lib/File/Spec/Unix.pm

   1 package File::Spec::Unix;
   2
   3 use strict;
   4 use vars qw($VERSION);
   5
   6 $VERSION = '3.28_03';
   7 $VERSION = eval $VERSION;
   8
   9 =head1 NAME
  10
  11 File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules
  12
  13 =head1 SYNOPSIS
  14
  15  require File::Spec::Unix; # Done automatically by File::Spec
  16
  17 =head1 DESCRIPTION
  18
  19 Methods for manipulating file specifications.  Other File::Spec
  20 modules, such as File::Spec::Mac, inherit from File::Spec::Unix and
  21 override specific methods.
  22
  23 =head1 METHODS
  24
  25 =over 2
  26
  27 =item canonpath()
  28
  29 No physical check on the filesystem, but a logical cleanup of a
  30 path. On UNIX eliminates successive slashes and successive "/.".
  31
  32     $cpath = File::Spec->canonpath( $path ) ;
  33
  34 Note that this does *not* collapse F<x/../y> sections into F<y>.  This
  35 is by design.  If F</foo> on your system is a symlink to F</bar/baz>,
  36 then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
  37 F<../>-removal would give you.  If you want to do this kind of
  38 processing, you probably want C<Cwd>'s C<realpath()> function to
  39 actually traverse the filesystem cleaning up paths like this.
  40
  41 =cut
  42
  43 sub canonpath {
  44     my ($self,$path) = @_;
  45     return unless defined $path;
  46
  47     # Handle POSIX-style node names beginning with double slash (qnx, nto)
  48     # (POSIX says: "a pathname that begins with two successive slashes
  49     # may be interpreted in an implementation-defined manner, although
  50     # more than two leading slashes shall be treated as a single slash.")
  51     my $node = '';
  52     my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto';
  53
  54
  55     if ( $double_slashes_special
  56          && ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) {
  57       $node = $1;
  58     }
  59     # This used to be
  60     # $path =~ s|/+|/|g unless ($^O eq 'cygwin');
  61     # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail
  62     # (Mainly because trailing "" directories didn't get stripped).
  63     # Why would cygwin avoid collapsing multiple slashes into one? --jhi
  64     $path =~ s|/{2,}|/|g;                            # xx////xx  -> xx/xx
  65     $path =~ s{(?:/\.)+(?:/|\z)}{/}g;                # xx/././xx -> xx/xx
  66     $path =~ s|^(?:\./)+||s unless $path eq "./";    # ./xx      -> xx
  67     $path =~ s|^/(?:\.\./)+|/|;                      # /../../xx -> xx
  68     $path =~ s|^/\.\.$|/|;                         # /..       -> /
  69     $path =~ s|/\z|| unless $path eq "/";          # xx/       -> xx
  70     return "$node$path";
  71 }
  72
  73 =item catdir()
  74
  75 Concatenate two or more directory names to form a complete path ending
  76 with a directory. But remove the trailing slash from the resulting
  77 string, because it doesn't look good, isn't necessary and confuses
  78 OS2. Of course, if this is the root directory, don't cut off the
  79 trailing slash :-)
  80
  81 =cut
  82
  83 sub catdir {
  84     my $self = shift;
  85
  86     $self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
  87 }
  88
  89 =item catfile
  90
  91 Concatenate one or more directory names and a filename to form a
  92 complete path ending with a filename
  93
  94 =cut
  95
  96 sub catfile {
  97     my $self = shift;
  98     my $file = $self->canonpath(pop @_);
  99     return $file unless @_;
 100     my $dir = $self->catdir(@_);
 101     $dir .= "/" unless substr($dir,-1) eq "/";
 102     return $dir.$file;
 103 }
 104
 105 =item curdir
 106
 107 Returns a string representation of the current directory.  "." on UNIX.
 108
 109 =cut
 110
 111 sub curdir { '.' }
 112
 113 =item devnull
 114
 115 Returns a string representation of the null device. "/dev/null" on UNIX.
 116
 117 =cut
 118
 119 sub devnull { '/dev/null' }
 120
 121 =item rootdir
 122
 123 Returns a string representation of the root directory.  "/" on UNIX.
 124
 125 =cut
 126
 127 sub rootdir { '/' }
 128
 129 =item tmpdir
 130
 131 Returns a string representation of the first writable directory from
 132 the following list or the current directory if none from the list are
 133 writable:
 134
 135     $ENV{TMPDIR}
 136     /tmp
 137
 138 Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
 139 is tainted, it is not used.
 140
 141 =cut
 142
 143 my $tmpdir;
 144 sub _tmpdir {
 145     return $tmpdir if defined $tmpdir;
 146     my $self = shift;
 147     my @dirlist = @_;
 148     {
 149         no strict 'refs';
 150         if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0
 151             require Scalar::Util;
 152             @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist;
 153         }
 154     }
 155     foreach (@dirlist) {
 156         next unless defined && -d && -w _;
 157         $tmpdir = $_;
 158         last;
 159     }
 160     $tmpdir = $self->curdir unless defined $tmpdir;
 161     $tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
 162     return $tmpdir;
 163 }
 164
 165 sub tmpdir {
 166     return $tmpdir if defined $tmpdir;
 167     $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" );
 168 }
 169
 170 =item updir
 171
 172 Returns a string representation of the parent directory.  ".." on UNIX.
 173
 174 =cut
 175
 176 sub updir { '..' }
 177
 178 =item no_upwards
 179
 180 Given a list of file names, strip out those that refer to a parent
 181 directory. (Does not strip symlinks, only '.', '..', and equivalents.)
 182
 183 =cut
 184
 185 sub no_upwards {
 186     my $self = shift;
 187     return grep(!/^\.{1,2}\z/s, @_);
 188 }
 189
 190 =item case_tolerant
 191
 192 Returns a true or false value indicating, respectively, that alphabetic
 193 is not or is significant when comparing file specifications.
 194
 195 =cut
 196
 197 sub case_tolerant { 0 }
 198
 199 =item file_name_is_absolute
 200
 201 Takes as argument a path and returns true if it is an absolute path.
 202
 203 This does not consult the local filesystem on Unix, Win32, OS/2 or Mac
 204 OS (Classic).  It does consult the working environment for VMS (see
 205 L<File::Spec::VMS/file_name_is_absolute>).
 206
 207 =cut
 208
 209 sub file_name_is_absolute {
 210     my ($self,$file) = @_;
 211     return scalar($file =~ m:^/:s);
 212 }
 213
 214 =item path
 215
 216 Takes no argument, returns the environment variable PATH as an array.
 217
 218 =cut
 219
 220 sub path {
 221     return () unless exists $ENV{PATH};
 222     my @path = split(':', $ENV{PATH});
 223     foreach (@path) { $_ = '.' if $_ eq '' }
 224     return @path;
 225 }
 226
 227 =item join
 228
 229 join is the same as catfile.
 230
 231 =cut
 232
 233 sub join {
 234     my $self = shift;
 235     return $self->catfile(@_);
 236 }
 237
 238 =item splitpath
 239
 240     ($volume,$directories,$file) = File::Spec->splitpath( $path );
 241     ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
 242
 243 Splits a path into volume, directory, and filename portions. On systems
 244 with no concept of volume, returns '' for volume.
 245
 246 For systems with no syntax differentiating filenames from directories,
 247 assumes that the last file is a path unless $no_file is true or a
 248 trailing separator or /. or /.. is present. On Unix this means that $no_file
 249 true makes this return ( '', $path, '' ).
 250
 251 The directory portion may or may not be returned with a trailing '/'.
 252
 253 The results can be passed to L</catpath()> to get back a path equivalent to
 254 (usually identical to) the original path.
 255
 256 =cut
 257
 258 sub splitpath {
 259     my ($self,$path, $nofile) = @_;
 260
 261     my ($volume,$directory,$file) = ('','','');
 262
 263     if ( $nofile ) {
 264         $directory = $path;
 265     }
 266     else {
 267         $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
 268         $directory = $1;
 269         $file      = $2;
 270     }
 271
 272     return ($volume,$directory,$file);
 273 }
 274
 275
 276 =item splitdir
 277
 278 The opposite of L</catdir()>.
 279
 280     @dirs = File::Spec->splitdir( $directories );
 281
 282 $directories must be only the directory portion of the path on systems
 283 that have the concept of a volume or that have path syntax that differentiates
 284 files from directories.
 285
 286 Unlike just splitting the directories on the separator, empty
 287 directory names (C<''>) can be returned, because these are significant
 288 on some OSs.
 289
 290 On Unix,
 291
 292     File::Spec->splitdir( "/a/b//c/" );
 293
 294 Yields:
 295
 296     ( '', 'a', 'b', '', 'c', '' )
 297
 298 =cut
 299
 300 sub splitdir {
 301     return split m|/|, $_[1], -1;  # Preserve trailing fields
 302 }
 303
 304
 305 =item catpath()
 306
 307 Takes volume, directory and file portions and returns an entire path. Under
 308 Unix, $volume is ignored, and directory and file are concatenated.  A '/' is
 309 inserted if needed (though if the directory portion doesn't start with
 310 '/' it is not added).  On other OSs, $volume is significant.
 311
 312 =cut
 313
 314 sub catpath {
 315     my ($self,$volume,$directory,$file) = @_;
 316
 317     if ( $directory ne ''                &&
 318          $file ne ''                     &&
 319          substr( $directory, -1 ) ne '/' &&
 320          substr( $file, 0, 1 ) ne '/'
 321     ) {
 322         $directory .= "/$file" ;
 323     }
 324     else {
 325         $directory .= $file ;
 326     }
 327
 328     return $directory ;
 329 }
 330
 331 =item abs2rel
 332
 333 Takes a destination path and an optional base path returns a relative path
 334 from the base path to the destination path:
 335
 336     $rel_path = File::Spec->abs2rel( $path ) ;
 337     $rel_path = File::Spec->abs2rel( $path, $base ) ;
 338
 339 If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
 340 relative, then it is converted to absolute form using
 341 L</rel2abs()>. This means that it is taken to be relative to
 342 L<cwd()|Cwd>.
 343
 344 On systems that have a grammar that indicates filenames, this ignores the
 345 $base filename. Otherwise all path components are assumed to be
 346 directories.
 347
 348 If $path is relative, it is converted to absolute form using L</rel2abs()>.
 349 This means that it is taken to be relative to L<cwd()|Cwd>.
 350
 351 No checks against the filesystem are made.  On VMS, there is
 352 interaction with the working environment, as logicals and
 353 macros are expanded.
 354
 355 Based on code written by Shigio Yamaguchi.
 356
 357 =cut
 358
 359 sub abs2rel {
 360     my($self,$path,$base) = @_;
 361     $base = $self->_cwd() unless defined $base and length $base;
 362
 363     ($path, $base) = map $self->canonpath($_), $path, $base;
 364
 365     if (grep $self->file_name_is_absolute($_), $path, $base) {
 366         ($path, $base) = map $self->rel2abs($_), $path, $base;
 367     }
 368     else {
 369         # save a couple of cwd()s if both paths are relative
 370         ($path, $base) = map $self->catdir('/', $_), $path, $base;
 371     }
 372
 373     my ($path_volume) = $self->splitpath($path, 1);
 374     my ($base_volume) = $self->splitpath($base, 1);
 375
 376     # Can't relativize across volumes
 377     return $path unless $path_volume eq $base_volume;
 378
 379     my $path_directories = ($self->splitpath($path, 1))[1];
 380     my $base_directories = ($self->splitpath($base, 1))[1];
 381
 382     # For UNC paths, the user might give a volume like //foo/bar that
 383     # strictly speaking has no directory portion.  Treat it as if it
 384     # had the root directory for that volume.
 385     if (!length($base_directories) and $self->file_name_is_absolute($base)) {
 386       $base_directories = $self->rootdir;
 387     }
 388
 389     # Now, remove all leading components that are the same
 390     my @pathchunks = $self->splitdir( $path_directories );
 391     my @basechunks = $self->splitdir( $base_directories );
 392
 393     if ($base_directories eq $self->rootdir) {
 394       shift @pathchunks;
 395       return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
 396     }
 397
 398     while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
 399         shift @pathchunks ;
 400         shift @basechunks ;
 401     }
 402     return $self->curdir unless @pathchunks || @basechunks;
 403
 404     # $base now contains the directories the resulting relative path
 405     # must ascend out of before it can descend to $path_directory.
 406     my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
 407     return $self->canonpath( $self->catpath('', $result_dirs, '') );
 408 }
 409
 410 sub _same {
 411   $_[1] eq $_[2];
 412 }
 413
 414 =item rel2abs()
 415
 416 Converts a relative path to an absolute path.
 417
 418     $abs_path = File::Spec->rel2abs( $path ) ;
 419     $abs_path = File::Spec->rel2abs( $path, $base ) ;
 420
 421 If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
 422 relative, then it is converted to absolute form using
 423 L</rel2abs()>. This means that it is taken to be relative to
 424 L<cwd()|Cwd>.
 425
 426 On systems that have a grammar that indicates filenames, this ignores
 427 the $base filename. Otherwise all path components are assumed to be
 428 directories.
 429
 430 If $path is absolute, it is cleaned up and returned using L</canonpath()>.
 431
 432 No checks against the filesystem are made.  On VMS, there is
 433 interaction with the working environment, as logicals and
 434 macros are expanded.
 435
 436 Based on code written by Shigio Yamaguchi.
 437
 438 =cut
 439
 440 sub rel2abs {
 441     my ($self,$path,$base ) = @_;
 442
 443     # Clean up $path
 444     if ( ! $self->file_name_is_absolute( $path ) ) {
 445         # Figure out the effective $base and clean it up.
 446         if ( !defined( $base ) || $base eq '' ) {
 447             $base = $self->_cwd();
 448         }
 449         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 450             $base = $self->rel2abs( $base ) ;
 451         }
 452         else {
 453             $base = $self->canonpath( $base ) ;
 454         }
 455
 456         # Glom them together
 457         $path = $self->catdir( $base, $path ) ;
 458     }
 459
 460     return $self->canonpath( $path ) ;
 461 }
 462
 463 =back
 464
 465 =head1 COPYRIGHT
 466
 467 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
 468
 469 This program is free software; you can redistribute it and/or modify
 470 it under the same terms as Perl itself.
 471
 472 =head1 SEE ALSO
 473
 474 L<File::Spec>
 475
 476 =cut
 477
 478 # Internal routine to File::Spec, no point in making this public since
 479 # it is the standard Cwd interface.  Most of the platform-specific
 480 # File::Spec subclasses use this.
 481 sub _cwd {
 482     require Cwd;
 483     Cwd::getcwd();
 484 }
 485
 486
 487 # Internal method to reduce xx\..\yy -> yy
 488 sub _collapse {
 489     my($fs, $path) = @_;
 490
 491     my $updir  = $fs->updir;
 492     my $curdir = $fs->curdir;
 493
 494     my($vol, $dirs, $file) = $fs->splitpath($path);
 495     my @dirs = $fs->splitdir($dirs);
 496     pop @dirs if @dirs && $dirs[-1] eq '';
 497
 498     my @collapsed;
 499     foreach my $dir (@dirs) {
 500         if( $dir eq $updir              and   # if we have an updir
 501             @collapsed                  and   # and something to collapse
 502             length $collapsed[-1]       and   # and its not the rootdir
 503             $collapsed[-1] ne $updir    and   # nor another updir
 504             $collapsed[-1] ne $curdir         # nor the curdir
 505           )
 506         {                                     # then
 507             pop @collapsed;                   # collapse
 508         }
 509         else {                                # else
 510             push @collapsed, $dir;            # just hang onto it
 511         }
 512     }
 513
 514     return $fs->catpath($vol,
 515                         $fs->catdir(@collapsed),
 516                         $file
 517                        );
 518 }
 519
 520
 521 1;