[Summary view] [Print] [Text view]

   1  package File::Spec::Unix;
   2  
   3  use strict;
   4  use vars qw($VERSION);
   5  
   6  $VERSION = '3.2501';
   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::getcwd();
 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;