modules/Tool.pm

   1 package Tool;
   2
   3 #
   4 # Dev-Editor - Module Tool
   5 #
   6 # Some shared sub routines
   7 #
   8 # Author:        Patrick Canterino <patshaping@gmx.net>
   9 # Last modified: 2004-07-28
  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              equal_url
  32              file_name
  33              mode_string
  34              upper_path);
  35
  36 # check_path()
  37 #
  38 # Check, if a virtual path is above a virtual root directory
  39 # (currently no check if the path exists - check otherwise!)
  40 #
  41 # Params: 1. Virtual root directory
  42 #         2. Virtual path to check
  43 #
  44 # Return: Array with the physical and the cleaned virtual path;
  45 #         false, if the submitted path is above the root directory
  46
  47 sub check_path($$)
  48 {
  49  my ($root,$path) = @_;
  50
  51  # Clean root path
  52
  53  $root = abs_path($root);
  54  $root = File::Spec->canonpath($root);
  55
  56  $path =~ s!^/{1}!!;
  57  $path = $root."/".$path;
  58
  59  unless(-d $path)
  60  {
  61   # The path points to a file
  62   # We have to extract the directory name and create the absolute path
  63
  64   my $dir  = upper_path($path);
  65   my $file = file_name($path);
  66
  67   $dir  = abs_path($dir);
  68   $path = $dir."/".$file;
  69  }
  70  else
  71  {
  72   $path = abs_path($path);
  73  }
  74
  75  $path = File::Spec->canonpath($path);
  76
  77  # Check if the path is above the root directory
  78
  79  return if(index($path,$root) == -1);
  80
  81  # Create short path name
  82
  83  my $short_path = substr($path,length($root));
  84  $short_path =~ tr!\\!\/!;
  85  $short_path = "/".$short_path if($short_path !~ m!^/!);
  86  $short_path = $short_path."/" if($short_path !~ m!/$! && -d $path);
  87
  88  return ($path,$short_path);
  89 }
  90
  91 # clean_path()
  92 #
  93 # Clean up a path logically and replace backslashes with
  94 # normal slashes
  95 #
  96 # Params: Path
  97 #
  98 # Return: Cleaned path
  99
 100 sub clean_path($)
 101 {
 102  my $path =  shift;
 103  $path    =  File::Spec->canonpath($path);
 104  $path    =~ tr!\\!/!;
 105
 106  return $path;
 107 }
 108
 109 # devedit_reload()
 110 #
 111 # Create a HTTP redirection header to load Dev-Editor
 112 # with some other parameters
 113 #
 114 # Params: Hash Reference (will be merged to a query string)
 115 #
 116 # Return: HTTP redirection header (Scalar Reference)
 117
 118 sub devedit_reload($)
 119 {
 120  my $params = shift;
 121
 122  # Detect the protocol (simple HTTP or SSL encrypted HTTP)
 123  # and check if the server listens on the default port
 124
 125  my $protocol = "";
 126  my $port     = "";
 127
 128  if(https)
 129  {
 130   # SSL encrypted HTTP (HTTPS)
 131
 132   $protocol = "https";
 133   $port     = ":".$ENV{'SERVER_PORT'} if($ENV{'SERVER_PORT'} != 443);
 134  }
 135  else
 136  {
 137   # Simple HTTP
 138
 139   $protocol = "http";
 140   $port     = ":".$ENV{'SERVER_PORT'} if($ENV{'SERVER_PORT'} != 80);
 141  }
 142
 143  # The following code is grabbed from Template::_query of
 144  # Andre Malo's selfforum (http://sourceforge.net/projects/selfforum/)
 145  # and modified by Patrick Canterino
 146
 147  my $query = '?'.join ('&' =>
 148    map {
 149      (ref)
 150      ? map{escape ($_).'='.escape ($params -> {$_})} @{$params -> {$_}}
 151      : escape ($_).'='.escape ($params -> {$_})
 152    } keys %$params
 153  );
 154
 155  # Create the redirection header
 156
 157  my $header = redirect($protocol."://".virtual_host.$port.$ENV{'SCRIPT_NAME'}.$query);
 158
 159  return \$header;
 160 }
 161
 162 # equal_url()
 163 #
 164 # Create URL equal to a file or directory
 165 #
 166 # Params: 1. HTTP root
 167 #         2. Relative path
 168 #
 169 # Return: Formatted link (String)
 170
 171 sub equal_url($$)
 172 {
 173  my ($root,$path) = @_;
 174  my $url;
 175
 176  $root =~ s!/$!!;
 177  $path =~ s!^/!!;
 178  $url  =  $root."/".$path;
 179
 180  return $url;
 181 }
 182
 183 # file_name()
 184 #
 185 # Return the last part of a path
 186 #
 187 # Params: Path
 188 #
 189 # Return: Last part of the path
 190
 191 sub file_name($)
 192 {
 193  my $path =  shift;
 194  $path    =~ tr!\\!/!;
 195
 196  unless($path eq "/")
 197  {
 198   $path = substr($path,0,-1) if($path =~ m!/$!);
 199   $path = substr($path,rindex($path,"/")+1);
 200  }
 201
 202  return $path;
 203 }
 204
 205 # mode_string()
 206 #
 207 # Convert a binary file mode string into a human
 208 # readable string (rwxr-x-r-x)
 209 #
 210 # Params: Binary file mode string
 211 #
 212 # Return: Humand readable mode string
 213
 214 sub mode_string($)
 215 {
 216  my $mode = shift;
 217
 218  my $string = "";
 219
 220   # Owner
 221   $string .= (($mode & 0x0100) ? 'r' : '-') .
 222          (($mode & 0x0080) ? 'w' : '-') .
 223          (($mode & 0x0040) ?
 224            (($mode & 0x0800) ? 's' : 'x' ) :
 225            (($mode & 0x0800) ? 'S' : '-')
 226          );
 227
 228   # Group
 229   $string .= (($mode & 0x0020) ? 'r' : '-') .
 230          (($mode & 0x0010) ? 'w' : '-') .
 231          (($mode & 0x0008) ?
 232            (($mode & 0x0400) ? 's' : 'x') :
 233            (($mode & 0x0400) ? 'S' : '-')
 234          );
 235
 236   # World
 237   $string .= (($mode & 0x0004) ? 'r' : '-') .
 238          (($mode & 0x0002) ? 'w' : '-') .
 239          (($mode & 0x0001) ?
 240            (($mode & 0x0200) ? 't' : 'x' ) :
 241            (($mode & 0x0200) ? 'T' : '-')
 242          );
 243
 244  return $string;
 245 }
 246
 247 # upper_path()
 248 #
 249 # Cut away the last part of a path
 250 #
 251 # Params: Path
 252 #
 253 # Return: Truncated path
 254
 255 sub upper_path($)
 256 {
 257  my $path =  shift;
 258  $path    =~ tr!\\!/!;
 259
 260  unless($path eq "/")
 261  {
 262   $path = substr($path,0,-1) if($path =~ m!/$!);
 263   $path = substr($path,0,rindex($path,"/")+1);
 264  }
 265
 266  return $path;
 267 }
 268
 269 # it's true, baby ;-)
 270
 271 1;
 272
 273 #
 274 ### End ###