dist/PathTools/lib/File/Spec/Unix.pm

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