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