lib/File/Spec/Unix.pm

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