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

   1 package File::Spec::Unix;
   2
   3 use strict;
   4 use vars qw($VERSION);
   5
   6 $VERSION = '3.34';
   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,
 242                                                           $no_file );
 243
 244 Splits a path into volume, directory, and filename portions. On systems
 245 with no concept of volume, returns '' for volume.
 246
 247 For systems with no syntax differentiating filenames from directories,
 248 assumes that the last file is a path unless $no_file is true or a
 249 trailing separator or /. or /.. is present. On Unix this means that $no_file
 250 true makes this return ( '', $path, '' ).
 251
 252 The directory portion may or may not be returned with a trailing '/'.
 253
 254 The results can be passed to L</catpath()> to get back a path equivalent to
 255 (usually identical to) the original path.
 256
 257 =cut
 258
 259 sub splitpath {
 260     my ($self,$path, $nofile) = @_;
 261
 262     my ($volume,$directory,$file) = ('','','');
 263
 264     if ( $nofile ) {
 265         $directory = $path;
 266     }
 267     else {
 268         $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
 269         $directory = $1;
 270         $file      = $2;
 271     }
 272
 273     return ($volume,$directory,$file);
 274 }
 275
 276
 277 =item splitdir
 278
 279 The opposite of L</catdir()>.
 280
 281     @dirs = File::Spec->splitdir( $directories );
 282
 283 $directories must be only the directory portion of the path on systems
 284 that have the concept of a volume or that have path syntax that differentiates
 285 files from directories.
 286
 287 Unlike just splitting the directories on the separator, empty
 288 directory names (C<''>) can be returned, because these are significant
 289 on some OSs.
 290
 291 On Unix,
 292
 293     File::Spec->splitdir( "/a/b//c/" );
 294
 295 Yields:
 296
 297     ( '', 'a', 'b', '', 'c', '' )
 298
 299 =cut
 300
 301 sub splitdir {
 302     return split m|/|, $_[1], -1;  # Preserve trailing fields
 303 }
 304
 305
 306 =item catpath()
 307
 308 Takes volume, directory and file portions and returns an entire path. Under
 309 Unix, $volume is ignored, and directory and file are concatenated.  A '/' is
 310 inserted if needed (though if the directory portion doesn't start with
 311 '/' it is not added).  On other OSs, $volume is significant.
 312
 313 =cut
 314
 315 sub catpath {
 316     my ($self,$volume,$directory,$file) = @_;
 317
 318     if ( $directory ne ''                &&
 319          $file ne ''                     &&
 320          substr( $directory, -1 ) ne '/' &&
 321          substr( $file, 0, 1 ) ne '/'
 322     ) {
 323         $directory .= "/$file" ;
 324     }
 325     else {
 326         $directory .= $file ;
 327     }
 328
 329     return $directory ;
 330 }
 331
 332 =item abs2rel
 333
 334 Takes a destination path and an optional base path returns a relative path
 335 from the base path to the destination path:
 336
 337     $rel_path = File::Spec->abs2rel( $path ) ;
 338     $rel_path = File::Spec->abs2rel( $path, $base ) ;
 339
 340 If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
 341 relative, then it is converted to absolute form using
 342 L</rel2abs()>. This means that it is taken to be relative to
 343 L<cwd()|Cwd>.
 344
 345 On systems that have a grammar that indicates filenames, this ignores the
 346 $base filename. Otherwise all path components are assumed to be
 347 directories.
 348
 349 If $path is relative, it is converted to absolute form using L</rel2abs()>.
 350 This means that it is taken to be relative to L<cwd()|Cwd>.
 351
 352 No checks against the filesystem are made.  On VMS, there is
 353 interaction with the working environment, as logicals and
 354 macros are expanded.
 355
 356 Based on code written by Shigio Yamaguchi.
 357
 358 =cut
 359
 360 sub abs2rel {
 361     my($self,$path,$base) = @_;
 362     $base = $self->_cwd() unless defined $base and length $base;
 363
 364     ($path, $base) = map $self->canonpath($_), $path, $base;
 365
 366     if (grep $self->file_name_is_absolute($_), $path, $base) {
 367         ($path, $base) = map $self->rel2abs($_), $path, $base;
 368     }
 369     else {
 370         # save a couple of cwd()s if both paths are relative
 371         ($path, $base) = map $self->catdir('/', $_), $path, $base;
 372     }
 373
 374     my ($path_volume) = $self->splitpath($path, 1);
 375     my ($base_volume) = $self->splitpath($base, 1);
 376
 377     # Can't relativize across volumes
 378     return $path unless $path_volume eq $base_volume;
 379
 380     my $path_directories = ($self->splitpath($path, 1))[1];
 381     my $base_directories = ($self->splitpath($base, 1))[1];
 382
 383     # For UNC paths, the user might give a volume like //foo/bar that
 384     # strictly speaking has no directory portion.  Treat it as if it
 385     # had the root directory for that volume.
 386     if (!length($base_directories) and $self->file_name_is_absolute($base)) {
 387       $base_directories = $self->rootdir;
 388     }
 389
 390     # Now, remove all leading components that are the same
 391     my @pathchunks = $self->splitdir( $path_directories );
 392     my @basechunks = $self->splitdir( $base_directories );
 393
 394     if ($base_directories eq $self->rootdir) {
 395       shift @pathchunks;
 396       return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
 397     }
 398
 399     while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
 400         shift @pathchunks ;
 401         shift @basechunks ;
 402     }
 403     return $self->curdir unless @pathchunks || @basechunks;
 404
 405     # $base now contains the directories the resulting relative path
 406     # must ascend out of before it can descend to $path_directory.
 407     my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
 408     return $self->canonpath( $self->catpath('', $result_dirs, '') );
 409 }
 410
 411 sub _same {
 412   $_[1] eq $_[2];
 413 }
 414
 415 =item rel2abs()
 416
 417 Converts a relative path to an absolute path.
 418
 419     $abs_path = File::Spec->rel2abs( $path ) ;
 420     $abs_path = File::Spec->rel2abs( $path, $base ) ;
 421
 422 If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
 423 relative, then it is converted to absolute form using
 424 L</rel2abs()>. This means that it is taken to be relative to
 425 L<cwd()|Cwd>.
 426
 427 On systems that have a grammar that indicates filenames, this ignores
 428 the $base filename. Otherwise all path components are assumed to be
 429 directories.
 430
 431 If $path is absolute, it is cleaned up and returned using L</canonpath()>.
 432
 433 No checks against the filesystem are made.  On VMS, there is
 434 interaction with the working environment, as logicals and
 435 macros are expanded.
 436
 437 Based on code written by Shigio Yamaguchi.
 438
 439 =cut
 440
 441 sub rel2abs {
 442     my ($self,$path,$base ) = @_;
 443
 444     # Clean up $path
 445     if ( ! $self->file_name_is_absolute( $path ) ) {
 446         # Figure out the effective $base and clean it up.
 447         if ( !defined( $base ) || $base eq '' ) {
 448             $base = $self->_cwd();
 449         }
 450         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 451             $base = $self->rel2abs( $base ) ;
 452         }
 453         else {
 454             $base = $self->canonpath( $base ) ;
 455         }
 456
 457         # Glom them together
 458         $path = $self->catdir( $base, $path ) ;
 459     }
 460
 461     return $self->canonpath( $path ) ;
 462 }
 463
 464 =back
 465
 466 =head1 COPYRIGHT
 467
 468 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
 469
 470 This program is free software; you can redistribute it and/or modify
 471 it under the same terms as Perl itself.
 472
 473 =head1 SEE ALSO
 474
 475 L<File::Spec>
 476
 477 =cut
 478
 479 # Internal routine to File::Spec, no point in making this public since
 480 # it is the standard Cwd interface.  Most of the platform-specific
 481 # File::Spec subclasses use this.
 482 sub _cwd {
 483     require Cwd;
 484     Cwd::getcwd();
 485 }
 486
 487
 488 # Internal method to reduce xx\..\yy -> yy
 489 sub _collapse {
 490     my($fs, $path) = @_;
 491
 492     my $updir  = $fs->updir;
 493     my $curdir = $fs->curdir;
 494
 495     my($vol, $dirs, $file) = $fs->splitpath($path);
 496     my @dirs = $fs->splitdir($dirs);
 497     pop @dirs if @dirs && $dirs[-1] eq '';
 498
 499     my @collapsed;
 500     foreach my $dir (@dirs) {
 501         if( $dir eq $updir              and   # if we have an updir
 502             @collapsed                  and   # and something to collapse
 503             length $collapsed[-1]       and   # and its not the rootdir
 504             $collapsed[-1] ne $updir    and   # nor another updir
 505             $collapsed[-1] ne $curdir         # nor the curdir
 506           )
 507         {                                     # then
 508             pop @collapsed;                   # collapse
 509         }
 510         else {                                # else
 511             push @collapsed, $dir;            # just hang onto it
 512         }
 513     }
 514
 515     return $fs->catpath($vol,
 516                         $fs->catdir(@collapsed),
 517                         $file
 518                        );
 519 }
 520
 521
 522 1;