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: 2011-01-05
  10 #
  11 # Copyright (C) 1999-2000 Roland Bluethgen, Frank Schoenmann
  12 # Copyright (C) 2003-2011 Patrick Canterino
  13 # All Rights Reserved.
  14 #
  15 # This file can be distributed and/or modified under the terms of
  16 # of the Artistic License 1.0 (see also the LICENSE file found at
  17 # the top level of the Dev-Editor distribution).
  18 #
  19
  20 use strict;
  21
  22 use vars qw(@EXPORT);
  23
  24 use CGI qw(redirect
  25            escape
  26            virtual_host
  27            https);
  28
  29 use Cwd qw(abs_path);
  30 use File::Spec;
  31
  32 ### Export ###
  33
  34 use base qw(Exporter);
  35
  36 @EXPORT = qw(check_path
  37              clean_path
  38              devedit_reload
  39              dos_wildcard_match
  40              encode_html
  41              equal_url
  42              file_name
  43              in_array
  44              is_archive
  45              is_disabled_command
  46              is_forbidden_file
  47              mode_string
  48              multi_string
  49              upper_path);
  50
  51 my @archive_exts = ('.zip',     '.tar', '.gz',
  52                     '.tar.gz',  '.tgz', '.bz2',
  53                     '.tar.bz2', '.tbz', '.tbz2',
  54                     '.Z');
  55
  56 # check_path()
  57 #
  58 # Check if a virtual path is above a virtual root directory
  59 # (currently no check if the path exists - check otherwise!)
  60 #
  61 # Params: 1. Virtual root directory
  62 #         2. Virtual path to check
  63 #
  64 # Return: Array with the physical and the cleaned virtual path;
  65 #         false, if the submitted path is above the root directory
  66
  67 sub check_path($$)
  68 {
  69  my ($root,$path) = @_;
  70
  71  # Clean root path
  72
  73  $root = abs_path($root);
  74  $root = File::Spec->canonpath($root);
  75
  76  $path =~ tr!\\!/!;
  77  $path =~ s!^/+!!;
  78  $path =  $root.'/'.$path;
  79
  80  # We extract the last part of the path and create the absolute path
  81
  82  my $first = upper_path($path);
  83  $first    = File::Spec->canonpath($first);
  84  $first    = abs_path($first);
  85
  86  my $last  = file_name($path);
  87  $last     = '' if($last eq '.');
  88
  89  if($last eq '..' || ($^O eq 'MSWin32' && $last =~ m!^\.\.\.+$!))
  90  {
  91   $first = abs_path($first.'/'.$last);
  92   $last  = '';
  93  }
  94
  95  $path = File::Spec->canonpath($first.'/'.$last);
  96
  97  # Check if the path is above the root directory
  98
  99  return if(index($path,$root) != 0);
 100  return if(substr($path,length($root)) && not File::Spec->file_name_is_absolute(substr($path,length($root))));
 101
 102  # Create short path name
 103
 104  my $short_path = substr($path,length($root));
 105  $short_path =~ tr!\\!/!;
 106  $short_path = '/'.$short_path if($short_path !~ m!^/!);
 107  $short_path = $short_path.'/' if($short_path !~ m!/$! && -d $path && not -l $path);
 108
 109  return ($path,$short_path);
 110 }
 111
 112 # clean_path()
 113 #
 114 # Clean up a path logically and replace backslashes with
 115 # normal slashes
 116 #
 117 # Params: Path
 118 #
 119 # Return: Cleaned path
 120
 121 sub clean_path($)
 122 {
 123  my $path =  shift;
 124  $path    =  File::Spec->canonpath($path);
 125  $path    =~ tr!\\!/!;
 126
 127  return $path;
 128 }
 129
 130 # devedit_reload()
 131 #
 132 # Create a HTTP redirection header to load Dev-Editor
 133 # with some other parameters
 134 #
 135 # Params: Hash Reference (will be merged to a query string)
 136 #         (optional)
 137 #
 138 # Return: HTTP redirection header (Scalar Reference)
 139
 140 sub devedit_reload(;$)
 141 {
 142  my $params = shift;
 143
 144  # Detect the protocol (simple HTTP or SSL encrypted HTTP)
 145  # and check if the server listens on the default port
 146
 147  my $protocol = '';
 148  my $port     = '';
 149
 150  if(https)
 151  {
 152   # SSL encrypted HTTP (HTTPS)
 153
 154   $protocol = 'https';
 155   $port     = ':'.$ENV{'SERVER_PORT'} if($ENV{'SERVER_PORT'} != 443);
 156  }
 157  else
 158  {
 159   # Simple HTTP
 160
 161   $protocol = 'http';
 162   $port     = ':'.$ENV{'SERVER_PORT'} if($ENV{'SERVER_PORT'} != 80);
 163  }
 164
 165  # The following code is grabbed from Template::_query of
 166  # Andre Malo's selfforum (http://sourceforge.net/projects/selfforum/)
 167  # and modified by Patrick Canterino
 168
 169  my $query = '';
 170
 171  if(ref($params) eq 'HASH')
 172  {
 173   $query = '?'.join ('&' =>
 174     map {
 175       (ref)
 176       ? map{escape ($_).'='.escape ($params -> {$_})} @{$params -> {$_}}
 177       : escape ($_).'='.escape ($params -> {$_})
 178     } keys %$params
 179   );
 180  }
 181
 182  # Create the redirection header
 183
 184  my $header = redirect($protocol.'://'.virtual_host.$port.$ENV{'SCRIPT_NAME'}.$query);
 185
 186  return \$header;
 187 }
 188
 189 # dos_wildcard_match()
 190 #
 191 # Check if a string matches against a DOS-style wildcard
 192 #
 193 # Params: 1. Pattern
 194 #         2. String
 195 #
 196 # Return: Status code (Boolean)
 197
 198 sub dos_wildcard_match($$)
 199 {
 200  my ($pattern,$string) = @_;
 201
 202  return 1 if($pattern eq '*');
 203
 204  # The following part is stolen from File::DosGlob
 205
 206  # escape regex metachars but not glob chars
 207  $pattern =~ s:([].+^\-\${}[|]):\\$1:g;
 208  # and convert DOS-style wildcards to regex
 209  $pattern =~ s/\*/.*/g;
 210  $pattern =~ s/\?/.?/g;
 211
 212  return ($string =~ m|^$pattern$|is);
 213 }
 214
 215 # encode_html()
 216 #
 217 # Encode HTML control characters (< > " &)
 218 #
 219 # Params: String to encode
 220 #
 221 # Return: Encoded string
 222
 223 sub encode_html($)
 224 {
 225  my $string = shift;
 226
 227  $string =~ s/&/&amp;/g;
 228  $string =~ s/</&lt;/g;
 229  $string =~ s/>/&gt;/g;
 230  $string =~ s/"/&quot;/g;
 231
 232  return $string;
 233 }
 234
 235 # equal_url()
 236 #
 237 # Create URL equal to a file or directory
 238 #
 239 # Params: 1. HTTP root
 240 #         2. Relative path
 241 #
 242 # Return: Formatted link (String)
 243
 244 sub equal_url($$)
 245 {
 246  my ($root,$path) = @_;
 247  my $url;
 248
 249  $root =~ s!/+$!!;
 250  $path =~ s!^/+!!;
 251  $url  =  $root.'/'.$path;
 252
 253  return $url;
 254 }
 255
 256 # file_name()
 257 #
 258 # Return the last part of a path
 259 #
 260 # Params: Path
 261 #
 262 # Return: Last part of the path
 263
 264 sub file_name($)
 265 {
 266  my $path =  shift;
 267  $path    =~ tr!\\!/!;
 268
 269  unless($path =~ m!^/+$! || ($^O eq 'MSWin32' && $path =~ m!^[a-z]:/+$!i))
 270  {
 271   $path =~ s!/+$!!;
 272   $path =  substr($path,rindex($path,'/')+1);
 273  }
 274
 275  return $path;
 276 }
 277
 278 # in_array()
 279 #
 280 # Check if a value is in an array
 281 #
 282 # Params: 1. Value to find
 283 #         2. Array
 284 #
 285 # Return: Status code (Boolean)
 286
 287 sub in_array($$)
 288 {
 289  my ($string,$array) = @_;
 290
 291  foreach my $element(@{$array})
 292  {
 293   return 1 if($string eq $element);
 294  }
 295
 296  return;
 297 }
 298
 299 # is_archive()
 300 #
 301 # Check if a file is an archive
 302 # (currently only by file extension)
 303 #
 304 # Params: Archive file name
 305 #
 306 # Return: Status code (Boolean)
 307
 308 sub is_archive($)
 309 {
 310  my $file = shift;
 311
 312  foreach my $ext(@archive_exts)
 313  {
 314   return 1 if(lc(substr($file,length($file)-length($ext),length($ext))) eq lc($ext));
 315  }
 316
 317  return;
 318 }
 319
 320 # is_disabled_command()
 321 #
 322 # Check if a command is disabled
 323 #
 324 # Params: 1. Array Reference containing the list
 325 #         2. Command to check
 326 #
 327 # Return: Status code (Boolean)
 328
 329 sub is_disabled_command($$)
 330 {
 331  my ($list,$command) = @_;
 332  $command =~ s!/+$!!g;
 333
 334  foreach my $entry(@$list)
 335  {
 336   return 1 if(lc($command) eq lc($entry));
 337  }
 338
 339  return;
 340 }
 341
 342 # is_forbidden_file()
 343 #
 344 # Check if a file is in the list of forbidden files
 345 #
 346 # Params: 1. Array Reference containing the list
 347 #         2. Filename to check
 348 #
 349 # Return: Status code (Boolean)
 350
 351 sub is_forbidden_file($$)
 352 {
 353  my ($list,$file) = @_;
 354  $file =~ s!/+$!!g;
 355
 356  foreach my $entry(@$list)
 357  {
 358   return 1 if($file eq $entry);
 359   return 1 if(index($file,$entry.'/') == 0);
 360  }
 361
 362  return;
 363 }
 364
 365 # mode_string()
 366 #
 367 # Convert a file mode number into a human readable string (rwxr-x-r-x)
 368 # (also supports SetUID, SetGID and Sticky Bit)
 369 #
 370 # Params: File mode number
 371 #
 372 # Return: Human readable mode string
 373
 374 sub mode_string($)
 375 {
 376  my $mode   = shift;
 377  my $string = '';
 378
 379  # User
 380
 381  $string  = ($mode & 00400) ? 'r' : '-';
 382  $string .= ($mode & 00200) ? 'w' : '-';
 383  $string .= ($mode & 00100) ? (($mode & 04000) ? 's' : 'x') :
 384                                ($mode & 04000) ? 'S' : '-';
 385
 386  # Group
 387
 388  $string .= ($mode & 00040) ? 'r' : '-';
 389  $string .= ($mode & 00020) ? 'w' : '-';
 390  $string .= ($mode & 00010) ? (($mode & 02000) ? 's' : 'x') :
 391                                ($mode & 02000) ? 'S' : '-';
 392
 393  # Other
 394
 395  $string .= ($mode & 00004) ? 'r' : '-';
 396  $string .= ($mode & 00002) ? 'w' : '-';
 397  $string .= ($mode & 00001) ? (($mode & 01000) ? 't' : 'x') :
 398                                ($mode & 01000) ? 'T' : '-';
 399
 400  return $string;
 401 }
 402
 403 # multi_string()
 404 #
 405 # Create a Hash Reference containing three forms of a string
 406 #
 407 # Params: String
 408 #
 409 # Return: Hash Reference:
 410 #         normal => Normal form of the string
 411 #         html   => HTML encoded form (see encode_html())
 412 #         url    => URL encoded form
 413
 414 sub multi_string($)
 415 {
 416  my $string = shift;
 417  my %multi;
 418
 419  $multi{'normal'} = $string;
 420  $multi{'html'}   = encode_html($string);
 421  $multi{'url'}    = escape($string);
 422
 423  return \%multi;
 424 }
 425
 426 # upper_path()
 427 #
 428 # Remove the last part of a path
 429 # (the resulting path contains a trailing slash)
 430 #
 431 # Params: Path
 432 #
 433 # Return: Truncated path
 434
 435 sub upper_path($)
 436 {
 437  my $path =  shift;
 438  $path    =~ tr!\\!/!;
 439
 440  unless($path =~ m!^/+$! || ($^O eq 'MSWin32' && $path =~ m!^[a-z]:/+$!i))
 441  {
 442   $path =~ s!/+$!!;
 443   $path =  substr($path,0,rindex($path,'/')+1);
 444  }
 445
 446  return $path;
 447 }
 448
 449 # it's true, baby ;-)
 450
 451 1;
 452
 453 #
 454 ### End ###