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