diff options
Diffstat (limited to 'cpan/lib/File/Spec/Unix.pm')
| -rw-r--r-- | cpan/lib/File/Spec/Unix.pm | 276 |
1 files changed, 206 insertions, 70 deletions
diff --git a/cpan/lib/File/Spec/Unix.pm b/cpan/lib/File/Spec/Unix.pm index 349757b6..586e9b0a 100644 --- a/cpan/lib/File/Spec/Unix.pm +++ b/cpan/lib/File/Spec/Unix.pm @@ -3,7 +3,23 @@ package File::Spec::Unix; use strict; use vars qw($VERSION); -$VERSION = '1.5'; +$VERSION = '3.62'; +my $xs_version = $VERSION; +$VERSION =~ tr/_//d; + +#dont try to load XSLoader and DynaLoader only to ultimately fail on miniperl +if(!defined &canonpath && defined &DynaLoader::boot_DynaLoader) { + eval {#eval is questionable since we are handling potential errors like + #"Cwd object version 3.48 does not match bootstrap parameter 3.50 + #at lib/DynaLoader.pm line 216." by having this eval + if ( $] >= 5.006 ) { + require XSLoader; + XSLoader::load("Cwd", $xs_version); + } else { + require Cwd; + } + }; +} =head1 NAME @@ -30,32 +46,45 @@ path. On UNIX eliminates successive slashes and successive "/.". $cpath = File::Spec->canonpath( $path ) ; +Note that this does *not* collapse F<x/../y> sections into F<y>. This +is by design. If F</foo> on your system is a symlink to F</bar/baz>, +then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive +F<../>-removal would give you. If you want to do this kind of +processing, you probably want C<Cwd>'s C<realpath()> function to +actually traverse the filesystem cleaning up paths like this. + =cut -sub canonpath { +sub _pp_canonpath { my ($self,$path) = @_; + return unless defined $path; # Handle POSIX-style node names beginning with double slash (qnx, nto) - # Handle network path names beginning with double slash (cygwin) # (POSIX says: "a pathname that begins with two successive slashes # may be interpreted in an implementation-defined manner, although # more than two leading slashes shall be treated as a single slash.") my $node = ''; - if ( $^O =~ m/^(?:qnx|nto|cygwin)$/ && $path =~ s:^(//[^/]+)(/|\z):/:s ) { + my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto'; + + + if ( $double_slashes_special + && ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) { $node = $1; } # This used to be - # $path =~ s|/+|/|g unless($^O eq 'cygwin'); + # $path =~ s|/+|/|g unless ($^O eq 'cygwin'); # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail # (Mainly because trailing "" directories didn't get stripped). # Why would cygwin avoid collapsing multiple slashes into one? --jhi - $path =~ s|/+|/|g; # xx////xx -> xx/xx - $path =~ s@(/\.)+(/|\Z(?!\n))@/@g; # xx/././xx -> xx/xx - $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx - $path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx - $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx + $path =~ s|/{2,}|/|g; # xx////xx -> xx/xx + $path =~ s{(?:/\.)+(?:/|\z)}{/}g; # xx/././xx -> xx/xx + $path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx + $path =~ s|^/(?:\.\./)+|/|; # /../../xx -> xx + $path =~ s|^/\.\.$|/|; # /.. -> / + $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx return "$node$path"; } +*canonpath = \&_pp_canonpath unless defined &canonpath; =item catdir() @@ -67,11 +96,12 @@ trailing slash :-) =cut -sub catdir { +sub _pp_catdir { my $self = shift; $self->canonpath(join('/', @_, '')); # '' because need a trailing '/' } +*catdir = \&_pp_catdir unless defined &catdir; =item catfile @@ -80,7 +110,7 @@ complete path ending with a filename =cut -sub catfile { +sub _pp_catfile { my $self = shift; my $file = $self->canonpath(pop @_); return $file unless @_; @@ -88,6 +118,7 @@ sub catfile { $dir .= "/" unless substr($dir,-1) eq "/"; return $dir.$file; } +*catfile = \&_pp_catfile unless defined &catfile; =item curdir @@ -95,7 +126,8 @@ Returns a string representation of the current directory. "." on UNIX. =cut -sub curdir () { '.' } +sub curdir { '.' } +use constant _fn_curdir => "."; =item devnull @@ -103,7 +135,8 @@ Returns a string representation of the null device. "/dev/null" on UNIX. =cut -sub devnull () { '/dev/null' } +sub devnull { '/dev/null' } +use constant _fn_devnull => "/dev/null"; =item rootdir @@ -111,7 +144,8 @@ Returns a string representation of the root directory. "/" on UNIX. =cut -sub rootdir () { '/' } +sub rootdir { '/' } +use constant _fn_rootdir => "/"; =item tmpdir @@ -122,23 +156,38 @@ writable: $ENV{TMPDIR} /tmp -Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR} +If running under taint mode, and if $ENV{TMPDIR} is tainted, it is not used. =cut -my $tmpdir; +my ($tmpdir, %tmpenv); +# Cache and return the calculated tmpdir, recording which env vars +# determined it. +sub _cache_tmpdir { + @tmpenv{@_[2..$#_]} = @ENV{@_[2..$#_]}; + return $tmpdir = $_[1]; +} +# Retrieve the cached tmpdir, checking first whether relevant env vars have +# changed and invalidated the cache. +sub _cached_tmpdir { + shift; + local $^W; + return if grep $ENV{$_} ne $tmpenv{$_}, @_; + return $tmpdir; +} sub _tmpdir { - return $tmpdir if defined $tmpdir; my $self = shift; my @dirlist = @_; - { - no strict 'refs'; - if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0 - require Scalar::Util; - @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; - } + my $taint = do { no strict 'refs'; ${"\cTAINT"} }; + if ($taint) { # Check for taint mode on perl >= 5.8.0 + require Scalar::Util; + @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; + } + elsif ($] < 5.007) { # No ${^TAINT} before 5.8 + @dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist; } + foreach (@dirlist) { next unless defined && -d && -w _; $tmpdir = $_; @@ -146,13 +195,22 @@ sub _tmpdir { } $tmpdir = $self->curdir unless defined $tmpdir; $tmpdir = defined $tmpdir && $self->canonpath($tmpdir); + if ( !$self->file_name_is_absolute($tmpdir) ) { + # See [perl #120593] for the full details + # If possible, return a full path, rather than '.' or 'lib', but + # jump through some hoops to avoid returning a tainted value. + ($tmpdir) = grep { + $taint ? ! Scalar::Util::tainted($_) : + $] < 5.007 ? eval { eval('1'.substr $_,0,0) } : 1 + } $self->rel2abs($tmpdir), $tmpdir; + } return $tmpdir; } sub tmpdir { - return $tmpdir if defined $tmpdir; - my $self = shift; - $tmpdir = $self->_tmpdir( $ENV{TMPDIR}, "/tmp" ); + my $cached = $_[0]->_cached_tmpdir('TMPDIR'); + return $cached if defined $cached; + $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ), 'TMPDIR'); } =item updir @@ -161,7 +219,8 @@ Returns a string representation of the parent directory. ".." on UNIX. =cut -sub updir () { '..' } +sub updir { '..' } +use constant _fn_updir => ".."; =item no_upwards @@ -172,7 +231,7 @@ directory. (Does not strip symlinks, only '.', '..', and equivalents.) sub no_upwards { my $self = shift; - return grep(!/^\.{1,2}\Z(?!\n)/s, @_); + return grep(!/^\.{1,2}\z/s, @_); } =item case_tolerant @@ -182,7 +241,8 @@ is not or is significant when comparing file specifications. =cut -sub case_tolerant () { 0 } +sub case_tolerant { 0 } +use constant _fn_case_tolerant => 0; =item file_name_is_absolute @@ -226,7 +286,8 @@ sub join { =item splitpath ($volume,$directories,$file) = File::Spec->splitpath( $path ); - ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, + $no_file ); Splits a path into volume, directory, and filename portions. On systems with no concept of volume, returns '' for volume. @@ -252,7 +313,7 @@ sub splitpath { $directory = $path; } else { - $path =~ m|^ ( (?: .* / (?: \.\.?\Z(?!\n) )? )? ) ([^/]*) |xs; + $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs; $directory = $1; $file = $2; } @@ -336,9 +397,11 @@ directories. If $path is relative, it is converted to absolute form using L</rel2abs()>. This means that it is taken to be relative to L<cwd()|Cwd>. -No checks against the filesystem are made. On VMS, there is -interaction with the working environment, as logicals and -macros are expanded. +No checks against the filesystem are made, so the result may not be correct if +C<$base> contains symbolic links. (Apply +L<Cwd::abs_path()|Cwd/abs_path> beforehand if that +is a concern.) On VMS, there is interaction with the working environment, as +logicals and macros are expanded. Based on code written by Shigio Yamaguchi. @@ -346,52 +409,81 @@ Based on code written by Shigio Yamaguchi. sub abs2rel { my($self,$path,$base) = @_; + $base = $self->_cwd() unless defined $base and length $base; - # Clean up $path - if ( ! $self->file_name_is_absolute( $path ) ) { - $path = $self->rel2abs( $path ) ; - } - else { - $path = $self->canonpath( $path ) ; - } + ($path, $base) = map $self->canonpath($_), $path, $base; - # Figure out the effective $base and clean it up. - if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd(); - } - elsif ( ! $self->file_name_is_absolute( $base ) ) { - $base = $self->rel2abs( $base ) ; + my $path_directories; + my $base_directories; + + if (grep $self->file_name_is_absolute($_), $path, $base) { + ($path, $base) = map $self->rel2abs($_), $path, $base; + + my ($path_volume) = $self->splitpath($path, 1); + my ($base_volume) = $self->splitpath($base, 1); + + # Can't relativize across volumes + return $path unless $path_volume eq $base_volume; + + $path_directories = ($self->splitpath($path, 1))[1]; + $base_directories = ($self->splitpath($base, 1))[1]; + + # For UNC paths, the user might give a volume like //foo/bar that + # strictly speaking has no directory portion. Treat it as if it + # had the root directory for that volume. + if (!length($base_directories) and $self->file_name_is_absolute($base)) { + $base_directories = $self->rootdir; + } } else { - $base = $self->canonpath( $base ) ; + my $wd= ($self->splitpath($self->_cwd(), 1))[1]; + $path_directories = $self->catdir($wd, $path); + $base_directories = $self->catdir($wd, $base); } # Now, remove all leading components that are the same - my @pathchunks = $self->splitdir( $path); - my @basechunks = $self->splitdir( $base); + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); - while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) { - shift @pathchunks ; - shift @basechunks ; + if ($base_directories eq $self->rootdir) { + return $self->curdir if $path_directories eq $self->rootdir; + shift @pathchunks; + return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') ); } - $path = CORE::join( '/', @pathchunks ); - $base = CORE::join( '/', @basechunks ); - - # $base now contains the directories the resulting relative path - # must ascend out of before it can descend to $path_directory. So, - # replace all names with $parentDir - $base =~ s|[^/]+|..|g ; - - # Glue the two together, using a separator if necessary, and preventing an - # empty result. - if ( $path ne '' && $base ne '' ) { - $path = "$base/$path" ; - } else { - $path = "$base$path" ; + my @common; + while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) { + push @common, shift @pathchunks ; + shift @basechunks ; } + return $self->curdir unless @pathchunks || @basechunks; + + # @basechunks now contains the directories the resulting relative path + # must ascend out of before it can descend to $path_directory. If there + # are updir components, we must descend into the corresponding directories + # (this only works if they are no symlinks). + my @reverse_base; + while( defined(my $dir= shift @basechunks) ) { + if( $dir ne $self->updir ) { + unshift @reverse_base, $self->updir; + push @common, $dir; + } + elsif( @common ) { + if( @reverse_base && $reverse_base[0] eq $self->updir ) { + shift @reverse_base; + pop @common; + } + else { + unshift @reverse_base, pop @common; + } + } + } + my $result_dirs = $self->catdir( @reverse_base, @pathchunks ); + return $self->canonpath( $self->catpath('', $result_dirs, '') ); +} - return $self->canonpath( $path ) ; +sub _same { + $_[1] eq $_[2]; } =item rel2abs() @@ -445,6 +537,15 @@ sub rel2abs { =back +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +Please submit bug reports and patches to perlbug@perl.org. + =head1 SEE ALSO L<File::Spec> @@ -456,7 +557,42 @@ L<File::Spec> # File::Spec subclasses use this. sub _cwd { require Cwd; - Cwd::cwd(); + Cwd::getcwd(); } + +# Internal method to reduce xx\..\yy -> yy +sub _collapse { + my($fs, $path) = @_; + + my $updir = $fs->updir; + my $curdir = $fs->curdir; + + my($vol, $dirs, $file) = $fs->splitpath($path); + my @dirs = $fs->splitdir($dirs); + pop @dirs if @dirs && $dirs[-1] eq ''; + + my @collapsed; + foreach my $dir (@dirs) { + if( $dir eq $updir and # if we have an updir + @collapsed and # and something to collapse + length $collapsed[-1] and # and its not the rootdir + $collapsed[-1] ne $updir and # nor another updir + $collapsed[-1] ne $curdir # nor the curdir + ) + { # then + pop @collapsed; # collapse + } + else { # else + push @collapsed, $dir; # just hang onto it + } + } + + return $fs->catpath($vol, + $fs->catdir(@collapsed), + $file + ); +} + + 1; |