From 3e6b9e338fe5ea06b487202fe54217f2082cd13d Mon Sep 17 00:00:00 2001 From: pcanterino <> Date: Tue, 23 Sep 2003 12:15:14 +0000 Subject: [PATCH] Initial version --- devedit.pl | 106 +++++++++ modules/Command.pm | 480 ++++++++++++++++++++++++++++++++++++++++ modules/File/Access.pm | 146 ++++++++++++ modules/File/UseList.pm | 247 +++++++++++++++++++++ modules/Output.pm | 174 +++++++++++++++ modules/Tool.pm | 171 ++++++++++++++ uselist | 0 uselist.lock | 0 8 files changed, 1324 insertions(+) create mode 100644 devedit.pl create mode 100644 modules/Command.pm create mode 100644 modules/File/Access.pm create mode 100644 modules/File/UseList.pm create mode 100644 modules/Output.pm create mode 100644 modules/Tool.pm create mode 100644 uselist create mode 100644 uselist.lock diff --git a/devedit.pl b/devedit.pl new file mode 100644 index 0000000..42e1d40 --- /dev/null +++ b/devedit.pl @@ -0,0 +1,106 @@ +#!C:/Programme/Perl/bin/perl.exe -w + +# +# Dev-Editor +# +# Dev-Editor's main program +# +# Author: Patrick Canterino +# Last modified: 09-22-2003 +# + +use strict; +use CGI::Carp qw(fatalsToBrowser); + +use lib 'modules'; + +use CGI; +use Command; +use File::UseList; +use Output; +use Tool; + +our $VERSION = '0.7'; + +### Settings ### + +our %config = ( + fileroot => 'D:/Server/WWW/Root', + httproot => '/', + uselist_file => 'uselist', + lock_file => 'uselist.lock', + lock_timeout => '10' + ); + +### End Settings ### + +# Read the most important form data + +my $cgi = new CGI; + +my $command = $cgi->param('command') || 'show'; +my $file = $cgi->param('file') || '/'; + +# This check has to be performed first, or abs_path() will be confused + +if(-e clean_path($config{'fileroot'}."/".$file)) +{ + if(my ($physical,$virtual) = check_path($config{'fileroot'},$file)) + { + # Copied from old Dev-Editor (great idea) + + my %dispatch = ('show' => \&exec_show, + 'beginedit' => \&exec_beginedit, + 'canceledit' => \&exec_unlock, + 'endedit' => \&exec_endedit, + # 'mkdir' => \&exec_mkdir, + # 'mkfile' => \&exec_mkfile, + 'workwithfile' => \&exec_workwithfile, + # 'copy' => \&exec_copy, + # 'rename' => \&exec_rename, + 'remove' => \&exec_remove, + 'unlock' => \&exec_unlock + ); + + # Create a File::UseList object and load the list + + my $uselist = new File::UseList(listfile => $config{'uselist_file'}, + lockfile => $config{'lock_file'}, + timeout => $config{'lock_timeout'}); + + $uselist->lock or abort("Locking failed. Try it again in a moment. If the problem persists, ask someone to recreate the lockfile ($config{'lock_file'})."); + $uselist->load; + + # Create a hash with data submitted by user + # (the CGI and the File::UseList objects will also be included) + + my %data = (physical => $physical, + virtual => $virtual, + new_physical => '', + new_virtual => '', + uselist => $uselist, + cgi => $cgi); + + unless($dispatch{$command}) + { + $uselist->unlock; + abort("Unknown command: $command"); + } + + my $output = &{$dispatch{$command}}(\%data,\%config); # Execute the command... + + $uselist->unlock; # ... unlock the list with used files... + print $$output; # ... and print the output of the command + } + else + { + abort("Accessing files and directories above the virtual root directory is forbidden."); + } +} +else +{ + abort("File/directory does not exist."); +} + +# +### End ### \ No newline at end of file diff --git a/modules/Command.pm b/modules/Command.pm new file mode 100644 index 0000000..1a39d67 --- /dev/null +++ b/modules/Command.pm @@ -0,0 +1,480 @@ +package Command; + +# +# Dev-Editor - Module Command +# +# Execute Dev-Editor's commands +# +# Author: Patrick Canterino +# Last modified: 09-22-2003 +# + +use strict; + +use vars qw(@EXPORT + $script); + +use CGI qw(header + redirect); + +use File::Access; +use File::Copy; + +use HTML::Entities; +use Output; +use POSIX qw(strftime); +use Tool; + +$script = $ENV{'SCRIPT_NAME'}; + +### Export ### + +use base qw(Exporter); + +@EXPORT = qw(exec_show + exec_beginedit + exec_endedit + exec_mkfile + exec_mkdir + exec_workwithfile + exec_copy + exec_rename + exec_remove + exec_unlock); + +# exec_show() +# +# View a directory or a file +# +# Params: 1. Reference to user input hash +# 2. Reference to config hash +# +# Return: Output of the command (Scalar Reference) + +sub exec_show($$$) +{ + my ($data,$config) = @_; + my $physical = $data->{'physical'}; + my $virtual = $data->{'virtual'}; + my $output; + + if(-d $physical) + { + # Create directory listing + + my $direntries = dir_read($physical); + return error("Reading of directory $virtual failed") unless($direntries); + + my $files = $direntries->{'files'}; + my $dirs = $direntries->{'dirs'}; + + $output .= htmlhead("Directory listing of $virtual"); + $output .= equal_url($config->{'httproot'},$virtual); + $output .= "
\n\n
\n";
+
+  # Create the link to the upper directory
+  # (only if we are not in the root directory)
+
+  unless($virtual eq "/")
+  {
+   my $upper = $physical."/..";
+   my @stat  = stat($upper);
+
+   $output .= "  [SUBDIR]  ";
+   $output .= strftime("%d.%m.%Y %H:%M",localtime($stat[9]));
+   $output .= " " x 10;
+   $output .= "../\n";
+  }
+
+  # Get the longest file/directory name
+
+  my $max_name_len = 0;
+
+  foreach(@$dirs,@$files)
+  {
+   my $length    = length($_);
+   $max_name_len = $length if($length > $max_name_len);
+  }
+
+  # Directories
+
+  foreach my $dir(@$dirs)
+  {
+   my @stat = stat($physical."/".$dir);
+
+   $output .= "  ";
+   $output .= "[SUBDIR]  ";
+   $output .= strftime("%d.%m.%Y %H:%M",localtime($stat[9]));
+   $output .= " " x 10;
+   $output .= "".encode_entities($dir)."/\n";
+  }
+
+  # Files
+
+  foreach my $file(@$files)
+  {
+   my @stat      = stat($physical."/".$file);
+   my $virt_path = $virtual.$file;
+   my $in_use    = $data->{'uselist'}->in_use($virtual.$file);
+
+   $output .= " " x (10 - length($stat[7]));
+   $output .= $stat[7];
+   $output .= "  ";
+   $output .= strftime("%d.%m.%Y %H:%M",localtime($stat[9]));
+   $output .= ($in_use) ? " (IN USE) " : " " x 10;
+   $output .= encode_entities($file);
+   $output .= " " x ($max_name_len - length($file))."\t  (";
+   $output .= "View | ";
+
+   $output .= ($in_use)
+              ? 'Edit'
+              : "Edit";
+
+   $output .= " | Do other stuff)\n";
+  }
+
+  $output .= "
\n\n
\n\n"; + $output .= < + +Create new directory: +$virtual + + +Create new file: +$virtual + + + +
+END + $output .= htmlfoot; + } + else + { + # View a file + + # Check on binary files + + if(-B $physical) + { + # Binary file + + return error("This editor is not able to view/edit binary files."); + } + else + { + # Text file + + $output = htmlhead("Contents of file $virtual"); + $output .= equal_url($config->{'httproot'},$virtual); + $output .= dir_link($virtual); + + $output .= '
'."\n"; + $output .= '
'."\n";
+   $output .= encode_entities(${file_read($physical)});
+   $output .= "\n
\n
"; + + $output .= htmlfoot; + } + } + + return \$output +} + +# exec_beginedit +# +# Lock a file and display a form to edit it +# +# Params: 1. Reference to user input hash +# 2. Reference to config hash +# +# Return: Output of the command (Scalar Reference) + +sub exec_beginedit($$) +{ + my ($data,$config) = @_; + my $physical = $data->{'physical'}; + my $virtual = $data->{'virtual'}; + my $uselist = $data->{'uselist'}; + + return error("You cannot edit directories.") if(-d $physical); + return error_in_use($virtual) if($uselist->in_use($virtual)); + + # Check on binary files + + if(-B $physical) + { + # Binary file + + return error("This editor is not able to view/edit binary files."); + } + else + { + # Text file + + $uselist->add_file($virtual); + $uselist->save; + + my $dir = upper_path($virtual); + my $content = encode_entities(${file_read($physical)}); + + my $output = htmlhead("Edit file $virtual"); + $output .= equal_url($config->{'httproot'},$virtual); + $output .= <Caution! This file is locked for other users while you are editing it. To unlock it, click Save and exit or Exit WITHOUT saving. Please don't click the Reload button in your browser! This will confuse the editor.

+ +
+ + +

+
+ +
+ + + + + + + + + + + + +
Save as new file: $dir Encode ISO-8859-1 special chars
+ + +
+END + + $output .= htmlfoot; + + return \$output; + } +} + +# exec_endedit() +# +# Save a file, unlock it and return to directory view +# +# Params: 1. Reference to user input hash +# 2. Reference to config hash +# +# Return: Output of the command (Scalar Reference) + +sub exec_endedit($$) +{ + my ($data,$config) = @_; + my $physical = $data->{'physical'}; + my $virtual = $data->{'virtual'}; + my $content = $data->{'cgi'}->param('filecontent'); + + return error("You cannot edit directories.") if(-d $physical); + + if($data->{'cgi'}->param('encode_iso')) + { + # Encode all ISO-8859-1 special chars + + $content = encode_entities($content,"\200-\377"); + } + + if(file_save($physical,\$content)) + { + # Saving of the file was successfull - so unlock it! + + return exec_unlock($data,$config); + } + else + { + return error("Saving of file '$virtual' failed'"); + } +} + +# exec_mkfile() +# +# Create a file and return to directory view +# +# Params: 1. Reference to user input hash +# 2. Reference to config hash +# +# Return: Output of the command (Scalar Reference) + +sub exec_mkfile($$) +{ + 1; +} + +# exec_mkdir() +# +# Create a directory and return to directory view +# +# Params: 1. Reference to user input hash +# 2. Reference to config hash +# +# Return: Output of the command (Scalar Reference) + +sub exec_mkdir($$) +{ + 1; +} + +# exec_workwithfile() +# +# Display a form for renaming/copying/deleting/unlocking a file +# +# Params: 1. Reference to user input hash +# 2. Reference to config hash +# +# Return: Output of the command (Scalar Reference) + +sub exec_workwithfile($$) +{ + my ($data,$config) = @_; + my $physical = $data->{'physical'}; + my $virtual = $data->{'virtual'}; + my $unused = $data->{'uselist'}->unused($virtual); + + my $output = htmlhead("Work with file $virtual"); + $output .= equal_url($config->{'httproot'},$virtual); + $output .= dir_link($virtual); + $output .= "

