modules/DirectoryManager.pm

   1 package DirectoryManager;
   2
   3 # ************************************************************
   4 # Description   : This module provides directory related methods
   5 # Author        : Chad Elliott
   6 # Create Date   : 5/13/2004
   7 # ************************************************************
   8
   9 # ************************************************************
  10 # Pragmas
  11 # ************************************************************
  12
  13 use strict;
  14 use File::Spec;
  15 use File::Basename;
  16
  17 # ************************************************************
  18 # Data Section
  19 # ************************************************************
  20
  21 my $onVMS = ($^O eq 'VMS');
  22 my $case_insensitive = File::Spec->case_tolerant();
  23 my $cwd = Cwd::getcwd();
  24 if ($^O eq 'cygwin' && $cwd !~ /[A-Za-z]:/) {
  25   my $cyg = `cygpath -w $cwd`;
  26   if (defined $cyg) {
  27     $cyg =~ s/\\/\//g;
  28     chop($cwd = $cyg);
  29   }
  30   $case_insensitive = 1;
  31 }
  32 elsif ($^O eq 'msys' && $cwd !~ /[A-Za-z]:/) {
  33   my $mp = Win32::GetCwd();
  34   if (defined $mp) {
  35     $mp =~ s/\\/\//g;
  36     $cwd = $mp;
  37   }
  38 }
  39 elsif ($onVMS) {
  40   $cwd = VMS::Filespec::unixify($cwd);
  41   $cwd =~ s!/$!!g;
  42 }
  43 my $start = $cwd;
  44
  45 # ************************************************************
  46 # Subroutine Section
  47 # ************************************************************
  48
  49 sub cd {
  50   my($self, $dir) = @_;
  51   my $status = chdir($dir);
  52
  53   if ($status && $dir ne '.') {
  54     ## First strip out any /./ or ./ or /.
  55     $dir =~ s/\/\.\//\//g;
  56     $dir =~ s/^\.\///;
  57     $dir =~ s/\/\.$//;
  58
  59     ## If the new directory contains a relative directory
  60     ## then we just get the real working directory
  61     if (index($dir, '..') >= 0) {
  62       $cwd = Cwd::getcwd();
  63       if ($^O eq 'cygwin' && $cwd !~ /[A-Za-z]:/) {
  64         ## We're using Cygwin perl, use cygpath to get the windows path
  65         ## and then fix up the slashes.
  66         my $cyg = `cygpath -w $cwd`;
  67         if (defined $cyg) {
  68           $cyg =~ s/\\/\//g;
  69           chop($cwd = $cyg);
  70         }
  71       }
  72       elsif ($^O eq 'msys' && $cwd !~ /[A-Za-z]:/) {
  73         ## We're using Mingw32 perl, use Win32::GetCwd() to get the windows
  74         ## path and then fix up the slashes.
  75         my $mp = Win32::GetCwd();
  76         if (defined $mp) {
  77           $mp =~ s/\\/\//g;
  78           $cwd = $mp;
  79         }
  80       }
  81       elsif ($onVMS) {
  82         ## On VMS, we need to get the UNIX style path and remove the
  83         ## trailing slash.
  84         $cwd = VMS::Filespec::unixify($cwd);
  85         $cwd =~ s!/$!!g;
  86       }
  87     }
  88     else {
  89       if ($dir =~ /^(\/|[a-z]:)/i) {
  90         ## It was a full path, just store it.
  91         $cwd = $dir;
  92       }
  93       else {
  94         ## This portion was relative, add it onto the current working
  95         ## directory.
  96         $cwd .= "/$dir";
  97       }
  98     }
  99   }
 100   return $status;
 101 }
 102
 103
 104 sub abs_path {
 105   my($self, $path) = @_;
 106
 107   ## When needing a full path, it's usually because the build system requires
 108   ## it.  If that's the case, it is unlikely to understand cygwin or mingw32
 109   ## paths.  For these, we will return the full path for Win32 specifically.
 110   return Win32::GetFullPathName($path) if ($^O eq 'cygwin' || $^O eq 'msys');
 111
 112   ## For all others, we will just use Cwd::abs_path
 113   return Cwd::abs_path($path);
 114 }
 115
 116
 117 sub getcwd {
 118   #my $self = shift;
 119   return $cwd;
 120 }
 121
 122
 123 sub getstartdir {
 124   #my $self = shift;
 125   return $start;
 126 }
 127
 128
 129 sub mpc_basename {
 130   #my $self = $_[0];
 131   #my $file = $_[1];
 132   return substr($_[1], rindex($_[1], '/') + 1);
 133 }
 134
 135
 136 sub mpc_dirname {
 137   my($self, $dir) = @_;
 138
 139   ## The dirname() on VMS doesn't work as we expect it to.
 140   if ($onVMS) {
 141     ## If the directory contains multiple parts, we need to get the
 142     ## dirname in a UNIX style format and then remove the slash from the
 143     ## end.
 144     if (index($dir, '/') >= 0) {
 145       $dir = VMS::Filespec::unixify(dirname($dir));
 146       $dir =~ s!/$!!g;
 147       return $dir;
 148     }
 149     else {
 150       ## There's no directory portion, so just return '.'
 151       return '.';
 152     }
 153   }
 154   else {
 155     ## Get the directory portion of the original directory or file path.
 156     $dir = dirname($dir);
 157
 158     ## If the result is just a drive specification, we need to append a
 159     ## slash to the end of the path so that cygwin perl can use this
 160     ## return value within a chdir() call.
 161     $dir .= '/' if ($dir =~ /^[a-z]:$/i);
 162
 163     return $dir;
 164   }
 165 }
 166
 167
 168 sub mpc_glob {
 169   my($self, $pattern) = @_;
 170
 171   ## glob() provided by OpenVMS does not understand [] within
 172   ## the pattern.  So, we implement our own through recursive calls
 173   ## to mpc_glob().
 174   if ($onVMS && $pattern =~ /(.*)\[([^\]]+)\](.*)/) {
 175     my @files;
 176     my($pre, $mid, $post) = ($1, $2, $3);
 177     for(my $i = 0; $i < length($mid); $i++) {
 178       StringProcessor::merge(\@files,
 179                              [$self->mpc_glob($pre . substr($mid, $i, 1)
 180                                               . $post)]);
 181     }
 182     return @files;
 183   }
 184
 185   ## Otherwise, we just return the globbed pattern.
 186   return glob($pattern);
 187 }
 188
 189
 190 sub onVMS {
 191   return $onVMS;
 192 }
 193
 194
 195 sub path_is_relative {
 196   ## To determine if the path is relative, we just determine if it is not
 197   ## an absolute path.
 198   #my($self, $path) = @_;
 199   return (index($_[1], '/') != 0 && $_[1] !~ /^[A-Z]:[\/\\]/i && $_[1] !~ /^\$\(\w+\)/);
 200 }
 201
 202 # ************************************************************
 203 # Virtual Methods To Be Overridden
 204 # ************************************************************
 205
 206 sub translate_directory {
 207   my($self, $dir) = @_;
 208
 209   ## Remove the current working directory from $dir (if it is contained)
 210   my $cwd = $self->getcwd();
 211   $cwd =~ s/\//\\/g if ($self->convert_slashes());
 212   if (index($dir, $cwd) == 0) {
 213     my $cwdl = length($cwd);
 214     return '.' if (length($dir) == $cwdl);
 215     $dir = substr($dir, $cwdl + 1);
 216   }
 217
 218   ## Translate .. to $dd
 219   if (index($dir, '..') >= 0) {
 220     my $dd = 'dotdot';
 221     $dir =~ s/^\.\.([\/\\])/$dd$1/;
 222     $dir =~ s/([\/\\])\.\.$/$1$dd/;
 223     $dir =~ s/([\/\\])\.\.(?=[\/\\])/$1$dd$2/g;
 224     $dir =~ s/^\.\.$/$dd/;
 225   }
 226
 227   return $dir;
 228 }
 229
 230
 231 sub convert_slashes {
 232   #my $self = shift;
 233   return 0;
 234 }
 235
 236
 237 sub case_insensitive {
 238   #my $self = shift;
 239   return $case_insensitive;
 240 }
 241
 242 1;