lib/File/Spec/Unix.pm

   1 package File::Spec::Unix;
   2
   3 use strict;
   4
   5 use Cwd;
   6
   7 =head1 NAME
   8
   9 File::Spec::Unix - methods used by File::Spec
  10
  11 =head1 SYNOPSIS
  12
  13  require File::Spec::Unix; # Done automatically by File::Spec
  14
  15 =head1 DESCRIPTION
  16
  17 Methods for manipulating file specifications.
  18
  19 =head1 METHODS
  20
  21 =over 2
  22
  23 =item canonpath
  24
  25 No physical check on the filesystem, but a logical cleanup of a
  26 path. On UNIX eliminated successive slashes and successive "/.".
  27
  28     $cpath = File::Spec->canonpath( $path ) ;
  29
  30 =cut
  31
  32 sub canonpath {
  33     my ($self,$path) = @_;
  34     $path =~ s|/+|/|g unless($^O eq 'cygwin');     # xx////xx  -> xx/xx
  35     $path =~ s|(/\.)+/|/|g;                        # xx/././xx -> xx/xx
  36     $path =~ s|^(\./)+|| unless $path eq "./";     # ./xx      -> xx
  37     $path =~ s|^/(\.\./)+|/|;                      # /../../xx -> xx
  38     $path =~ s|/$|| unless $path eq "/";           # xx/       -> xx
  39     return $path;
  40 }
  41
  42 =item catdir
  43
  44 Concatenate two or more directory names to form a complete path ending
  45 with a directory. But remove the trailing slash from the resulting
  46 string, because it doesn't look good, isn't necessary and confuses
  47 OS2. Of course, if this is the root directory, don't cut off the
  48 trailing slash :-)
  49
  50 =cut
  51
  52 sub catdir {
  53     my $self = shift;
  54     my @args = @_;
  55     foreach (@args) {
  56         # append a slash to each argument unless it has one there
  57         $_ .= "/" if $_ eq '' || substr($_,-1) ne "/";
  58     }
  59     return $self->canonpath(join('', @args));
  60 }
  61
  62 =item catfile
  63
  64 Concatenate one or more directory names and a filename to form a
  65 complete path ending with a filename
  66
  67 =cut
  68
  69 sub catfile {
  70     my $self = shift;
  71     my $file = pop @_;
  72     return $file unless @_;
  73     my $dir = $self->catdir(@_);
  74     $dir .= "/" unless substr($dir,-1) eq "/";
  75     return $dir.$file;
  76 }
  77
  78 =item curdir
  79
  80 Returns a string representation of the current directory.  "." on UNIX.
  81
  82 =cut
  83
  84 sub curdir {
  85     return ".";
  86 }
  87
  88 =item devnull
  89
  90 Returns a string representation of the null device. "/dev/null" on UNIX.
  91
  92 =cut
  93
  94 sub devnull {
  95     return "/dev/null";
  96 }
  97
  98 =item rootdir
  99
 100 Returns a string representation of the root directory.  "/" on UNIX.
 101
 102 =cut
 103
 104 sub rootdir {
 105     return "/";
 106 }
 107
 108 =item tmpdir
 109
 110 Returns a string representation of the first writable directory
 111 from the following list or "" if none are writable:
 112
 113     $ENV{TMPDIR}
 114     /tmp
 115
 116 =cut
 117
 118 my $tmpdir;
 119 sub tmpdir {
 120     return $tmpdir if defined $tmpdir;
 121     foreach ($ENV{TMPDIR}, "/tmp") {
 122         next unless defined && -d && -w _;
 123         $tmpdir = $_;
 124         last;
 125     }
 126     $tmpdir = '' unless defined $tmpdir;
 127     return $tmpdir;
 128 }
 129
 130 =item updir
 131
 132 Returns a string representation of the parent directory.  ".." on UNIX.
 133
 134 =cut
 135
 136 sub updir {
 137     return "..";
 138 }
 139
 140 =item no_upwards
 141
 142 Given a list of file names, strip out those that refer to a parent
 143 directory. (Does not strip symlinks, only '.', '..', and equivalents.)
 144
 145 =cut
 146
 147 sub no_upwards {
 148     my $self = shift;
 149     return grep(!/^\.{1,2}$/, @_);
 150 }
 151
 152 =item case_tolerant
 153
 154 Returns a true or false value indicating, respectively, that alphabetic
 155 is not or is significant when comparing file specifications.
 156
 157 =cut
 158
 159 sub case_tolerant {
 160     return 0;
 161 }
 162
 163 =item file_name_is_absolute
 164
 165 Takes as argument a path and returns true, if it is an absolute path.
 166
 167 =cut
 168
 169 sub file_name_is_absolute {
 170     my ($self,$file) = @_;
 171     return scalar($file =~ m:^/:);
 172 }
 173
 174 =item path
 175
 176 Takes no argument, returns the environment variable PATH as an array.
 177
 178 =cut
 179
 180 sub path {
 181     my @path = split(':', $ENV{PATH});
 182     foreach (@path) { $_ = '.' if $_ eq '' }
 183     return @path;
 184 }
 185
 186 =item join
 187
 188 join is the same as catfile.
 189
 190 =cut
 191
 192 sub join {
 193     my $self = shift;
 194     return $self->catfile(@_);
 195 }
 196
 197 =item splitpath
 198
 199     ($volume,$directories,$file) = File::Spec->splitpath( $path );
 200     ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
 201
 202 Splits a path in to volume, directory, and filename portions. On systems
 203 with no concept of volume, returns undef for volume.
 204
 205 For systems with no syntax differentiating filenames from directories,
 206 assumes that the last file is a path unless $no_file is true or a
 207 trailing separator or /. or /.. is present. On Unix this means that $no_file
 208 true makes this return ( '', $path, '' ).
 209
 210 The directory portion may or may not be returned with a trailing '/'.
 211
 212 The results can be passed to L</catpath()> to get back a path equivalent to
 213 (usually identical to) the original path.
 214
 215 =cut
 216
 217 sub splitpath {
 218     my ($self,$path, $nofile) = @_;
 219
 220     my ($volume,$directory,$file) = ('','','');
 221
 222     if ( $nofile ) {
 223         $directory = $path;
 224     }
 225     else {
 226         $path =~ m|^ ( (?: .* / (?: \.\.?$ )? )? ) ([^/]*) |x;
 227         $directory = $1;
 228         $file      = $2;
 229     }
 230
 231     return ($volume,$directory,$file);
 232 }
 233
 234
 235 =item splitdir
 236
 237 The opposite of L</catdir()>.
 238
 239     @dirs = File::Spec->splitdir( $directories );
 240
 241 $directories must be only the directory portion of the path on systems
 242 that have the concept of a volume or that have path syntax that differentiates
 243 files from directories.
 244
 245 Unlike just splitting the directories on the separator, leading empty and
 246 trailing directory entries can be returned, because these are significant
 247 on some OSs. So,
 248
 249     File::Spec->splitdir( "/a/b/c" );
 250
 251 Yields:
 252
 253     ( '', 'a', 'b', '', 'c', '' )
 254
 255 =cut
 256
 257 sub splitdir {
 258     my ($self,$directories) = @_ ;
 259     #
 260     # split() likes to forget about trailing null fields, so here we
 261     # check to be sure that there will not be any before handling the
 262     # simple case.
 263     #
 264     if ( $directories !~ m|/$| ) {
 265         return split( m|/|, $directories );
 266     }
 267     else {
 268         #
 269         # since there was a trailing separator, add a file name to the end,
 270         # then do the split, then replace it with ''.
 271         #
 272         my( @directories )= split( m|/|, "${directories}dummy" ) ;
 273         $directories[ $#directories ]= '' ;
 274         return @directories ;
 275     }
 276 }
 277
 278
 279 =item catpath
 280
 281 Takes volume, directory and file portions and returns an entire path. Under
 282 Unix, $volume is ignored, and directory and file are catenated.  A '/' is
 283 inserted if need be.  On other OSs, $volume is significant.
 284
 285 =cut
 286
 287 sub catpath {
 288     my ($self,$volume,$directory,$file) = @_;
 289
 290     if ( $directory ne ''                &&
 291          $file ne ''                     &&
 292          substr( $directory, -1 ) ne '/' &&
 293          substr( $file, 0, 1 ) ne '/'
 294     ) {
 295         $directory .= "/$file" ;
 296     }
 297     else {
 298         $directory .= $file ;
 299     }
 300
 301     return $directory ;
 302 }
 303
 304 =item abs2rel
 305
 306 Takes a destination path and an optional base path returns a relative path
 307 from the base path to the destination path:
 308
 309     $rel_path = File::Spec->abs2rel( $destination ) ;
 310     $rel_path = File::Spec->abs2rel( $destination, $base ) ;
 311
 312 If $base is not present or '', then L<cwd()> is used. If $base is relative,
 313 then it is converted to absolute form using L</rel2abs()>. This means that it
 314 is taken to be relative to L<cwd()>.
 315
 316 On systems with the concept of a volume, this assumes that both paths
 317 are on the $destination volume, and ignores the $base volume.
 318
 319 On systems that have a grammar that indicates filenames, this ignores the
 320 $base filename as well. Otherwise all path components are assumed to be
 321 directories.
 322
 323 If $path is relative, it is converted to absolute form using L</rel2abs()>.
 324 This means that it is taken to be relative to L<cwd()>.
 325
 326 Based on code written by Shigio Yamaguchi.
 327
 328 No checks against the filesystem are made.
 329
 330 =cut
 331
 332 sub abs2rel {
 333     my($self,$path,$base) = @_;
 334
 335     # Clean up $path
 336     if ( ! $self->file_name_is_absolute( $path ) ) {
 337         $path = $self->rel2abs( $path ) ;
 338     }
 339     else {
 340         $path = $self->canonpath( $path ) ;
 341     }
 342
 343     # Figure out the effective $base and clean it up.
 344     if ( !defined( $base ) || $base eq '' ) {
 345         $base = cwd() ;
 346     }
 347     elsif ( ! $self->file_name_is_absolute( $base ) ) {
 348         $base = $self->rel2abs( $base ) ;
 349     }
 350     else {
 351         $base = $self->canonpath( $base ) ;
 352     }
 353
 354     # Now, remove all leading components that are the same
 355     my @pathchunks = $self->splitpath( $path );
 356     my @basechunks = ($self->splitpath( $base, 1 ))[0,1];
 357
 358     # Insure same device; case-insensitive since those filesystems
 359     # which use device semantics (VMS and Win32) are case-tolerant
 360     return undef unless lc($pathchunks[0]) eq lc($basechunks[0]);
 361     $path = $pathchunks[0] || '';
 362     @pathchunks = ( $self->splitdir( $pathchunks[1] ), $pathchunks[2] );
 363     @basechunks = $self->splitdir( $basechunks[1] );
 364
 365     # We do case-insensitive comparisons rather than just flattening case
 366     # so caller gets back same case as was sent in
 367     my $lc = $self->case_tolerant;
 368     while (@pathchunks && @basechunks &&
 369            ($lc ? lc($pathchunks[0]) eq lc($basechunks[0])
 370                 : $pathchunks[0] eq $basechunks[0]        ) ) {
 371         shift @pathchunks ;
 372         shift @basechunks ;
 373     }
 374
 375     # @basechunks now contains the directories the resulting relative path
 376     # must ascend out of before it can descend to $path_directory.  So,
 377     # replace all names with $parentDir
 378     @basechunks = ($self->updir()) x @basechunks;
 379
 380     # Glue the two together, using a separator if necessary, and preventing an
 381     # empty result.
 382     $path = $self->catfile($path,@basechunks,@pathchunks);
 383     $path = $self->curdir unless $path;
 384
 385     return $self->canonpath( $path ) ;
 386 }
 387
 388 =item rel2abs
 389
 390 Converts a relative path to an absolute path.
 391
 392     $abs_path = $File::Spec->rel2abs( $destination ) ;
 393     $abs_path = $File::Spec->rel2abs( $destination, $base ) ;
 394
 395 If $base is not present or '', then L<cwd()> is used. If $base is relative,
 396 then it is converted to absolute form using L</rel2abs()>. This means that it
 397 is taken to be relative to L<cwd()>.
 398
 399 On systems with the concept of a volume, this assumes that both paths
 400 are on the $base volume, and ignores the $destination volume.
 401
 402 On systems that have a grammar that indicates filenames, this ignores the
 403 $base filename as well. Otherwise all path components are assumed to be
 404 directories.
 405
 406 If $path is absolute, it is cleaned up and returned using L</canonpath()>.
 407
 408 Based on code written by Shigio Yamaguchi.
 409
 410 No checks against the filesystem are made.
 411
 412 =cut
 413
 414 sub rel2abs($;$;) {
 415     my ($self,$path,$base ) = @_;
 416
 417     # Clean up $path
 418     if ( ! $self->file_name_is_absolute( $path ) ) {
 419         # Figure out the effective $base and clean it up.
 420         if ( !defined( $base ) || $base eq '' ) {
 421             $base = cwd() ;
 422         }
 423         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 424             $base = $self->rel2abs( $base ) ;
 425         }
 426         else {
 427             $base = $self->canonpath( $base ) ;
 428         }
 429
 430         # Glom them together
 431         my($pdev,$pdir,$pfile) = $self->splitpath( $path );
 432         my($bdev,$bdir,$bfile) = $self->splitpath( $base );
 433         $path = $self->catpath( $bdev, $self->catdir( $bdir, $pdir ), $pfile );
 434     }
 435
 436     return $self->canonpath( $path ) ;
 437 }
 438
 439
 440 =back
 441
 442 =head1 SEE ALSO
 443
 444 L<File::Spec>
 445
 446 =cut
 447
 448 1;