Note: On UNIX systems, filenames are case-sensitive!

\n\n"; + + $output .= "

Someone else is currently editing this file. So not all features are available.

\n\n" unless($unused); + + $output .= < + +

Copy

+ +

Copy file '$virtual' to:

+ +
+ +END + + if($unused) + { + $output .= <Move/rename + +

Move/Rename file '$virtual' to:

+ +
+ +

Delete

+ +
+ + +

+
+END + } + else + { + $output .= <Unlock file + +

Someone else is currently editing this file. At least, the file is marked so. Maybe, someone who was editing the file, has forgotten to unlock it. In this case (and only in this case) you can unlock the file using this button:

+ +
+ + +

+
+END + } + + $output .= "\n
"; + $output .= htmlfoot; + + return \$output; +} + +# exec_copy() +# +# Copy a file and return to directory view +# +# Params: 1. Reference to user input hash +# 2. Reference to config hash +# +# Return: Output of the command (Scalar Reference) + +sub exec_copy($$) +{ + 1; +} + +# exec_rename() +# +# Rename/move a file and return to directory view +# +# Params: 1. Reference to user input hash +# 2. Reference to config hash +# +# Return: Output of the command (Scalar Reference) + +sub exec_rename($$) +{ + 1; +} + +# exec_remove() +# +# Remove a file and return to directory view +# +# Params: 1. Reference to user input hash +# 2. Reference to config hash +# +# Return: Output of the command (Scalar Reference) + +sub exec_remove($$) +{ + my ($data,$config) = @_; + my $physical = $data->{'physical'}; + my $virtual = $data->{'virtual'}; + + return error_in_use($virtual) if($data->{'uselist'}->in_use($virtual)); + + my $dir = upper_path($virtual); + + unlink($physical); + + my $output = redirect("http://$ENV{'HTTP_HOST'}$script?command=show&file=$dir"); + return \$output; +} + +# exec_unlock() +# +# Remove a file from the list of used files and +# return to directory view +# +# Params: 1. Reference to user input hash +# 2. Reference to config hash +# +# Return: Output of the command (Scalar Reference) + +sub exec_unlock($$) +{ + my ($data,$config) = @_; + my $physical = $data->{'physical'}; + my $virtual = $data->{'virtual'}; + my $uselist = $data->{'uselist'}; + + my $dir = upper_path($virtual); + + $uselist->remove_file($virtual); + $uselist->save; + + my $output = redirect("http://$ENV{'HTTP_HOST'}$script?command=show&file=$dir"); + return \$output; +} + +# it's true, baby ;-) + +1; + +# +### End ### \ No newline at end of file diff --git a/modules/File/Access.pm b/modules/File/Access.pm new file mode 100644 index 0000000..81b6851 --- /dev/null +++ b/modules/File/Access.pm @@ -0,0 +1,146 @@ +package File::Access; + +# +# Dev-Editor - Module File::Access +# +# Some simple routines for doing things with files +# with only one command +# +# Author: Patrick Canterino +# Last modified: 09-20-2003 +# + +use strict; + +use vars qw(@EXPORT); + +use Carp qw(croak); +use File::Spec; + +### Export ### + +use base qw(Exporter); + +@EXPORT = qw(dir_read + file_create + file_read + file_save); + +# dir_read() +# +# Collect the files and directories in a directory +# +# Params: Directory +# +# Return: Hash reference: dirs => directories +# files => files + +sub dir_read($) +{ + my $dir = shift; + local *DIR; + + return unless(-d $dir); + + # Get all the entries in the directory + + opendir(DIR,$dir) or return; + my @entries = readdir(DIR); + closedir(DIR) or return; + + # Sort the entries + + @entries = sort(@entries); + + my @files; + my @dirs; + + foreach my $entry(@entries) + { + next if($entry eq "." || $entry eq ".."); + + if(-d File::Spec->canonpath($dir."/".$entry)) + { + push(@dirs,$entry); + } + else + { + push(@files,$entry); + } + } + + return {dirs => \@dirs, files => \@files}; +} + +# file_create() +# +# Create a file +# +# Params: File to create +# +# Return: true on success; +# false on error or if the file already exists + +sub file_create($) +{ + my $file = shift; + local *FILE; + + return if(-e $file); + + open(FILE,">",$file) or return; + close(FILE) or return; + + return 1; +} + +# file_read() +# +# Read out a file completely +# +# Params: File +# +# Return: Contents of the file (Scalar Reference) + +sub file_read($) +{ + my $file = shift; + local *FILE; + + open(FILE,"<",$file); + read(FILE, my $content, -s $file); + close(FILE); + + return \$content; +} + +# file_save() +# +# Save a file +# +# Params: 1. File +# 2. File content as Scalar Reference +# +# Return: Status Code (Boolean) + +sub file_save($$) +{ + my ($file,$content) = @_; + my $temp = $file.".temp"; + local *FILE; + + open(FILE,">",$temp) or return; + print FILE $$content; + close(FILE) or return; + + rename($temp,$file) or return; + + return 1; +} + +# it's true, baby ;-) + +1; + +# +### End ### \ No newline at end of file diff --git a/modules/File/UseList.pm b/modules/File/UseList.pm new file mode 100644 index 0000000..626bd90 --- /dev/null +++ b/modules/File/UseList.pm @@ -0,0 +1,247 @@ +package File::UseList; + +# +# File::UseList +# +# Fuehren einer Liste mit Dateien, auf die zur Zeit zugegriffen wird +# (basiert auf Filing::UseList von Roland Bluethgen ) +# +# Autor: Patrick Canterino +# Letzte Aenderung: 20.9.2003 +# + +use strict; + +use Carp qw(croak); + +our $VERSION = '1.0'; + +# new() +# +# Konstruktor +# +# Parameter: Hash: listfile => Datei mit der Liste der benutzten Dateien +# lockfile => Lock-Datei +# timeout => Lock-Timeout in Sekunden (Standard: 10) +# +# Rueckgabe: File::UseList-Objekt + +sub new(%) +{ + my ($class,%args) = @_; + + # Pruefen, ob wir alle Informationen erhalten haben + + croak "Missing path of list file" unless($args{'listfile'}); + croak "Missing path of lockfile" unless($args{'lockfile'}); + $args{'timeout'} = 10 unless($args{'timeout'}); # Standard-Timeout + + my $self = \%args; + $self->{'files'} = []; + + return bless($self,$class); +} + +# lock() +# +# Datei mit Liste sperren +# (Lock-Datei loeschen) +# +# Parameter: -keine- +# +# Rueckgabe: Status-Code (Boolean) + +sub lock +{ + my $self = shift; + my $lockfile = $self->{'lockfile'}; + my $timeout = $self->{'timeout'}; + + # Versuche, einmal pro Sekunde die Datei zu loeschen + # bis das Timeout erreicht ist + + for(my $x=$timeout;$x>=0;$x--) + { + unlink($lockfile) and return 1; + sleep(1); + } + + # Timeout + + return; +} + +# unlock() +# +# Datei mit Liste freigeben +# (Lock-Datei anlegen) +# +# Parameter: -keine- +# +# Rueckgabe: Status-Code (Boolean) + +sub unlock +{ + my $self = shift; + my $lockfile = $self->{'lockfile'}; + local *LOCKFILE; + + return 1 if(-f $lockfile); # Hmmm... + + open(LOCKFILE,">",$lockfile) or return; + close(LOCKFILE) or return; + + return 1; +} + +# load() +# +# Liste mit Dateien laden +# +# Parameter: -keine- +# +# Rueckgabe: Status-Code (Boolean) + +sub load +{ + my $self = shift; + my $file = $self->{'listfile'}; + local *FILE; + + # Datei auslesen und zeilenweise aufteilen + + open(FILE,"<".$file) or return; + read(FILE, my $content, -s $file); + close(FILE) or return; + + my @files = split(/\015\012|\012|\015/,$content); + + # Unbrauchbare Zeilen entfernen + + for(my $x=0;$x<@files;$x++) + { + if($files[$x] eq "" || $files[$x] =~ /^\s+$/) + { + splice(@files,$x,1); + $x--; # <-- sehr wichtig! + } + } + + $self->{'files'} = \@files; + return 1; +} + +# save() +# +# Liste mit Dateien speichern +# +# Parameter: -keine- +# +# Rueckgabe: Status-Code (Boolean) + +sub save +{ + my $self = shift; + my $file = $self->{'listfile'}; + my $temp = $file.".temp"; + my $files = $self->{'files'}; + local *FILE; + + my $data = (@$files) ? join("\n",@$files)."\n" : ''; + + open(FILE,">",$temp) or return; + print FILE $data; + close(FILE) or return; + + rename($temp,$file) and return 1; + + # Mist + + return; +} + +# add_file() +# +# Datei zur Liste hinzufuegen +# +# Parameter: Datei + +sub add_file($) +{ + my ($self,$file) = @_; + my $files = $self->{'files'}; + + # Pruefen, ob die Datei nicht schon in der Liste vorhanden ist + + return if($self->in_use($file)); + + push(@$files,$file); +} + +# remove_file() +# +# Datei aus der Liste entfernen +# +# Parameter: Datei + +sub remove_file($) +{ + my ($self,$file) = @_; + my $files = $self->{'files'}; + + # Pruefen, ob die Datei ueberhaupt in der Liste vorhanden ist + + return if($self->unused($file)); + + # Datei entfernen + + for(my $x=0;$x<@$files;$x++) + { + if($files->[$x] eq $file) + { + splice(@$files,$x,1); + last; + } + } +} + +# in_use() +# +# Pruefen, ob eine Datei in der Liste vorhanden ist +# +# Parameter: Zu pruefende Datei +# +# Rueckgabe: Status-Code (Boolean) + +sub in_use($) +{ + my ($self,$file) = @_; + my $files = $self->{'files'}; + + foreach(@$files) + { + return 1 if($_ eq $file); + } + + return; +} + +# unused() +# +# Pruefen, ob eine Datei nicht in der Liste vorhanden ist +# +# Parameter: Zu pruefende Datei +# +# Rueckgabe: Status-Code (Boolean) + +sub unused($) +{ + return not shift->in_use(shift); +} + +# it's true, baby ;-) + +1; + +# +### Ende ### \ No newline at end of file diff --git a/modules/Output.pm b/modules/Output.pm new file mode 100644 index 0000000..e8d4bad --- /dev/null +++ b/modules/Output.pm @@ -0,0 +1,174 @@ +package Output; + +# +# Dev-Editor - Module Output +# +# HTML generating routines +# +# Author: Patrick Canterino +# Last modified: 09-22-2003 +# + +use strict; + +use vars qw(@EXPORT); + +use CGI qw(header); +use HTML::Entities; +use Tool; + +### Export ### + +use base qw(Exporter); + +@EXPORT = qw(htmlhead + htmlfoot + error + abort + error_in_use + equal_url + dir_link); + +# htmlhead() +# +# Generate the head of a HTML document +# +# Params: Title and heading +# +# Return: Head for the HTML document + +sub htmlhead($) +{ + my $title = shift; + + my $html = header(-type => "text/html"); + + $html .= < + + + +$title + + + + +

