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