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     # For UNC paths, the user might give a volume like //foo/bar that
 373     # strictly speaking has no directory portion.  Treat it as if it
 374     # had the root directory for that volume.
 375     if (!length($base_directories) and $self->file_name_is_absolute($base)) {
 376       $base_directories = $self->rootdir;
 377     }
 378
 379     # Now, remove all leading components that are the same
 380     my @pathchunks = $self->splitdir( $path_directories );
 381     my @basechunks = $self->splitdir( $base_directories );
 382
 383     if ($base_directories eq $self->rootdir) {
 384       shift @pathchunks;
 385       return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
 386     }
 387
 388     while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
 389         shift @pathchunks ;
 390         shift @basechunks ;
 391     }
 392     return $self->curdir unless @pathchunks || @basechunks;
 393
 394     # $base now contains the directories the resulting relative path
 395     # must ascend out of before it can descend to $path_directory.
 396     my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
 397     return $self->canonpath( $self->catpath('', $result_dirs, '') );
 398 }
 399
 400 sub _same {
 401   $_[1] eq $_[2];
 402 }
 403
 404 =item rel2abs()
 405
 406 Converts a relative path to an absolute path.
 407
 408     $abs_path = File::Spec->rel2abs( $path ) ;
 409     $abs_path = File::Spec->rel2abs( $path, $base ) ;
 410
 411 If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
 412 relative, then it is converted to absolute form using
 413 L</rel2abs()>. This means that it is taken to be relative to
 414 L<cwd()|Cwd>.
 415
 416 On systems that have a grammar that indicates filenames, this ignores
 417 the $base filename. Otherwise all path components are assumed to be
 418 directories.
 419
 420 If $path is absolute, it is cleaned up and returned using L</canonpath()>.
 421
 422 No checks against the filesystem are made.  On VMS, there is
 423 interaction with the working environment, as logicals and
 424 macros are expanded.
 425
 426 Based on code written by Shigio Yamaguchi.
 427
 428 =cut
 429
 430 sub rel2abs {
 431     my ($self,$path,$base ) = @_;
 432
 433     # Clean up $path
 434     if ( ! $self->file_name_is_absolute( $path ) ) {
 435         # Figure out the effective $base and clean it up.
 436         if ( !defined( $base ) || $base eq '' ) {
 437             $base = $self->_cwd();
 438         }
 439         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 440             $base = $self->rel2abs( $base ) ;
 441         }
 442         else {
 443             $base = $self->canonpath( $base ) ;
 444         }
 445
 446         # Glom them together
 447         $path = $self->catdir( $base, $path ) ;
 448     }
 449
 450     return $self->canonpath( $path ) ;
 451 }
 452
 453 =back
 454
 455 =head1 COPYRIGHT
 456
 457 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
 458
 459 This program is free software; you can redistribute it and/or modify
 460 it under the same terms as Perl itself.
 461
 462 =head1 SEE ALSO
 463
 464 L<File::Spec>
 465
 466 =cut
 467
 468 # Internal routine to File::Spec, no point in making this public since
 469 # it is the standard Cwd interface.  Most of the platform-specific
 470 # File::Spec subclasses use this.
 471 sub _cwd {
 472     require Cwd;
 473     Cwd::cwd();
 474 }
 475
 476
 477 # Internal method to reduce xx\..\yy -> yy
 478 sub _collapse {
 479     my($fs, $path) = @_;
 480
 481     my $updir  = $fs->updir;
 482     my $curdir = $fs->curdir;
 483
 484     my($vol, $dirs, $file) = $fs->splitpath($path);
 485     my @dirs = $fs->splitdir($dirs);
 486
 487     my @collapsed;
 488     foreach my $dir (@dirs) {
 489         if( $dir eq $updir              and   # if we have an updir
 490             @collapsed                  and   # and something to collapse
 491             length $collapsed[-1]       and   # and its not the rootdir
 492             $collapsed[-1] ne $updir    and   # nor another updir
 493             $collapsed[-1] ne $curdir         # nor the curdir
 494           )
 495         {                                     # then
 496             pop @collapsed;                   # collapse
 497         }
 498         else {                                # else
 499             push @collapsed, $dir;            # just hang onto it
 500         }
 501     }
 502
 503     return $fs->catpath($vol,
 504                         $fs->catdir(@collapsed),
 505                         $file
 506                        );
 507 }
 508
 509
 510 1;