$title

+ +END + + return $html; +} + +# htmlfoot() +# +# Generate the foot of a HTML document +# +# Params: -nothing- +# +# Return: Foot for the HTML document + +sub htmlfoot +{ + return "\n\n"; +} + +# error() +# +# Format an error message +# +# Params: Error message +# +# Return: Formatted message (Scalar Reference) + +sub error($) +{ + my $message = shift; + + my $output = htmlhead("Error"); + $output .= "

$message

"; + $output .= htmlfoot; + + return \$output; +} + +# abort() +# +# Print and error message and exit script +# +# Params: Error message + +sub abort($) +{ + my $output = error(shift); + print $$output; + exit; +} + +# error_in_use() +# +# Create a message, that a file is currently in use +# +# Params: File, which is in use +# +# Return: Formatted message (Scalar Reference) + +sub error_in_use($) +{ + my $file = encode_entities(shift); + my $dir = upper_path($file); + + my $message = htmlhead("File in use"); + $message .= "

The file '$file' is currently editet by someone else.

\n\n"; + $message .= "

Back to $dir

"; + $message .= htmlfoot; + + return \$message; +} + +# equal_url() +# +# Create an "equals"-link and print it out +# +# Params: 1. HTTP root +# 2. Relative path +# +# Return: Formatted link (String) + +sub equal_url($$) +{ + my ($root,$path) = @_; + my $url; + + $root =~ s!/$!!; + $path =~ s!^/!!; + $url = $root."/".$path; + $url = encode_entities($url); + + return "

