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              encode_html
  33              equal_url
  34              file_name
  35              mode_string
  36              multi_string
  37              upper_path);
  38
  39 # check_path()
  40 #
  41 # Check if a virtual path is above a virtual root directory
  42 # (currently no check if the path exists - check otherwise!)
  43 #
  44 # Params: 1. Virtual root directory
  45 #         2. Virtual path to check
  46 #
  47 # Return: Array with the physical and the cleaned virtual path;
  48 #         false, if the submitted path is above the root directory
  49
  50 sub check_path($$)
  51 {
  52  my ($root,$path) = @_;
  53
  54  # Clean root path
  55
  56  $root = abs_path($root);
  57  $root = File::Spec->canonpath($root);
  58
  59  $path =~ tr!\\!/!;
  60  $path =~ s!^/+!!;
  61  $path =  $root.'/'.$path;
  62
  63  # We extract the last part of the path and create the absolute path
  64
  65  my $first = upper_path($path);
  66  $first    = File::Spec->canonpath($first);
  67  $first    = abs_path($first);
  68
  69  my $last  = file_name($path);
  70  $last     = '' if($last eq '.');
  71
  72  if($last eq '..' || ($^O eq 'MSWin32' && $last =~ m!^\.\.\.+$!))
  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 # mode_string()
 259 #
 260 # Convert a file mode number into a human readable string (rwxr-x-r-x)
 261 # (also supports SetUID, SetGID and Sticky Bit)
 262 #
 263 # Params: File mode number
 264 #
 265 # Return: Human readable mode string
 266
 267 sub mode_string($)
 268 {
 269  my $mode   = shift;
 270  my $string = '';
 271
 272  # User
 273
 274  $string  = ($mode & 00400) ? 'r' : '-';
 275  $string .= ($mode & 00200) ? 'w' : '-';
 276  $string .= ($mode & 00100) ? (($mode & 04000) ? 's' : 'x') :
 277                                ($mode & 04000) ? 'S' : '-';
 278
 279  # Group
 280
 281  $string .= ($mode & 00040) ? 'r' : '-';
 282  $string .= ($mode & 00020) ? 'w' : '-';
 283  $string .= ($mode & 00010) ? (($mode & 02000) ? 's' : 'x') :
 284                                ($mode & 02000) ? 'S' : '-';
 285
 286  # Other
 287
 288  $string .= ($mode & 00004) ? 'r' : '-';
 289  $string .= ($mode & 00002) ? 'w' : '-';
 290  $string .= ($mode & 00001) ? (($mode & 01000) ? 't' : 'x') :
 291                                ($mode & 01000) ? 'T' : '-';
 292
 293  return $string;
 294 }
 295
 296 # multi_string()
 297 #
 298 # Create a Hash Reference containing three forms of a string
 299 #
 300 # Params: String
 301 #
 302 # Return: Hash Reference:
 303 #         normal => Normal form of the string
 304 #         html   => HTML encoded form (see encode_html())
 305 #         url    => URL encoded form
 306
 307 sub multi_string($)
 308 {
 309  my $string = shift;
 310  my %multi;
 311
 312  $multi{'normal'} = $string;
 313  $multi{'html'}   = encode_html($string);
 314  $multi{'url'}    = escape($string);
 315
 316  return \%multi;
 317 }
 318
 319 # upper_path()
 320 #
 321 # Remove the last part of a path
 322 # (the resulting path contains a trailing slash)
 323 #
 324 # Params: Path
 325 #
 326 # Return: Truncated path
 327
 328 sub upper_path($)
 329 {
 330  my $path =  shift;
 331  $path    =~ tr!\\!/!;
 332
 333  unless($path =~ m!^/+$! || ($^O eq 'MSWin32' && $path =~ m!^[a-z]:/+$!i))
 334  {
 335   $path =~ s!/+$!!;
 336   $path =  substr($path,0,rindex($path,'/')+1);
 337  }
 338
 339  return $path;
 340 }
 341
 342 # it's true, baby ;-)
 343
 344 1;
 345
 346 #
 347 ### End ###