modules/Tool.pm

   1 package Tool;
   2
   3 #
   4 # Dev-Editor - Module Tool
   5 #
   6 # Some shared sub routines
   7 #
   8 # Author:        Patrick Canterino <patshaping@gmx.net>
   9 # Last modified: 2003-12-02
  10 #
  11
  12 use strict;
  13
  14 use vars qw(@EXPORT);
  15
  16 use CGI qw(redirect);
  17 use Cwd qw(abs_path);
  18 use File::Spec;
  19
  20 ### Export ###
  21
  22 use base qw(Exporter);
  23
  24 @EXPORT = qw(check_path
  25              clean_path
  26              devedit_reload
  27              file_name
  28              upper_path);
  29
  30 # check_path()
  31 #
  32 # Check, if a virtual path is above a virtual root directory
  33 # (currently no check if the path exists - check otherwise!)
  34 #
  35 # Params: 1. Virtual root directory
  36 #         2. Virtual path to check
  37 #
  38 # Return: Array with the physical and the cleaned virtual path;
  39 #         false, if the submitted path is above the root directory
  40
  41 sub check_path($$)
  42 {
  43  my ($root,$path) = @_;
  44
  45  # Clean root path
  46
  47  $root = abs_path($root);
  48  $root = File::Spec->canonpath($root);
  49
  50  $path =~ s!^/{1}!!;
  51  $path = $root."/".$path;
  52
  53  unless(-d $path)
  54  {
  55   # The path points to a file
  56   # We have to extract the directory name and create the absolute path
  57
  58   my $dir  = upper_path($path);
  59   my $file = file_name($path);
  60
  61   $dir  = abs_path($dir);
  62   $path = $dir."/".$file;
  63  }
  64  else
  65  {
  66   $path = abs_path($path);
  67  }
  68
  69  $path = File::Spec->canonpath($path);
  70
  71  # Check if the path is above the root directory
  72
  73  return if(index($path,$root) == -1);
  74
  75  # Create short path name
  76
  77  my $short_path = substr($path,length($root));
  78  $short_path =~ tr!\\!\/!;
  79  $short_path = "/".$short_path if($short_path !~ m!^/!);
  80  $short_path = $short_path."/" if($short_path !~ m!/$! && -d $path);
  81
  82  return ($path,$short_path);
  83 }
  84
  85 # clean_path()
  86 #
  87 # Clean up a path logically and replace backslashes with
  88 # normal slashes
  89 #
  90 # Params: Path
  91 #
  92 # Return: Cleaned path
  93
  94 sub clean_path($)
  95 {
  96  my $path =  shift;
  97  $path    =  File::Spec->canonpath($path);
  98  $path    =~ tr!\\!/!;
  99
 100  return $path;
 101 }
 102
 103 # devedit_reload()
 104 #
 105 # Create a HTTP redirection header to load Dev-Editor
 106 # with some other parameters
 107 #
 108 # Params: Hash Reference (will be merged to a query string)
 109 #
 110 # Return: HTTP redirection header (Scalar Reference)
 111
 112 sub devedit_reload($)
 113 {
 114  my $params = shift;
 115  my @list;
 116
 117  while(my ($param,$value) = each(%$params))
 118  {
 119   push(@list,$param."=".$value);
 120  }
 121
 122  my $query  = join("&",@list);
 123  my $header = redirect("http://$ENV{'HTTP_HOST'}$ENV{'SCRIPT_NAME'}?$query");
 124
 125  return \$header;
 126 }
 127
 128 # file_name()
 129 #
 130 # Returns the last path of a path
 131 #
 132 # Params: Path
 133 #
 134 # Return: Last part of the path
 135
 136 sub file_name($)
 137 {
 138  my $path =  shift;
 139  $path    =~ tr!\\!/!;
 140
 141  unless($path eq "/")
 142  {
 143   $path = substr($path,0,-1) if($path =~ m!/$!);
 144   $path = substr($path,rindex($path,"/")+1);
 145  }
 146
 147  return $path;
 148 }
 149
 150 # upper_path()
 151 #
 152 # Cut the last part of a path away
 153 #
 154 # Params: Path
 155 #
 156 # Return: Truncated path
 157
 158 sub upper_path($)
 159 {
 160  my $path =  shift;
 161  $path    =~ tr!\\!/!;
 162
 163  unless($path eq "/")
 164  {
 165   $path = substr($path,0,-1) if($path =~ m!/$!);
 166   $path = substr($path,0,rindex($path,"/")+1);
 167  }
 168
 169  return $path;
 170 }
 171
 172 # it's true, baby ;-)
 173
 174 1;
 175
 176 #
 177 ### End ###