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-01-06
  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  my $last  = file_name($path);
  65
  66  $first = abs_path($first);
  67  $path  = $first.'/'.$last;
  68
  69  $first = File::Spec->canonpath($first);
  70  $path  = File::Spec->canonpath($path);
  71
  72  # Check if the path is above the root directory
  73
  74  return if(index($path,$root) != 0);
  75  return if($first eq $root && ($last eq '..' || ($^O eq 'MSWin32' && $last =~ m!^\.\.+$!)));
  76
  77  # Create short path name
  78
  79  my $short_path = substr($path,length($root));
  80  $short_path =~ tr!\\!/!;
  81  $short_path = '/'.$short_path if($short_path !~ m!^/!);
  82  $short_path = $short_path.'/' if($short_path !~ m!/$! && -d $path);
  83
  84  return ($path,$short_path);
  85 }
  86
  87 # clean_path()
  88 #
  89 # Clean up a path logically and replace backslashes with
  90 # normal slashes
  91 #
  92 # Params: Path
  93 #
  94 # Return: Cleaned path
  95
  96 sub clean_path($)
  97 {
  98  my $path =  shift;
  99  $path    =  File::Spec->canonpath($path);
 100  $path    =~ tr!\\!/!;
 101
 102  return $path;
 103 }
 104
 105 # devedit_reload()
 106 #
 107 # Create a HTTP redirection header to load Dev-Editor
 108 # with some other parameters
 109 #
 110 # Params: Hash Reference (will be merged to a query string)
 111 #         (optional)
 112 #
 113 # Return: HTTP redirection header (Scalar Reference)
 114
 115 sub devedit_reload(;$)
 116 {
 117  my $params = shift;
 118
 119  # Detect the protocol (simple HTTP or SSL encrypted HTTP)
 120  # and check if the server listens on the default port
 121
 122  my $protocol = '';
 123  my $port     = '';
 124
 125  if(https)
 126  {
 127   # SSL encrypted HTTP (HTTPS)
 128
 129   $protocol = 'https';
 130   $port     = ':'.$ENV{'SERVER_PORT'} if($ENV{'SERVER_PORT'} != 443);
 131  }
 132  else
 133  {
 134   # Simple HTTP
 135
 136   $protocol = 'http';
 137   $port     = ':'.$ENV{'SERVER_PORT'} if($ENV{'SERVER_PORT'} != 80);
 138  }
 139
 140  # The following code is grabbed from Template::_query of
 141  # Andre Malo's selfforum (http://sourceforge.net/projects/selfforum/)
 142  # and modified by Patrick Canterino
 143
 144  my $query = '';
 145
 146  if(ref($params) eq 'HASH')
 147  {
 148   $query = '?'.join ('&' =>
 149     map {
 150       (ref)
 151       ? map{escape ($_).'='.escape ($params -> {$_})} @{$params -> {$_}}
 152       : escape ($_).'='.escape ($params -> {$_})
 153     } keys %$params
 154   );
 155  }
 156
 157  # Create the redirection header
 158
 159  my $header = redirect($protocol.'://'.virtual_host.$port.$ENV{'SCRIPT_NAME'}.$query);
 160
 161  return \$header;
 162 }
 163
 164 # dos_wildcard_match()
 165 #
 166 # Check if a string matches against a DOS-style wildcard
 167 #
 168 # Params: 1. Pattern
 169 #         2. String
 170 #
 171 # Return: Status code (Boolean)
 172
 173 sub dos_wildcard_match($$)
 174 {
 175  my ($pattern,$string) = @_;
 176
 177  # The following part is stolen from File::DosGlob
 178
 179  # escape regex metachars but not glob chars
 180  $pattern =~ s:([].+^\-\${}[|]):\\$1:g;
 181  # and convert DOS-style wildcards to regex
 182  $pattern =~ s/\*/.*/g;
 183  $pattern =~ s/\?/.?/g;
 184
 185  return ($string =~ m|^$pattern$|is);
 186 }
 187
 188 # equal_url()
 189 #
 190 # Create URL equal to a file or directory
 191 #
 192 # Params: 1. HTTP root
 193 #         2. Relative path
 194 #
 195 # Return: Formatted link (String)
 196
 197 sub equal_url($$)
 198 {
 199  my ($root,$path) = @_;
 200  my $url;
 201
 202  $root =~ s!/+$!!;
 203  $path =~ s!^/+!!;
 204  $url  =  $root.'/'.$path;
 205
 206  return $url;
 207 }
 208
 209 # file_name()
 210 #
 211 # Return the last part of a path
 212 #
 213 # Params: Path
 214 #
 215 # Return: Last part of the path
 216
 217 sub file_name($)
 218 {
 219  my $path =  shift;
 220  $path    =~ tr!\\!/!;
 221
 222  unless($path eq '/')
 223  {
 224   $path =~ s!/+$!!;
 225   $path =  substr($path,rindex($path,'/')+1);
 226  }
 227
 228  return $path;
 229 }
 230
 231 # mode_string()
 232 #
 233 # Convert a file mode number into a human readable string (rwxr-x-r-x)
 234 # (also supports SetUID, SetGID and Sticky Bit)
 235 #
 236 # Params: File mode number
 237 #
 238 # Return: Human readable mode string
 239
 240 sub mode_string($)
 241 {
 242  my $mode   = shift;
 243  my $string = '';
 244
 245  # User
 246
 247  $string  = ($mode & 00400) ? 'r' : '-';
 248  $string .= ($mode & 00200) ? 'w' : '-';
 249  $string .= ($mode & 00100) ? (($mode & 04000) ? 's' : 'x') :
 250                                ($mode & 04000) ? 'S' : '-';
 251
 252  # Group
 253
 254  $string .= ($mode & 00040) ? 'r' : '-';
 255  $string .= ($mode & 00020) ? 'w' : '-';
 256  $string .= ($mode & 00010) ? (($mode & 02000) ? 's' : 'x') :
 257                                ($mode & 02000) ? 'S' : '-';
 258
 259  # Other
 260
 261  $string .= ($mode & 00004) ? 'r' : '-';
 262  $string .= ($mode & 00002) ? 'w' : '-';
 263  $string .= ($mode & 00001) ? (($mode & 01000) ? 't' : 'x') :
 264                                ($mode & 01000) ? 'T' : '-';
 265
 266  return $string;
 267 }
 268
 269 # upper_path()
 270 #
 271 # Cut away the last part of a path
 272 #
 273 # Params: Path
 274 #
 275 # Return: Truncated path
 276
 277 sub upper_path($)
 278 {
 279  my $path =  shift;
 280  $path    =~ tr!\\!/!;
 281
 282  unless($path eq '/')
 283  {
 284   $path =~ s!/+$!!;
 285   $path =  substr($path,0,rindex($path,'/')+1);
 286  }
 287
 288  return $path;
 289 }
 290
 291 # it's true, baby ;-)
 292
 293 1;
 294
 295 #
 296 ### End ###