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: 09-22-2003
  10 #
  11
  12 use strict;
  13
  14 use vars qw(@EXPORT);
  15
  16 use Carp qw(croak);
  17
  18 use Cwd qw(abs_path);
  19 use File::Basename;
  20 use File::Spec;
  21
  22 ### Export ###
  23
  24 use base qw(Exporter);
  25
  26 @EXPORT = qw(check_path
  27              clean_path
  28              filemode
  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 @pathinfo = fileparse($path);
  60
  61   # This is only to avoid errors
  62
  63   my $basename = $pathinfo[0] || '';
  64   my $dir      = $pathinfo[1] || '';
  65   my $ext      = $pathinfo[2] || '';
  66
  67   $dir = abs_path($dir);
  68
  69   $path = $dir."/".$basename.$ext;
  70  }
  71  else
  72  {
  73   $path = abs_path($path);
  74  }
  75
  76  $path = File::Spec->canonpath($path);
  77
  78  # Check if the path is above the root directory
  79
  80  return if(index($path,$root) == -1);
  81
  82  # Create short path name
  83
  84  my $short_path = substr($path,length($root));
  85  $short_path =~ tr!\\!\/!;
  86  $short_path = "/".$short_path unless($short_path =~ m!^/!);
  87  $short_path = $short_path."/" if($short_path !~ m!/$! && -d $path);
  88
  89  return ($path,$short_path);
  90 }
  91
  92 # clean_path()
  93 #
  94 # Clean up a path logically and replace backslashes with
  95 # normal slashes
  96 #
  97 # Params: Path
  98 #
  99 # Return: Cleaned path
 100
 101 sub clean_path($)
 102 {
 103  my $path =  shift;
 104  $path    =  File::Spec->canonpath($path);
 105  $path    =~ tr!\\!/!;
 106
 107  return $path;
 108 }
 109
 110 # filemode()
 111 #
 112 # Creates a readable string of a UNIX filemode number
 113 # (copied from Tool.pm of Dev-Editor 0.1.4)
 114 #
 115 # Params: Filemode as number
 116 #
 117 # Return: Filemode as readable string
 118
 119 sub filemode($)
 120 {
 121     my ($modestring, $ur, $uw, $ux, $gr, $gw, $gx, $or, $ow, $ox);
 122     my $mode = shift;
 123
 124     $ur = ($mode & 0400) ? "r" : "-";       # User Read
 125     $uw = ($mode & 0200) ? "w" : "-";       # User Write
 126     $ux = ($mode & 0100) ? "x" : "-";       # User eXecute
 127     $gr = ($mode & 0040) ? "r" : "-";       # Group Read
 128     $gw = ($mode & 0020) ? "w" : "-";       # Group Write
 129     $gx = ($mode & 0010) ? "x" : "-";       # Group eXecute
 130     $or = ($mode & 0004) ? "r" : "-";       # Other Read
 131     $ow = ($mode & 0002) ? "w" : "-";       # Other Write
 132     $ox = ($mode & 0001) ? "x" : "-";       # Other eXecute
 133
 134     # build a readable mode string (rwxrwxrwx)
 135     return $ur . $uw . $ux . $gr . $gw . $gx . $or . $ow . $ox;
 136 }
 137
 138 # upper_path()
 139 #
 140 # Truncate a path in one of the following ways:
 141 #
 142 # - If the path points to a directory, the upper directory
 143 #   will be returned.
 144 # - If the path points to a file, the directory containing
 145 #   the file will be returned.
 146 #
 147 # Params: Path
 148 #
 149 # Return: Truncated path
 150
 151 sub upper_path($)
 152 {
 153  my $path =  shift;
 154  $path    =~ tr!\\!/!;
 155
 156  unless($path eq "/")
 157  {
 158   $path = substr($path,0,-1) if($path =~ m!/$!);
 159   $path = substr($path,0,rindex($path,"/"));
 160   $path = $path."/";
 161  }
 162
 163  return $path;
 164 }
 165
 166 # it's true, baby ;-)
 167
 168 1;
 169
 170 #
 171 ### End ###