modules/Tool.pm

   1 package Tool;
   2
   3 #
   4 # Dev-Editor - Module Tool
   5 #
   6 # Some shared sub routines
   7 #
   8 # Author:        Patrick Canterino <patrick@patshaping.de>
   9 # Last modified: 2005-04-22
  10 #
  11
  12 use strict;
  13
  14 use vars qw(@EXPORT);
  15
  16 use CGI qw(redirect
  17            escape
  18            virtual_host
  19            https);
  20
  21 use Cwd qw(abs_path);
  22 use File::Spec;
  23
  24 ### Export ###
  25
  26 use base qw(Exporter);
  27
  28 @EXPORT = qw(check_path
  29              clean_path
  30              devedit_reload
  31              dos_wildcard_match
  32              equal_url
  33              file_name
  34              mode_string
  35              upper_path);
  36
  37 # check_path()
  38 #
  39 # Check if a virtual path is above a virtual root directory
  40 # (currently no check if the path exists - check otherwise!)
  41 #
  42 # Params: 1. Virtual root directory
  43 #         2. Virtual path to check
  44 #
  45 # Return: Array with the physical and the cleaned virtual path;
  46 #         false, if the submitted path is above the root directory
  47
  48 sub check_path($$)
  49 {
  50  my ($root,$path) = @_;
  51
  52  # Clean root path
  53
  54  $root = abs_path($root);
  55  $root = File::Spec->canonpath($root);
  56
  57  $path =~ tr!\\!/!;
  58  $path =~ s!^/+!!;
  59  $path =  $root.'/'.$path;
  60
  61  # We extract the last part of the path and create the absolute path
  62
  63  my $first = upper_path($path);
  64  $first    = File::Spec->canonpath($first);
  65  $first    = abs_path($first);
  66
  67  my $last  = file_name($path);
  68  $last     = '' if($last eq '.');
  69
  70  if($last eq '..' || ($^O eq 'MSWin32' && $last =~ m!^\.\.\.+$!))
  71  {
  72   $first = abs_path($first.'/'.$last);
  73   $last  = '';
  74  }
  75
  76  $path = File::Spec->canonpath($first.'/'.$last);
  77
  78  # Check if the path is above the root directory
  79
  80  return if(index($path,$root) != 0);
  81
  82  # Create short path name
  83
  84  my $short_path = substr($path,length($root));
  85  $short_path =~ tr!\\!/!;
  86  $short_path = '/'.$short_path if($short_path !~ m!^/!);
  87  $short_path = $short_path.'/' if($short_path !~ m!/$! && -d $path && not -l $path);
  88
  89  return ($path,$short_path);
  90 }
  91
  92 # clean_path()
  93 #
  94 # Clean up a path logically and replace backslashes with
  95 # normal slashes
  96 #
  97 # Params: Path
  98 #
  99 # Return: Cleaned path
 100
 101 sub clean_path($)
 102 {
 103  my $path =  shift;
 104  $path    =  File::Spec->canonpath($path);
 105  $path    =~ tr!\\!/!;
 106
 107  return $path;
 108 }
 109
 110 # devedit_reload()
 111 #
 112 # Create a HTTP redirection header to load Dev-Editor
 113 # with some other parameters
 114 #
 115 # Params: Hash Reference (will be merged to a query string)
 116 #         (optional)
 117 #
 118 # Return: HTTP redirection header (Scalar Reference)
 119
 120 sub devedit_reload(;$)
 121 {
 122  my $params = shift;
 123
 124  # Detect the protocol (simple HTTP or SSL encrypted HTTP)
 125  # and check if the server listens on the default port
 126
 127  my $protocol = '';
 128  my $port     = '';
 129
 130  if(https)
 131  {
 132   # SSL encrypted HTTP (HTTPS)
 133
 134   $protocol = 'https';
 135   $port     = ':'.$ENV{'SERVER_PORT'} if($ENV{'SERVER_PORT'} != 443);
 136  }
 137  else
 138  {
 139   # Simple HTTP
 140
 141   $protocol = 'http';
 142   $port     = ':'.$ENV{'SERVER_PORT'} if($ENV{'SERVER_PORT'} != 80);
 143  }
 144
 145  # The following code is grabbed from Template::_query of
 146  # Andre Malo's selfforum (http://sourceforge.net/projects/selfforum/)
 147  # and modified by Patrick Canterino
 148
 149  my $query = '';
 150
 151  if(ref($params) eq 'HASH')
 152  {
 153   $query = '?'.join ('&' =>
 154     map {
 155       (ref)
 156       ? map{escape ($_).'='.escape ($params -> {$_})} @{$params -> {$_}}
 157       : escape ($_).'='.escape ($params -> {$_})
 158     } keys %$params
 159   );
 160  }
 161
 162  # Create the redirection header
 163
 164  my $header = redirect($protocol.'://'.virtual_host.$port.$ENV{'SCRIPT_NAME'}.$query);
 165
 166  return \$header;
 167 }
 168
 169 # dos_wildcard_match()
 170 #
 171 # Check if a string matches against a DOS-style wildcard
 172 #
 173 # Params: 1. Pattern
 174 #         2. String
 175 #
 176 # Return: Status code (Boolean)
 177
 178 sub dos_wildcard_match($$)
 179 {
 180  my ($pattern,$string) = @_;
 181
 182  # The following part is stolen from File::DosGlob
 183
 184  # escape regex metachars but not glob chars
 185  $pattern =~ s:([].+^\-\${}[|]):\\$1:g;
 186  # and convert DOS-style wildcards to regex
 187  $pattern =~ s/\*/.*/g;
 188  $pattern =~ s/\?/.?/g;
 189
 190  return ($string =~ m|^$pattern$|is);
 191 }
 192
 193 # equal_url()
 194 #
 195 # Create URL equal to a file or directory
 196 #
 197 # Params: 1. HTTP root
 198 #         2. Relative path
 199 #
 200 # Return: Formatted link (String)
 201
 202 sub equal_url($$)
 203 {
 204  my ($root,$path) = @_;
 205  my $url;
 206
 207  $root =~ s!/+$!!;
 208  $path =~ s!^/+!!;
 209  $url  =  $root.'/'.$path;
 210
 211  return $url;
 212 }
 213
 214 # file_name()
 215 #
 216 # Return the last part of a path
 217 #
 218 # Params: Path
 219 #
 220 # Return: Last part of the path
 221
 222 sub file_name($)
 223 {
 224  my $path =  shift;
 225  $path    =~ tr!\\!/!;
 226
 227  unless($path =~ m!^/+$! || ($^O eq 'MSWin32' && $path =~ m!^[a-z]:/+$!i))
 228  {
 229   $path =~ s!/+$!!;
 230   $path =  substr($path,rindex($path,'/')+1);
 231  }
 232
 233  return $path;
 234 }
 235
 236 # mode_string()
 237 #
 238 # Convert a file mode number into a human readable string (rwxr-x-r-x)
 239 # (also supports SetUID, SetGID and Sticky Bit)
 240 #
 241 # Params: File mode number
 242 #
 243 # Return: Human readable mode string
 244
 245 sub mode_string($)
 246 {
 247  my $mode   = shift;
 248  my $string = '';
 249
 250  # User
 251
 252  $string  = ($mode & 00400) ? 'r' : '-';
 253  $string .= ($mode & 00200) ? 'w' : '-';
 254  $string .= ($mode & 00100) ? (($mode & 04000) ? 's' : 'x') :
 255                                ($mode & 04000) ? 'S' : '-';
 256
 257  # Group
 258
 259  $string .= ($mode & 00040) ? 'r' : '-';
 260  $string .= ($mode & 00020) ? 'w' : '-';
 261  $string .= ($mode & 00010) ? (($mode & 02000) ? 's' : 'x') :
 262                                ($mode & 02000) ? 'S' : '-';
 263
 264  # Other
 265
 266  $string .= ($mode & 00004) ? 'r' : '-';
 267  $string .= ($mode & 00002) ? 'w' : '-';
 268  $string .= ($mode & 00001) ? (($mode & 01000) ? 't' : 'x') :
 269                                ($mode & 01000) ? 'T' : '-';
 270
 271  return $string;
 272 }
 273
 274 # upper_path()
 275 #
 276 # Remove the last part of a path
 277 # (the resulting path contains a trailing slash)
 278 #
 279 # Params: Path
 280 #
 281 # Return: Truncated path
 282
 283 sub upper_path($)
 284 {
 285  my $path =  shift;
 286  $path    =~ tr!\\!/!;
 287
 288  unless($path =~ m!^/+$! || ($^O eq 'MSWin32' && $path =~ m!^[a-z]:/+$!i))
 289  {
 290   $path =~ s!/+$!!;
 291   $path =  substr($path,0,rindex($path,'/')+1);
 292  }
 293
 294  return $path;
 295 }
 296
 297 # it's true, baby ;-)
 298
 299 1;
 300
 301 #
 302 ### End ###