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