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