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: 10-03-2003
  10 #
  11
  12 use strict;
  13
  14 use vars qw(@EXPORT);
  15
  16 use Cwd qw(abs_path);
  17 use File::Basename;
  18 use File::Spec;
  19
  20 ### Export ###
  21
  22 use base qw(Exporter);
  23
  24 @EXPORT = qw(check_path
  25              clean_path
  26              file_name
  27              upper_path);
  28
  29 # check_path()
  30 #
  31 # Check, if a virtual path is above a virtual root directory
  32 # (currently no check if the path exists - check otherwise!)
  33 #
  34 # Params: 1. Virtual root directory
  35 #         2. Virtual path to check
  36 #
  37 # Return: Array with the physical and the cleaned virtual path;
  38 #         false, if the submitted path is above the root directory
  39
  40 sub check_path($$)
  41 {
  42  my ($root,$path) = @_;
  43
  44  # Clean root path
  45
  46  $root = abs_path($root);
  47  $root = File::Spec->canonpath($root);
  48
  49  $path =~ s!^/{1}!!;
  50  $path = $root."/".$path;
  51
  52  unless(-d $path)
  53  {
  54   # The path points to a file
  55   # We have to extract the directory name and create the absolute path
  56
  57   my @pathinfo = fileparse($path);
  58
  59   # This is only to avoid errors
  60
  61   my $basename = $pathinfo[0] || '';
  62   my $dir      = $pathinfo[1] || '';
  63   my $ext      = $pathinfo[2] || '';
  64
  65   $dir = abs_path($dir);
  66
  67   $path = $dir."/".$basename.$ext;
  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 unless($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 # file_name()
 109 #
 110 # Returns the last path of a filename
 111 #
 112 # Params: Path
 113 #
 114 # Return: Last part of the path
 115
 116 sub file_name($)
 117 {
 118  my $path =  shift;
 119  $path    =~ tr!\\!/!;
 120
 121  unless($path eq "/")
 122  {
 123   $path = substr($path,0,-1) if($path =~ m!/$!);
 124   $path = substr($path,rindex($path,"/")+1);
 125  }
 126
 127  return $path;
 128 }
 129
 130 # upper_path()
 131 #
 132 # Truncate a path in one of the following ways:
 133 #
 134 # - If the path points to a directory, the upper directory
 135 #   will be returned.
 136 # - If the path points to a file, the directory containing
 137 #   the file will be returned.
 138 #
 139 # Params: Path
 140 #
 141 # Return: Truncated path
 142
 143 sub upper_path($)
 144 {
 145  my $path =  shift;
 146  $path    =~ tr!\\!/!;
 147
 148  unless($path eq "/")
 149  {
 150   $path = substr($path,0,-1) if($path =~ m!/$!);
 151   $path = substr($path,0,rindex($path,"/"));
 152   $path = $path."/";
 153  }
 154
 155  return $path;
 156 }
 157
 158 # it's true, baby ;-)
 159
 160 1;
 161
 162 #
 163 ### End ###