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-07-23
  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              encode_html
  33              equal_url
  34              file_name
  35              is_forbidden_file
  36              mode_string
  37              multi_string
  38              upper_path);
  39
  40 # check_path()
  41 #
  42 # Check if a virtual path is above a virtual root directory
  43 # (currently no check if the path exists - check otherwise!)
  44 #
  45 # Params: 1. Virtual root directory
  46 #         2. Virtual path to check
  47 #
  48 # Return: Array with the physical and the cleaned virtual path;
  49 #         false, if the submitted path is above the root directory
  50
  51 sub check_path($$)
  52 {
  53  my ($root,$path) = @_;
  54
  55  # Clean root path
  56
  57  $root = abs_path($root);
  58  $root = File::Spec->canonpath($root);
  59
  60  $path =~ tr!\\!/!;
  61  $path =~ s!^/+!!;
  62  $path =  $root.'/'.$path;
  63
  64  # We extract the last part of the path and create the absolute path
  65
  66  my $first = upper_path($path);
  67  $first    = File::Spec->canonpath($first);
  68  $first    = abs_path($first);
  69
  70  my $last  = file_name($path);
  71
  72  if(-d $first.'/'.$last && (not -l $first.'/'.$last) && -r $first.'/'.$last && -x $first.'/'.$last)
  73  {
  74   $first = abs_path($first.'/'.$last);
  75   $last  = '';
  76  }
  77
  78  $path = File::Spec->canonpath($first.'/'.$last);
  79
  80  # Check if the path is above the root directory
  81
  82  return if(index($path,$root) != 0);
  83
  84  # Create short path name
  85
  86  my $short_path = substr($path,length($root));
  87  $short_path =~ tr!\\!/!;
  88  $short_path = '/'.$short_path if($short_path !~ m!^/!);
  89  $short_path = $short_path.'/' if($short_path !~ m!/$! && -d $path && not -l $path);
  90
  91  return ($path,$short_path);
  92 }
  93
  94 # clean_path()
  95 #
  96 # Clean up a path logically and replace backslashes with
  97 # normal slashes
  98 #
  99 # Params: Path
 100 #
 101 # Return: Cleaned path
 102
 103 sub clean_path($)
 104 {
 105  my $path =  shift;
 106  $path    =  File::Spec->canonpath($path);
 107  $path    =~ tr!\\!/!;
 108
 109  return $path;
 110 }
 111
 112 # devedit_reload()
 113 #
 114 # Create a HTTP redirection header to load Dev-Editor
 115 # with some other parameters
 116 #
 117 # Params: Hash Reference (will be merged to a query string)
 118 #         (optional)
 119 #
 120 # Return: HTTP redirection header (Scalar Reference)
 121
 122 sub devedit_reload(;$)
 123 {
 124  my $params = shift;
 125
 126  # Detect the protocol (simple HTTP or SSL encrypted HTTP)
 127  # and check if the server listens on the default port
 128
 129  my $protocol = '';
 130  my $port     = '';
 131
 132  if(https)
 133  {
 134   # SSL encrypted HTTP (HTTPS)
 135
 136   $protocol = 'https';
 137   $port     = ':'.$ENV{'SERVER_PORT'} if($ENV{'SERVER_PORT'} != 443);
 138  }
 139  else
 140  {
 141   # Simple HTTP
 142
 143   $protocol = 'http';
 144   $port     = ':'.$ENV{'SERVER_PORT'} if($ENV{'SERVER_PORT'} != 80);
 145  }
 146
 147  # The following code is grabbed from Template::_query of
 148  # Andre Malo's selfforum (http://sourceforge.net/projects/selfforum/)
 149  # and modified by Patrick Canterino
 150
 151  my $query = '';
 152
 153  if(ref($params) eq 'HASH')
 154  {
 155   $query = '?'.join ('&' =>
 156     map {
 157       (ref)
 158       ? map{escape ($_).'='.escape ($params -> {$_})} @{$params -> {$_}}
 159       : escape ($_).'='.escape ($params -> {$_})
 160     } keys %$params
 161   );
 162  }
 163
 164  # Create the redirection header
 165
 166  my $header = redirect($protocol.'://'.virtual_host.$port.$ENV{'SCRIPT_NAME'}.$query);
 167
 168  return \$header;
 169 }
 170
 171 # dos_wildcard_match()
 172 #
 173 # Check if a string matches against a DOS-style wildcard
 174 #
 175 # Params: 1. Pattern
 176 #         2. String
 177 #
 178 # Return: Status code (Boolean)
 179
 180 sub dos_wildcard_match($$)
 181 {
 182  my ($pattern,$string) = @_;
 183
 184  # The following part is stolen from File::DosGlob
 185
 186  # escape regex metachars but not glob chars
 187  $pattern =~ s:([].+^\-\${}[|]):\\$1:g;
 188  # and convert DOS-style wildcards to regex
 189  $pattern =~ s/\*/.*/g;
 190  $pattern =~ s/\?/.?/g;
 191
 192  return ($string =~ m|^$pattern$|is);
 193 }
 194
 195 # encode_html()
 196 #
 197 # Encode HTML control characters (< > " &)
 198 #
 199 # Params: String to encode
 200 #
 201 # Return: Encoded string
 202
 203 sub encode_html($)
 204 {
 205  my $string = shift;
 206
 207  $string =~ s/&/&amp;/g;
 208  $string =~ s/</&lt;/g;
 209  $string =~ s/>/&gt;/g;
 210  $string =~ s/"/&quot;/g;
 211
 212  return $string;
 213 }
 214
 215 # equal_url()
 216 #
 217 # Create URL equal to a file or directory
 218 #
 219 # Params: 1. HTTP root
 220 #         2. Relative path
 221 #
 222 # Return: Formatted link (String)
 223
 224 sub equal_url($$)
 225 {
 226  my ($root,$path) = @_;
 227  my $url;
 228
 229  $root =~ s!/+$!!;
 230  $path =~ s!^/+!!;
 231  $url  =  $root.'/'.$path;
 232
 233  return $url;
 234 }
 235
 236 # file_name()
 237 #
 238 # Return the last part of a path
 239 #
 240 # Params: Path
 241 #
 242 # Return: Last part of the path
 243
 244 sub file_name($)
 245 {
 246  my $path =  shift;
 247  $path    =~ tr!\\!/!;
 248
 249  unless($path =~ m!^/+$! || ($^O eq 'MSWin32' && $path =~ m!^[a-z]:/+$!i))
 250  {
 251   $path =~ s!/+$!!;
 252   $path =  substr($path,rindex($path,'/')+1);
 253  }
 254
 255  return $path;
 256 }
 257
 258 # is_forbidden_file()
 259 #
 260 # Check if a file is in the list of forbidden files
 261 #
 262 # Params: 1. Array Reference containing the list
 263 #         2. Filename to check
 264 #
 265 # Return: Status code (Boolean)
 266
 267 sub is_forbidden_file($$)
 268 {
 269  my ($list,$file) = @_;
 270  $file =~ s!/+$!!g;
 271
 272  foreach my $entry(@$list)
 273  {
 274   return 1 if($file eq $entry);
 275   return 1 if(index($file,$entry.'/') == 0);
 276  }
 277
 278  return;
 279 }
 280
 281 # mode_string()
 282 #
 283 # Convert a file mode number into a human readable string (rwxr-x-r-x)
 284 # (also supports SetUID, SetGID and Sticky Bit)
 285 #
 286 # Params: File mode number
 287 #
 288 # Return: Human readable mode string
 289
 290 sub mode_string($)
 291 {
 292  my $mode   = shift;
 293  my $string = '';
 294
 295  # User
 296
 297  $string  = ($mode & 00400) ? 'r' : '-';
 298  $string .= ($mode & 00200) ? 'w' : '-';
 299  $string .= ($mode & 00100) ? (($mode & 04000) ? 's' : 'x') :
 300                                ($mode & 04000) ? 'S' : '-';
 301
 302  # Group
 303
 304  $string .= ($mode & 00040) ? 'r' : '-';
 305  $string .= ($mode & 00020) ? 'w' : '-';
 306  $string .= ($mode & 00010) ? (($mode & 02000) ? 's' : 'x') :
 307                                ($mode & 02000) ? 'S' : '-';
 308
 309  # Other
 310
 311  $string .= ($mode & 00004) ? 'r' : '-';
 312  $string .= ($mode & 00002) ? 'w' : '-';
 313  $string .= ($mode & 00001) ? (($mode & 01000) ? 't' : 'x') :
 314                                ($mode & 01000) ? 'T' : '-';
 315
 316  return $string;
 317 }
 318
 319 # multi_string()
 320 #
 321 # Create a Hash Reference containing three forms of a string
 322 #
 323 # Params: String
 324 #
 325 # Return: Hash Reference:
 326 #         normal => Normal form of the string
 327 #         html   => HTML encoded form (see encode_html())
 328 #         url    => URL encoded form
 329
 330 sub multi_string($)
 331 {
 332  my $string = shift;
 333  my %multi;
 334
 335  $multi{'normal'} = $string;
 336  $multi{'html'}   = encode_html($string);
 337  $multi{'url'}    = escape($string);
 338
 339  return \%multi;
 340 }
 341
 342 # upper_path()
 343 #
 344 # Remove the last part of a path
 345 # (the resulting path contains a trailing slash)
 346 #
 347 # Params: Path
 348 #
 349 # Return: Truncated path
 350
 351 sub upper_path($)
 352 {
 353  my $path =  shift;
 354  $path    =~ tr!\\!/!;
 355
 356  unless($path =~ m!^/+$! || ($^O eq 'MSWin32' && $path =~ m!^[a-z]:/+$!i))
 357  {
 358   $path =~ s!/+$!!;
 359   $path =  substr($path,0,rindex($path,'/')+1);
 360  }
 361
 362  return $path;
 363 }
 364
 365 # it's true, baby ;-)
 366
 367 1;
 368
 369 #
 370 ### End ###