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-02-03
  10 #
  11
  12 use strict;
  13
  14 use vars qw(@EXPORT);
  15
  16 use CGI qw(redirect);
  17 use Cwd qw(abs_path);
  18 use File::Spec;
  19
  20 ### Export ###
  21
  22 use base qw(Exporter);
  23
  24 @EXPORT = qw(check_path
  25              clean_path
  26              devedit_reload
  27              equal_url
  28              file_name
  29              upper_path);
  30
  31 # check_path()
  32 #
  33 # Check, if a virtual path is above a virtual root directory
  34 # (currently no check if the path exists - check otherwise!)
  35 #
  36 # Params: 1. Virtual root directory
  37 #         2. Virtual path to check
  38 #
  39 # Return: Array with the physical and the cleaned virtual path;
  40 #         false, if the submitted path is above the root directory
  41
  42 sub check_path($$)
  43 {
  44  my ($root,$path) = @_;
  45
  46  # Clean root path
  47
  48  $root = abs_path($root);
  49  $root = File::Spec->canonpath($root);
  50
  51  $path =~ s!^/{1}!!;
  52  $path = $root."/".$path;
  53
  54  unless(-d $path)
  55  {
  56   # The path points to a file
  57   # We have to extract the directory name and create the absolute path
  58
  59   my $dir  = upper_path($path);
  60   my $file = file_name($path);
  61
  62   $dir  = abs_path($dir);
  63   $path = $dir."/".$file;
  64  }
  65  else
  66  {
  67   $path = abs_path($path);
  68  }
  69
  70  $path = File::Spec->canonpath($path);
  71
  72  # Check if the path is above the root directory
  73
  74  return if(index($path,$root) == -1);
  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 #
 111 # Return: HTTP redirection header (Scalar Reference)
 112
 113 sub devedit_reload($)
 114 {
 115  my $params = shift;
 116  my @list;
 117
 118  while(my ($param,$value) = each(%$params))
 119  {
 120   push(@list,$param."=".$value);
 121  }
 122
 123  my $query  = join("&",@list);
 124  my $header = redirect("http://$ENV{'HTTP_HOST'}$ENV{'SCRIPT_NAME'}?$query");
 125
 126  return \$header;
 127 }
 128
 129 # equal_url()
 130 #
 131 # Create URL equal to a file or directory
 132 #
 133 # Params: 1. HTTP root
 134 #         2. Relative path
 135 #
 136 # Return: Formatted link (String)
 137
 138 sub equal_url($$)
 139 {
 140  my ($root,$path) = @_;
 141  my $url;
 142
 143  $root =~ s!/$!!;
 144  $path =~ s!^/!!;
 145  $url  =  $root."/".$path;
 146  #$url  =  encode_entities($url);
 147
 148  return $url;
 149 }
 150
 151 # file_name()
 152 #
 153 # Returns the last path of a path
 154 #
 155 # Params: Path
 156 #
 157 # Return: Last part of the path
 158
 159 sub file_name($)
 160 {
 161  my $path =  shift;
 162  $path    =~ tr!\\!/!;
 163
 164  unless($path eq "/")
 165  {
 166   $path = substr($path,0,-1) if($path =~ m!/$!);
 167   $path = substr($path,rindex($path,"/")+1);
 168  }
 169
 170  return $path;
 171 }
 172
 173 # upper_path()
 174 #
 175 # Cut the last part of a path away
 176 #
 177 # Params: Path
 178 #
 179 # Return: Truncated path
 180
 181 sub upper_path($)
 182 {
 183  my $path =  shift;
 184  $path    =~ tr!\\!/!;
 185
 186  unless($path eq "/")
 187  {
 188   $path = substr($path,0,-1) if($path =~ m!/$!);
 189   $path = substr($path,0,rindex($path,"/")+1);
 190  }
 191
 192  return $path;
 193 }
 194
 195 # it's true, baby ;-)
 196
 197 1;
 198
 199 #
 200 ### End ###