lib/File/Spec/Unix.pm

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