(equals $url)

\n\n"; +} + +# dir_link() +# +# Create the link to the directory of a file and +# print it out +# +# Params: File +# +# Return: Formatted link (String) + +sub dir_link($) +{ + my $dir = upper_path(shift); + $dir = encode_entities($dir); + + return "

Back to $dir

\n\n"; +} + +# it's true, baby ;-) + +1; + +# +### End ### \ No newline at end of file diff --git a/modules/Tool.pm b/modules/Tool.pm new file mode 100644 index 0000000..47b73e6 --- /dev/null +++ b/modules/Tool.pm @@ -0,0 +1,171 @@ +package Tool; + +# +# Dev-Editor - Module Tool +# +# Some shared sub routines +# +# Author: Patrick Canterino +# Last modified: 09-22-2003 +# + +use strict; + +use vars qw(@EXPORT); + +use Carp qw(croak); + +use Cwd qw(abs_path); +use File::Basename; +use File::Spec; + +### Export ### + +use base qw(Exporter); + +@EXPORT = qw(check_path + clean_path + filemode + upper_path); + +# check_path() +# +# Check, if a virtual path is above a virtual root directory +# (currently no check if the path exists - check otherwise!) +# +# Params: 1. Virtual root directory +# 2. Virtual path to check +# +# Return: Array with the physical and the cleaned virtual path; +# false, if the submitted path is above the root directory + +sub check_path($$) +{ + my ($root,$path) = @_; + + # Clean root path + + $root = abs_path($root); + $root = File::Spec->canonpath($root); + + $path =~ s!^/{1}!!; + $path = $root."/".$path; + + unless(-d $path) + { + # The path points to a file + # We have to extract the directory name and create the absolute path + + my @pathinfo = fileparse($path); + + # This is only to avoid errors + + my $basename = $pathinfo[0] || ''; + my $dir = $pathinfo[1] || ''; + my $ext = $pathinfo[2] || ''; + + $dir = abs_path($dir); + + $path = $dir."/".$basename.$ext; + } + else + { + $path = abs_path($path); + } + + $path = File::Spec->canonpath($path); + + # Check if the path is above the root directory + + return if(index($path,$root) == -1); + + # Create short path name + + my $short_path = substr($path,length($root)); + $short_path =~ tr!\\!\/!; + $short_path = "/".$short_path unless($short_path =~ m!^/!); + $short_path = $short_path."/" if($short_path !~ m!/$! && -d $path); + + return ($path,$short_path); +} + +# clean_path() +# +# Clean up a path logically and replace backslashes with +# normal slashes +# +# Params: Path +# +# Return: Cleaned path + +sub clean_path($) +{ + my $path = shift; + $path = File::Spec->canonpath($path); + $path =~ tr!\\!/!; + + return $path; +} + +# filemode() +# +# Creates a readable string of a UNIX filemode number +# (copied from Tool.pm of Dev-Editor 0.1.4) +# +# Params: Filemode as number +# +# Return: Filemode as readable string + +sub filemode($) +{ + my ($modestring, $ur, $uw, $ux, $gr, $gw, $gx, $or, $ow, $ox); + my $mode = shift; + + $ur = ($mode & 0400) ? "r" : "-"; # User Read + $uw = ($mode & 0200) ? "w" : "-"; # User Write + $ux = ($mode & 0100) ? "x" : "-"; # User eXecute + $gr = ($mode & 0040) ? "r" : "-"; # Group Read + $gw = ($mode & 0020) ? "w" : "-"; # Group Write + $gx = ($mode & 0010) ? "x" : "-"; # Group eXecute + $or = ($mode & 0004) ? "r" : "-"; # Other Read + $ow = ($mode & 0002) ? "w" : "-"; # Other Write + $ox = ($mode & 0001) ? "x" : "-"; # Other eXecute + + # build a readable mode string (rwxrwxrwx) + return $ur . $uw . $ux . $gr . $gw . $gx . $or . $ow . $ox; +} + +# upper_path() +# +# Truncate a path in one of the following ways: +# +# - If the path points to a directory, the upper directory +# will be returned. +# - If the path points to a file, the directory containing +# the file will be returned. +# +# Params: Path +# +# Return: Truncated path + +sub upper_path($) +{ + my $path = shift; + $path =~ tr!\\!/!; + + unless($path eq "/") + { + $path = substr($path,0,-1) if($path =~ m!/$!); + $path = substr($path,0,rindex($path,"/")); + $path = $path."/"; + } + + return $path; +} + +# it's true, baby ;-) + +1; + +# +### End ### \ No newline at end of file diff --git a/uselist b/uselist new file mode 100644 index 0000000..e69de29 diff --git a/uselist.lock b/uselist.lock new file mode 100644 index 0000000..e69de29 -- 2.34.1