diff options
Diffstat (limited to 'cpan/lib/File')
| -rw-r--r-- | cpan/lib/File/Spec.pm | 128 | ||||
| -rw-r--r-- | cpan/lib/File/Spec/AmigaOS.pm | 61 | ||||
| -rw-r--r-- | cpan/lib/File/Spec/Cygwin.pm | 87 | ||||
| -rw-r--r-- | cpan/lib/File/Spec/Epoc.pm | 25 | ||||
| -rw-r--r-- | cpan/lib/File/Spec/Functions.pm | 35 | ||||
| -rw-r--r-- | cpan/lib/File/Spec/Mac.pm | 48 | ||||
| -rw-r--r-- | cpan/lib/File/Spec/OS2.pm | 24 | ||||
| -rw-r--r-- | cpan/lib/File/Spec/Unix.pm | 276 | ||||
| -rw-r--r-- | cpan/lib/File/Spec/VMS.pm | 441 | ||||
| -rw-r--r-- | cpan/lib/File/Spec/Win32.pm | 340 |
10 files changed, 987 insertions, 478 deletions
diff --git a/cpan/lib/File/Spec.pm b/cpan/lib/File/Spec.pm index a911fa29..2709c39f 100644 --- a/cpan/lib/File/Spec.pm +++ b/cpan/lib/File/Spec.pm @@ -3,7 +3,8 @@ package File::Spec; use strict; use vars qw(@ISA $VERSION); -$VERSION = '0.85_03'; +$VERSION = '3.62'; +$VERSION =~ tr/_//d; my %module = (MacOS => 'Mac', MSWin32 => 'Win32', @@ -11,8 +12,10 @@ my %module = (MacOS => 'Mac', VMS => 'VMS', epoc => 'Epoc', NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare. - dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP. - cygwin => 'Cygwin'); + symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian. + dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP. + cygwin => 'Cygwin', + amigaos => 'AmigaOS'); my $module = $module{$^O} || 'Unix'; @@ -81,23 +84,33 @@ forms of these methods. =over 2 =item canonpath +X<canonpath> No physical check on the filesystem, but a logical cleanup of a path. $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. + =item catdir +X<catdir> Concatenate two or more directory names to form a complete path ending with a directory. But remove the trailing slash from the resulting string, because it doesn't look good, isn't necessary and confuses -OS2. Of course, if this is the root directory, don't cut off the +OS/2. Of course, if this is the root directory, don't cut off the trailing slash :-) $path = File::Spec->catdir( @directories ); =item catfile +X<catfile> Concatenate one or more directory names and a filename to form a complete path ending with a filename @@ -105,34 +118,39 @@ complete path ending with a filename $path = File::Spec->catfile( @directories, $filename ); =item curdir +X<curdir> Returns a string representation of the current directory. $curdir = File::Spec->curdir(); =item devnull +X<devnull> Returns a string representation of the null device. $devnull = File::Spec->devnull(); =item rootdir +X<rootdir> Returns a string representation of the root directory. $rootdir = File::Spec->rootdir(); =item tmpdir +X<tmpdir> Returns a string representation of the first writable directory from a list of possible temporary directories. Returns the current directory if no writable temporary directories are found. The list of directories -checked depends on the platform; e.g. File::Spec::Unix checks $ENV{TMPDIR} -(unless taint is on) and /tmp. +checked depends on the platform; e.g. File::Spec::Unix checks C<$ENV{TMPDIR}> +(unless taint is on) and F</tmp>. $tmpdir = File::Spec->tmpdir(); =item updir +X<updir> Returns a string representation of the parent directory. @@ -148,13 +166,14 @@ directory. (Does not strip symlinks, only '.', '..', and equivalents.) =item case_tolerant Returns a true or false value indicating, respectively, that alphabetic -is not or is significant when comparing file specifications. +case is not or is significant when comparing file specifications. +Cygwin and Win32 accept an optional drive argument. $is_case_tolerant = File::Spec->case_tolerant(); =item file_name_is_absolute -Takes as argument a path and returns true if it is an absolute path. +Takes as its argument a path, and returns true if it is an absolute path. $is_absolute = File::Spec->file_name_is_absolute( $path ); @@ -163,27 +182,32 @@ Mac OS (Classic). It does consult the working environment for VMS (see L<File::Spec::VMS/file_name_is_absolute>). =item path +X<path> -Takes no argument, returns the environment variable PATH (or the local +Takes no argument. Returns the environment variable C<PATH> (or the local platform's equivalent) as a list. @PATH = File::Spec->path(); =item join +X<join, path> join is the same as catfile. =item splitpath +X<splitpath> X<split, path> Splits a path in to volume, directory, and filename portions. On systems with no concept of volume, returns '' for volume. - ($volume,$directories,$file) = File::Spec->splitpath( $path ); - ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + ($volume,$directories,$file) = + File::Spec->splitpath( $path ); + ($volume,$directories,$file) = + File::Spec->splitpath( $path, $no_file ); For systems with no syntax differentiating filenames from directories, -assumes that the last file is a path unless $no_file is true or a -trailing separator or /. or /.. is present. On Unix this means that $no_file +assumes that the last file is a path unless C<$no_file> is true or a +trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file> true makes this return ( '', $path, '' ). The directory portion may or may not be returned with a trailing '/'. @@ -192,28 +216,30 @@ The results can be passed to L</catpath()> to get back a path equivalent to (usually identical to) the original path. =item splitdir +X<splitdir> X<split, dir> -The opposite of L</catdir()>. +The opposite of L</catdir>. @dirs = File::Spec->splitdir( $directories ); -$directories must be only the directory portion of the path on systems +C<$directories> must be only the directory portion of the path on systems that have the concept of a volume or that have path syntax that differentiates files from directories. Unlike just splitting the directories on the separator, empty directory names (C<''>) can be returned, because these are significant -on some OSs. +on some OSes. =item catpath() Takes volume, directory and file portions and returns an entire path. Under -Unix, $volume is ignored, and directory and file are concatenated. A '/' is -inserted if need be. On other OSs, $volume is significant. +Unix, C<$volume> is ignored, and directory and file are concatenated. A '/' is +inserted if need be. On other OSes, C<$volume> is significant. $full_path = File::Spec->catpath( $volume, $directory, $file ); =item abs2rel +X<abs2rel> X<absolute, path> X<relative, path> Takes a destination path and an optional base path returns a relative path from the base path to the destination path: @@ -221,23 +247,23 @@ from the base path to the destination path: $rel_path = File::Spec->abs2rel( $path ) ; $rel_path = File::Spec->abs2rel( $path, $base ) ; -If $base is not present or '', then L<cwd()|Cwd> is used. If $base is +If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is relative, then it is converted to absolute form using L</rel2abs()>. This means that it is taken to be relative to -L<cwd()|Cwd>. +L<Cwd::cwd()|Cwd>. -On systems with the concept of volume, if $path and $base appear to be +On systems with the concept of volume, if C<$path> and C<$base> appear to be on two different volumes, we will not attempt to resolve the two -paths, and we will instead simply return $path. Note that previous -versions of this module ignored the volume of $base, which resulted in +paths, and we will instead simply return C<$path>. Note that previous +versions of this module ignored the volume of C<$base>, which resulted in garbage results part of the time. On systems that have a grammar that indicates filenames, this ignores the -$base filename as well. Otherwise all path components are assumed to be +C<$base> filename as well. Otherwise all path components are assumed to be 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>. +If C<$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()|Cwd>. No checks against the filesystem are made. On VMS, there is interaction with the working environment, as logicals and @@ -246,27 +272,28 @@ macros are expanded. Based on code written by Shigio Yamaguchi. =item rel2abs() +X<rel2abs> X<absolute, path> X<relative, path> Converts a relative path to an absolute path. $abs_path = File::Spec->rel2abs( $path ) ; $abs_path = File::Spec->rel2abs( $path, $base ) ; -If $base is not present or '', then L<cwd()|Cwd> is used. If $base is relative, +If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is relative, then it is converted to absolute form using L</rel2abs()>. This means that it -is taken to be relative to L<cwd()|Cwd>. +is taken to be relative to L<Cwd::cwd()|Cwd>. -On systems with the concept of volume, if $path and $base appear to be +On systems with the concept of volume, if C<$path> and C<$base> appear to be on two different volumes, we will not attempt to resolve the two -paths, and we will instead simply return $path. Note that previous -versions of this module ignored the volume of $base, which resulted in +paths, and we will instead simply return C<$path>. Note that previous +versions of this module ignored the volume of C<$base>, which resulted in garbage results part of the time. On systems that have a grammar that indicates filenames, this ignores the -$base filename as well. Otherwise all path components are assumed to be +C<$base> filename as well. Otherwise all path components are assumed to be directories. -If $path is absolute, it is cleaned up and returned using L</canonpath()>. +If C<$path> is absolute, it is cleaned up and returned using L</canonpath>. No checks against the filesystem are made. On VMS, there is interaction with the working environment, as logicals and @@ -286,17 +313,28 @@ L<File::Spec::Unix>, L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, L<File::Spec::VMS>, L<File::Spec::Functions>, L<ExtUtils::MakeMaker> -=head1 AUTHORS - -Kenneth Albanowski <kjahds@kjahds.com>, Andy Dougherty -<doughera@lafayette.edu>, Andreas KE<ouml>nig -<A.Koenig@franz.ww.TU-Berlin.DE>, Tim Bunce <Tim.Bunce@ig.co.uk. -VMS support by Charles Bailey <bailey@newman.upenn.edu>. -OS/2 support by Ilya Zakharevich <ilya@math.ohio-state.edu>. -Mac support by Paul Schinder <schinder@pobox.com>, and Thomas Wegner -<wegner_thomas@yahoo.com>. abs2rel() and rel2abs() written by Shigio -Yamaguchi <shigio@tamacom.com>, modified by Barrie Slaymaker -<barries@slaysys.com>. splitpath(), splitdir(), catpath() and -catdir() by Barrie Slaymaker. +=head1 AUTHOR + +Currently maintained by Ken Williams C<< <KWILLIAMS@cpan.org> >>. + +The vast majority of the code was written by +Kenneth Albanowski C<< <kjahds@kjahds.com> >>, +Andy Dougherty C<< <doughera@lafayette.edu> >>, +Andreas KE<ouml>nig C<< <A.Koenig@franz.ww.TU-Berlin.DE> >>, +Tim Bunce C<< <Tim.Bunce@ig.co.uk> >>. +VMS support by Charles Bailey C<< <bailey@newman.upenn.edu> >>. +OS/2 support by Ilya Zakharevich C<< <ilya@math.ohio-state.edu> >>. +Mac support by Paul Schinder C<< <schinder@pobox.com> >>, and +Thomas Wegner C<< <wegner_thomas@yahoo.com> >>. +abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio@tamacom.com> >>, +modified by Barrie Slaymaker C<< <barries@slaysys.com> >>. +splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker. + +=head1 COPYRIGHT + +Copyright (c) 2004-2013 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. =cut diff --git a/cpan/lib/File/Spec/AmigaOS.pm b/cpan/lib/File/Spec/AmigaOS.pm new file mode 100644 index 00000000..e6d6f5f2 --- /dev/null +++ b/cpan/lib/File/Spec/AmigaOS.pm @@ -0,0 +1,61 @@ +package File::Spec::AmigaOS; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '3.62'; +$VERSION =~ tr/_//d; + +@ISA = qw(File::Spec::Unix); + +=head1 NAME + +File::Spec::AmigaOS - File::Spec for AmigaOS + +=head1 SYNOPSIS + + require File::Spec::AmigaOS; # Done automatically by File::Spec if needed + +=head1 DESCRIPTION + +Methods for manipulating file specifications. + +=head1 METHODS + +=over 2 + +=item tmpdir + +Returns $ENV{TMPDIR} or if that is unset, "/t". + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/t" ); +} + +=item file_name_is_absolute + +Returns true if there's a colon in the file name, +or if it begins with a slash. + +=cut + +sub file_name_is_absolute { + my ($self, $file) = @_; + + # Not 100% robust as a "/" must not preceded a ":" + # but this cannot happen in a well formed path. + return $file =~ m{^/|:}s; +} + +=back + +All the other methods are from L<File::Spec::Unix>. + +=cut + +1; diff --git a/cpan/lib/File/Spec/Cygwin.pm b/cpan/lib/File/Spec/Cygwin.pm index 0712add8..67f056f5 100644 --- a/cpan/lib/File/Spec/Cygwin.pm +++ b/cpan/lib/File/Spec/Cygwin.pm @@ -4,7 +4,8 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '1.1'; +$VERSION = '3.62'; +$VERSION =~ tr/_//d; @ISA = qw(File::Spec::Unix); @@ -39,8 +40,29 @@ and then File::Spec::Unix canonpath() is called on the result. sub canonpath { my($self,$path) = @_; + return unless defined $path; + $path =~ s|\\|/|g; - return $self->SUPER::canonpath($path); + + # Handle network path names beginning with double slash + my $node = ''; + if ( $path =~ s@^(//[^/]+)(?:/|\z)@/@s ) { + $node = $1; + } + return $node . $self->SUPER::canonpath($path); +} + +sub catdir { + my $self = shift; + return unless @_; + + # Don't create something that looks like a //network/path + if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) { + shift; + return $self->SUPER::catdir('', @_); + } + + $self->SUPER::catdir(@_); } =pod @@ -66,22 +88,73 @@ from the following list: $ENV{TMPDIR} /tmp + $ENV{'TMP'} + $ENV{'TEMP'} C:/temp -Since Perl 5.8.0, if running under taint mode, and if the environment +If running under taint mode, and if the environment variables are tainted, they are not used. =cut -my $tmpdir; sub tmpdir { - return $tmpdir if defined $tmpdir; - my $self = shift; - $tmpdir = $self->_tmpdir( $ENV{TMPDIR}, "/tmp", 'C:/temp' ); + my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TMP TEMP'); + return $cached if defined $cached; + $_[0]->_cache_tmpdir( + $_[0]->_tmpdir( + $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp' + ), + qw 'TMPDIR TMP TEMP' + ); +} + +=item case_tolerant + +Override Unix. Cygwin case-tolerance depends on managed mount settings and +as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE, +indicating the case significance when comparing file specifications. +Default: 1 + +=cut + +sub case_tolerant { + return 1 unless $^O eq 'cygwin' + and defined &Cygwin::mount_flags; + + my $drive = shift; + if (! $drive) { + my @flags = split(/,/, Cygwin::mount_flags('/cygwin')); + my $prefix = pop(@flags); + if (! $prefix || $prefix eq 'cygdrive') { + $drive = '/cygdrive/c'; + } elsif ($prefix eq '/') { + $drive = '/c'; + } else { + $drive = "$prefix/c"; + } + } + my $mntopts = Cygwin::mount_flags($drive); + if ($mntopts and ($mntopts =~ /,managed/)) { + return 0; + } + eval { require Win32API::File; } or return 1; + my $osFsType = "\0"x256; + my $osVolName = "\0"x256; + my $ouFsFlags = 0; + Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 ); + if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; } + else { return 1; } } =back +=head1 COPYRIGHT + +Copyright (c) 2004,2007 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. + =cut 1; diff --git a/cpan/lib/File/Spec/Epoc.pm b/cpan/lib/File/Spec/Epoc.pm index 89ca0b99..17e3f54d 100644 --- a/cpan/lib/File/Spec/Epoc.pm +++ b/cpan/lib/File/Spec/Epoc.pm @@ -3,7 +3,8 @@ package File::Spec::Epoc; use strict; use vars qw($VERSION @ISA); -$VERSION = '1.1'; +$VERSION = '3.62'; +$VERSION =~ tr/_//d; require File::Spec::Unix; @ISA = qw(File::Spec::Unix); @@ -19,14 +20,10 @@ File::Spec::Epoc - methods for Epoc file specs =head1 DESCRIPTION See File::Spec::Unix for a documentation of the methods provided -there. This package overrides the implementation of these methods, not +there. This package overrides the implementation of these methods, not the semantics. -This package is still work in progress ;-) - -=head1 AUTHORS - -o.flebbe@gmx.de +This package is still a work in progress. ;-) =cut @@ -41,7 +38,7 @@ sub case_tolerant { =item canonpath() No physical check on the filesystem, but a logical cleanup of a -path. On UNIX eliminated successive slashes and successive "/.". +path. On UNIX eliminated successive slashes and successive "/.". =back @@ -49,6 +46,7 @@ path. On UNIX eliminated successive slashes and successive "/.". sub canonpath { my ($self,$path) = @_; + return unless defined $path; $path =~ s|/+|/|g; # xx////xx -> xx/xx $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx @@ -60,6 +58,17 @@ sub canonpath { =pod +=head1 AUTHOR + +o.flebbe@gmx.de + +=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. + =head1 SEE ALSO See L<File::Spec> and L<File::Spec::Unix>. This package overrides the diff --git a/cpan/lib/File/Spec/Functions.pm b/cpan/lib/File/Spec/Functions.pm index 1c36e8b9..470c7718 100644 --- a/cpan/lib/File/Spec/Functions.pm +++ b/cpan/lib/File/Spec/Functions.pm @@ -5,7 +5,8 @@ use strict; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); -$VERSION = '1.3'; +$VERSION = '3.62'; +$VERSION =~ tr/_//d; require Exporter; @@ -36,10 +37,30 @@ require Exporter; %EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] ); +require File::Spec::Unix; +my %udeps = ( + canonpath => [], + catdir => [qw(canonpath)], + catfile => [qw(canonpath catdir)], + case_tolerant => [], + curdir => [], + devnull => [], + rootdir => [], + updir => [], +); + foreach my $meth (@EXPORT, @EXPORT_OK) { my $sub = File::Spec->can($meth); no strict 'refs'; - *{$meth} = sub {&$sub('File::Spec', @_)}; + if (exists($udeps{$meth}) && $sub == File::Spec::Unix->can($meth) && + !(grep { + File::Spec->can($_) != File::Spec::Unix->can($_) + } @{$udeps{$meth}}) && + defined(&{"File::Spec::Unix::_fn_$meth"})) { + *{$meth} = \&{"File::Spec::Unix::_fn_$meth"}; + } else { + *{$meth} = sub {&$sub('File::Spec', @_)}; + } } @@ -93,7 +114,17 @@ The following functions are exported only by request. All the functions may be imported using the C<:ALL> tag. +=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. + =head1 SEE ALSO File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2, File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker + +=cut + diff --git a/cpan/lib/File/Spec/Mac.pm b/cpan/lib/File/Spec/Mac.pm index 34a7a015..329451fb 100644 --- a/cpan/lib/File/Spec/Mac.pm +++ b/cpan/lib/File/Spec/Mac.pm @@ -4,7 +4,8 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '1.4'; +$VERSION = '3.62'; +$VERSION =~ tr/_//d; @ISA = qw(File::Spec::Unix); @@ -53,7 +54,7 @@ done in MacPerl's environment and helps to distinguish a file path from a directory path. B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the resulting -path is relative by default and I<not> absolute. This descision was made due +path is relative by default and I<not> absolute. This decision was made due to portability reasons. Since C<File::Spec-E<gt>catdir()> returns relative paths on all other operating systems, it will now also follow this convention on Mac OS. Note that this may break some existing scripts. @@ -155,13 +156,16 @@ their Unix counterparts: Unix: Unix->catdir("","") = "/" Unix->catdir("",".") = "/" - Unix->catdir("","..") = "/" # can't go beyond root + Unix->catdir("","..") = "/" # can't go + # beyond root Unix->catdir("",".","..","..","a") = "/a" Mac: - Mac->catdir("","") = rootdir() # (e.g. "HD:") + Mac->catdir("","") = rootdir() # (e.g. "HD:") Mac->catdir("",":") = rootdir() - Mac->catdir("","::") = rootdir() # can't go beyond root - Mac->catdir("",":","::","::","a") = rootdir() . "a:" # (e.g. "HD:a:") + Mac->catdir("","::") = rootdir() # can't go + # beyond root + Mac->catdir("",":","::","::","a") = rootdir() . "a:" + # (e.g. "HD:a:") However, this approach is limited to the first arguments following "root" (again, see C<Unix-E<gt>canonpath()> ). If there are more @@ -272,7 +276,7 @@ by default, but can be forced to be absolute (but avoid this). B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the resulting path is relative by default and I<not> absolute. This -descision was made due to portability reasons. Since +decision was made due to portability reasons. Since C<File::Spec-E<gt>catfile()> returns relative paths on all other operating systems, it will now also follow this convention on Mac OS. Note that this may break some existing scripts. @@ -370,11 +374,10 @@ directory on your startup volume. =cut -my $tmpdir; sub tmpdir { - return $tmpdir if defined $tmpdir; - my $self = shift; - $tmpdir = $self->_tmpdir( $ENV{TMPDIR} ); + my $cached = $_[0]->_cached_tmpdir('TMPDIR'); + return $cached if defined $cached; + $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR} ), 'TMPDIR'); } =item updir @@ -400,10 +403,11 @@ the filename '' is always considered to be absolute. Note that with version E.g. - File::Spec->file_name_is_absolute("a"); # false (relative) - File::Spec->file_name_is_absolute(":a:b:"); # false (relative) - File::Spec->file_name_is_absolute("MacintoshHD:"); # true (absolute) - File::Spec->file_name_is_absolute(""); # true (absolute) + File::Spec->file_name_is_absolute("a"); # false (relative) + File::Spec->file_name_is_absolute(":a:b:"); # false (relative) + File::Spec->file_name_is_absolute("MacintoshHD:"); + # true (absolute) + File::Spec->file_name_is_absolute(""); # true (absolute) =cut @@ -440,7 +444,8 @@ sub path { =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. @@ -531,7 +536,7 @@ sub splitdir { my @result = (); my ($head, $sep, $tail, $volume, $directories); - return ('') if ( (!defined($path)) || ($path eq '') ); + return @result if ( (!defined($path)) || ($path eq '') ); return (':') if ($path eq ':'); ( $volume, $sep, $directories ) = $path =~ m|^((?:[^:]+:)?)(:*)(.*)|s; @@ -740,7 +745,7 @@ sub rel2abs { # Split up paths - # igonore $path's volume + # ignore $path's volume my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ; # ignore $base's file part @@ -764,6 +769,13 @@ sub rel2abs { See the authors list in I<File::Spec>. Mac OS support by Paul Schinder <schinder@pobox.com> and Thomas Wegner <wegner_thomas@yahoo.com>. +=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. + =head1 SEE ALSO See L<File::Spec> and L<File::Spec::Unix>. This package overrides the diff --git a/cpan/lib/File/Spec/OS2.pm b/cpan/lib/File/Spec/OS2.pm index 47dc0a6a..55e6d335 100644 --- a/cpan/lib/File/Spec/OS2.pm +++ b/cpan/lib/File/Spec/OS2.pm @@ -4,7 +4,8 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '1.2'; +$VERSION = '3.62'; +$VERSION =~ tr/_//d; @ISA = qw(File::Spec::Unix); @@ -34,13 +35,13 @@ sub _cwd { return Cwd::sys_cwd(); } -my $tmpdir; sub tmpdir { - return $tmpdir if defined $tmpdir; - my $self = shift; - $tmpdir = $self->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)}, - '/tmp', - '/' ); + my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TEMP TMP'); + return $cached if defined $cached; + my @d = @ENV{qw(TMPDIR TEMP TMP)}; # function call could autovivivy + $_[0]->_cache_tmpdir( + $_[0]->_tmpdir( @d, '/tmp', '/' ), qw 'TMPDIR TEMP TMP' + ); } sub catdir { @@ -56,6 +57,8 @@ sub catdir { sub canonpath { my ($self,$path) = @_; + return unless defined $path; + $path =~ s/^([a-z]:)/\l$1/s; $path =~ s|\\|/|g; $path =~ s|([^/])/+|$1/|g; # xx////xx -> xx/xx @@ -263,4 +266,11 @@ Volumes can be drive letters or UNC sharenames (\\server\share). =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. + =cut 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; diff --git a/cpan/lib/File/Spec/VMS.pm b/cpan/lib/File/Spec/VMS.pm index 362cdaa2..600c49fa 100644 --- a/cpan/lib/File/Spec/VMS.pm +++ b/cpan/lib/File/Spec/VMS.pm @@ -4,7 +4,8 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '1.4'; +$VERSION = '3.62'; +$VERSION =~ tr/_//d; @ISA = qw(File::Spec::Unix); @@ -25,239 +26,238 @@ See File::Spec::Unix for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. -=over 4 - -=item eliminate_macros +The default behavior is to allow either VMS or Unix syntax on input and to +return VMS syntax on output unless Unix syntax has been explicitly requested +via the C<DECC$FILENAME_UNIX_REPORT> CRTL feature. -Expands MM[KS]/Make macros in a text string, using the contents of -identically named elements of C<%$self>, and returns the result -as a file specification in Unix syntax. +=over 4 =cut -sub eliminate_macros { - my($self,$path) = @_; - return '' unless $path; - $self = {} unless ref $self; +# Need to look up the feature settings. The preferred way is to use the +# VMS::Feature module, but that may not be available to dual life modules. - if ($path =~ /\s/) { - return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path; +my $use_feature; +BEGIN { + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $use_feature = 1; } - - my($npath) = unixify($path); - my($complex) = 0; - my($head,$macro,$tail); - - # perform m##g in scalar context so it acts as an iterator - while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { - if ($self->{$2}) { - ($head,$macro,$tail) = ($1,$2,$3); - if (ref $self->{$macro}) { - if (ref $self->{$macro} eq 'ARRAY') { - $macro = join ' ', @{$self->{$macro}}; - } - else { - print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), - "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; - $macro = "\cB$macro\cB"; - $complex = 1; - } - } - else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; } - $npath = "$head$macro$tail"; - } - } - if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; } - $npath; } -=item fixpath - -Catchall routine to clean up problem MM[SK]/Make macros. Expands macros -in any directory specification, in order to avoid juxtaposing two -VMS-syntax directories when MM[SK] is run. Also expands expressions which -are all macro, so that we can tell how long the expansion is, and avoid -overrunning DCL's command buffer when MM[KS] is running. - -If optional second argument has a TRUE value, then the return string is -a VMS-syntax directory specification, if it is FALSE, the return string -is a VMS-syntax file specification, and if it is not specified, fixpath() -checks to see whether it matches the name of a directory in the current -default directory, and returns a directory or file specification accordingly. - -=cut - -sub fixpath { - my($self,$path,$force_path) = @_; - return '' unless $path; - $self = bless {} unless ref $self; - my($fixedpath,$prefix,$name); - - if ($path =~ /\s/) { - return join ' ', - map { $self->fixpath($_,$force_path) } - split /\s+/, $path; - } - - if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { - if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) { - $fixedpath = vmspath($self->eliminate_macros($path)); - } - else { - $fixedpath = vmsify($self->eliminate_macros($path)); - } - } - elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) { - my($vmspre) = $self->eliminate_macros("\$($prefix)"); - # is it a dir or just a name? - $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : ''; - $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; - $fixedpath = vmspath($fixedpath) if $force_path; - } - else { - $fixedpath = $path; - $fixedpath = vmspath($fixedpath) if $force_path; - } - # No hints, so we try to guess - if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { - $fixedpath = vmspath($fixedpath) if -d $fixedpath; +# Need to look up the UNIX report mode. This may become a dynamic mode +# in the future. +sub _unix_rpt { + my $unix_rpt; + if ($use_feature) { + $unix_rpt = VMS::Feature::current("filename_unix_report"); + } else { + my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; } - - # Trim off root dirname if it's had other dirs inserted in front of it. - $fixedpath =~ s/\.000000([\]>])/$1/; - # Special case for VMS absolute directory specs: these will have had device - # prepended during trip through Unix syntax in eliminate_macros(), since - # Unix syntax has no way to express "absolute from the top of this device's - # directory tree". - if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; } - $fixedpath; + return $unix_rpt; } -=back - -=head2 Methods always loaded - -=over 4 - =item canonpath (override) -Removes redundant portions of file specifications according to VMS syntax. +Removes redundant portions of file specifications and returns results +in native syntax unless Unix filename reporting has been enabled. =cut + sub canonpath { my($self,$path) = @_; - if ($path =~ m|/|) { # Fake Unix + return undef unless defined $path; + + my $unix_rpt = $self->_unix_rpt; + + if ($path =~ m|/|) { my $pathify = $path =~ m|/\Z(?!\n)|; $path = $self->SUPER::canonpath($path); - if ($pathify) { return vmspath($path); } - else { return vmsify($path); } - } - else { - $path =~ s/([\[<])000000\./$1/g; # [000000.foo ==> [foo - $path =~ s/([^-]+)\.(\]\[|><)?000000([\]\>])/$1$3/g; # foo.000000] ==> foo] - $path =~ s-\]\[--g; $path =~ s/><//g; # foo.][bar ==> foo.bar - 1 while $path =~ s{([\[<-])\.-}{$1-}; # [.-.- ==> [-- - $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/; # bar.foo.-] ==> bar] - $path =~ s/([\[<])(-+)/$1 . "\cx" x length($2)/e; # encode leading '-'s - $path =~ s/([\[<\.])([^\[<\.\cx]+)\.-\.?/$1/g; # bar.-.foo ==> foo - $path =~ s/([\[<])(\cx+)/$1 . '-' x length($2)/e; # then decode - $path =~ s/^[\[<\]>]{2}//; # []foo ==> foo - return $path; + + return $path if $unix_rpt; + $path = $pathify ? vmspath($path) : vmsify($path); } + + $path =~ s/(?<!\^)</[/; # < and > ==> [ and ] + $path =~ s/(?<!\^)>/]/; + $path =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][ + $path =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [ + $path =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [ + $path =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ] + $path =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar + 1 while ($path =~ s/(?<!\^)([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/); + # That loop does the following + # with any amount of dashes: + # .-.-. ==> .--. + # [-.-. ==> [--. + # .-.-] ==> .--] + # [-.-] ==> [--] + 1 while ($path =~ s/(?<!\^)([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/); + # That loop does the following + # with any amount (minimum 2) + # of dashes: + # .foo.--. ==> .-. + # .foo.--] ==> .-] + # [foo.--. ==> [-. + # [foo.--] ==> [-] + # + # And then, the remaining cases + $path =~ s/(?<!\^)\[\.-/[-/; # [.- ==> [- + $path =~ s/(?<!\^)\.[^\]\.]+\.-\./\./g; # .foo.-. ==> . + $path =~ s/(?<!\^)\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [ + $path =~ s/(?<!\^)\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ] + # [foo.-] ==> [000000] + $path =~ s/(?<!\^)\[[^\]\.]+\.-\]/\[000000\]/g; + # [] ==> + $path =~ s/(?<!\^)\[\]// unless $path eq '[]'; + return $unix_rpt ? unixify($path) : $path; } -=item catdir +=item catdir (override) Concatenates a list of file specifications, and returns the result as a -VMS-syntax directory specification. No check is made for "impossible" -cases (e.g. elements other than the first being absolute filespecs). +native directory specification unless the Unix filename reporting feature +has been enabled. No check is made for "impossible" cases (e.g. elements +other than the first being absolute filespecs). =cut sub catdir { - my ($self,@dirs) = @_; - my $dir = pop @dirs; - @dirs = grep($_,@dirs); + my $self = shift; + my $dir = pop; + + my $unix_rpt = $self->_unix_rpt; + + my @dirs = grep {defined() && length()} @_; + my $rslt; if (@dirs) { my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); my ($spath,$sdir) = ($path,$dir); - $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//; - $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s; - $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); - - # Special case for VMS absolute directory specs: these will have had device - # prepended during trip through Unix syntax in eliminate_macros(), since - # Unix syntax has no way to express "absolute from the top of this device's - # directory tree". + $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i; + + if ($unix_rpt) { + $spath = unixify($spath) unless $spath =~ m#/#; + $sdir= unixify($sdir) unless $sdir =~ m#/#; + return $self->SUPER::catdir($spath, $sdir) + } + + $rslt = vmspath( unixify($spath) . '/' . unixify($sdir)); + + # Special case for VMS absolute directory specs: these will have + # had device prepended during trip through Unix syntax in + # eliminate_macros(), since Unix syntax has no way to express + # "absolute from the top of this device's directory tree". if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; } - } - else { - if (not defined $dir or not length $dir) { $rslt = ''; } - elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; } - else { $rslt = vmspath($dir); } + + } else { + # Single directory. Return an empty string on null input; otherwise + # just return a canonical path. + + if (not defined $dir or not length $dir) { + $rslt = ''; + } else { + $rslt = $unix_rpt ? $dir : vmspath($dir); + } } return $self->canonpath($rslt); } -=item catfile +=item catfile (override) -Concatenates a list of file specifications, and returns the result as a -VMS-syntax file specification. +Concatenates a list of directory specifications with a filename specification +to build a path. =cut sub catfile { - my ($self,@files) = @_; - my $file = $self->canonpath(pop @files); - @files = grep($_,@files); + my $self = shift; + my $tfile = pop(); + my $file = $self->canonpath($tfile); + my @files = grep {defined() && length()} @_; + + my $unix_rpt = $self->_unix_rpt; + my $rslt; if (@files) { my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); my $spath = $path; - $spath =~ s/\.dir\Z(?!\n)//; - if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) { + + # Something building a VMS path in pieces may try to pass a + # directory name in filename format, so normalize it. + $spath =~ s/\.dir\Z(?!\n)//i; + + # If the spath ends with a directory delimiter and the file is bare, + # then just concatenate them. + if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) { $rslt = "$spath$file"; - } - else { - $rslt = $self->eliminate_macros($spath); - $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); + } else { + $rslt = unixify($spath); + $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file); + $rslt = vmsify($rslt) unless $unix_rpt; } } - else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; } - return $self->canonpath($rslt); + else { + # Only passed a single file? + my $xfile = (defined($file) && length($file)) ? $file : ''; + + $rslt = $unix_rpt ? $xfile : vmsify($xfile); + } + return $self->canonpath($rslt) unless $unix_rpt; + + # In Unix report mode, do not strip off redundant path information. + return $rslt; } =item curdir (override) -Returns a string representation of the current directory: '[]' +Returns a string representation of the current directory: '[]' or '.' =cut sub curdir { + my $self = shift @_; + return '.' if ($self->_unix_rpt); return '[]'; } =item devnull (override) -Returns a string representation of the null device: '_NLA0:' +Returns a string representation of the null device: '_NLA0:' or '/dev/null' =cut sub devnull { + my $self = shift @_; + return '/dev/null' if ($self->_unix_rpt); return "_NLA0:"; } =item rootdir (override) Returns a string representation of the root directory: 'SYS$DISK:[000000]' +or '/' =cut sub rootdir { + my $self = shift @_; + if ($self->_unix_rpt) { + # Root may exist, try it first. + my $try = '/'; + my ($dev1, $ino1) = stat('/'); + my ($dev2, $ino2) = stat('.'); + + # Perl falls back to '.' if it can not determine '/' + if (($dev1 != $dev2) || ($ino1 != $ino2)) { + return $try; + } + # Fall back to UNIX format sys$disk. + return '/sys$disk/'; + } return 'SYS$DISK:[000000]'; } @@ -266,28 +266,37 @@ sub rootdir { Returns a string representation of the first writable directory from the following list or '' if none are writable: + /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled. sys$scratch: $ENV{TMPDIR} -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; sub tmpdir { + my $self = shift @_; + my $tmpdir = $self->_cached_tmpdir('TMPDIR'); return $tmpdir if defined $tmpdir; - my $self = shift; - $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); + if ($self->_unix_rpt) { + $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR}); + } + else { + $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); + } + $self->_cache_tmpdir($tmpdir, 'TMPDIR'); } =item updir (override) -Returns a string representation of the parent directory: '[-]' +Returns a string representation of the parent directory: '[-]' or '..' =cut sub updir { + my $self = shift @_; + return '..' if ($self->_unix_rpt); return '[-]'; } @@ -326,34 +335,71 @@ sub file_name_is_absolute { $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file}; return scalar($file =~ m!^/!s || $file =~ m![<\[][^.\-\]>]! || - $file =~ /:[^<\[]/); + $file =~ /^[A-Za-z0-9_\$\-\~]+(?<!\^):/); } =item splitpath (override) -Splits using VMS syntax. + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, + $no_file ); + +Passing a true value for C<$no_file> indicates that the path being +split only contains directory components, even on systems where you +can usually (when not supporting a foreign syntax) tell the difference +between directories and files at a glance. =cut sub splitpath { - my($self,$path) = @_; - my($dev,$dir,$file) = ('','',''); - - vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s; - return ($1 || '',$2 || '',$3); + my($self,$path, $nofile) = @_; + my($dev,$dir,$file) = ('','',''); + my $vmsify_path = vmsify($path); + + if ( $nofile ) { + #vmsify('d1/d2/d3') returns '[.d1.d2]d3' + #vmsify('/d1/d2/d3') returns 'd1:[d2]d3' + if( $vmsify_path =~ /(.*)\](.+)/ ){ + $vmsify_path = $1.'.'.$2.']'; + } + $vmsify_path =~ /(.+:)?(.*)/s; + $dir = defined $2 ? $2 : ''; # dir can be '0' + return ($1 || '',$dir,$file); + } + else { + $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s; + return ($1 || '',$2 || '',$3); + } } =item splitdir (override) -Split dirspec using VMS syntax. +Split a directory specification into the components. =cut sub splitdir { my($self,$dirspec) = @_; - $dirspec =~ s/\]\[//g; $dirspec =~ s/\-\-/-.-/g; - $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal - my(@dirs) = split('\.', vmspath($dirspec)); + my @dirs = (); + return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) ); + + $dirspec =~ s/(?<!\^)</[/; # < and > ==> [ and ] + $dirspec =~ s/(?<!\^)>/]/; + $dirspec =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][ + $dirspec =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [ + $dirspec =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [ + $dirspec =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ] + $dirspec =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar + while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {} + # That loop does the following + # with any amount of dashes: + # .--. ==> .-.-. + # [--. ==> [-.-. + # .--] ==> .-.-] + # [--] ==> [-.-] + $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal + $dirspec =~ s/^(\[|<)\./$1/; + @dirs = split /(?<!\^)\./, vmspath($dirspec); $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s; @dirs; } @@ -361,7 +407,7 @@ sub splitdir { =item catpath (override) -Construct a complete filespec using VMS syntax +Construct a complete filespec. =cut @@ -373,30 +419,35 @@ sub catpath { $dev = $dir_volume unless length $dev; $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir; - if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; } + if ($dev =~ m|^(?<!\^)/+([^/]+)|) { $dev = "$1:"; } else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; } if (length($dev) or length($dir)) { - $dir = "[$dir]" unless $dir =~ /[\[<\/]/; - $dir = vmspath($dir); + $dir = "[$dir]" unless $dir =~ /(?<!\^)[\[<\/]/; + $dir = vmspath($dir); } + $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>'); "$dev$dir$file"; } =item abs2rel (override) -Use VMS syntax when converting filespecs. +Attempt to convert an absolute file specification to a relative specification. =cut sub abs2rel { my $self = shift; return vmspath(File::Spec::Unix::abs2rel( $self, @_ )) - if grep m{/}, @_; + if ((grep m{/}, @_) && !(grep m{(?<!\^)[\[<:]}, @_)); my($path,$base) = @_; $base = $self->_cwd() unless defined $base and length $base; - for ($path, $base) { $_ = $self->canonpath($_) } + # If there is no device or directory syntax on $base, make sure it + # is treated as a directory. + $base = VMS::Filespec::vmspath($base) unless $base =~ m{(?<!\^)[\[<:]}; + + for ($path, $base) { $_ = $self->rel2abs($_) } # Are we even starting $path on the same (node::)device as $base? Note that # logical paths or nodename differences may be on the "same device" @@ -412,12 +463,12 @@ sub abs2rel { my ($base_volume, $base_directories, $base_file) = $self->splitpath($base); return $path unless lc($path_volume) eq lc($base_volume); - for ($path, $base) { $_ = $self->rel2abs($_) } - # Now, remove all leading components that are the same my @pathchunks = $self->splitdir( $path_directories ); + my $pathchunks = @pathchunks; unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000'; my @basechunks = $self->splitdir( $base_directories ); + my $basechunks = @basechunks; unshift(@basechunks,'000000') unless $basechunks[0] eq '000000'; while ( @pathchunks && @@ -430,23 +481,34 @@ sub abs2rel { # @basechunks now contains the directories to climb out of, # @pathchunks now has the directories to descend in to. - $path_directories = join '.', ('-' x @basechunks, @pathchunks) ; + if ((@basechunks > 0) || ($basechunks != $pathchunks)) { + $path_directories = join '.', ('-' x @basechunks, @pathchunks) ; + } + else { + $path_directories = join '.', @pathchunks; + } + $path_directories = '['.$path_directories.']'; return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; } =item rel2abs (override) -Use VMS syntax when converting filespecs. +Return an absolute file specification from a relative one. =cut sub rel2abs { my $self = shift ; - return vmspath(File::Spec::Unix::rel2abs( $self, @_ )) - if ( join( '', @_ ) =~ m{/} ) ; - my ($path,$base ) = @_; + return undef unless defined $path; + if ($path =~ m/\//) { + $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about + ? vmspath($path) # whether it's a directory + : vmsify($path) ); + } + $base = vmspath($base) if defined $base && $base =~ m/\//; + # Clean up and split up $path if ( ! $self->file_name_is_absolute( $path ) ) { # Figure out the effective $base and clean it up. @@ -486,13 +548,20 @@ sub rel2abs { =back +=head1 COPYRIGHT + +Copyright (c) 2004-14 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. + =head1 SEE ALSO See L<File::Spec> and L<File::Spec::Unix>. This package overrides the implementation of these methods, not the semantics. An explanation of VMS file specs can be found at -L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">. +L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>. =cut diff --git a/cpan/lib/File/Spec/Win32.pm b/cpan/lib/File/Spec/Win32.pm index 1a91b95a..6df7ee87 100644 --- a/cpan/lib/File/Spec/Win32.pm +++ b/cpan/lib/File/Spec/Win32.pm @@ -5,10 +5,17 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '1.4'; +$VERSION = '3.62'; +$VERSION =~ tr/_//d; @ISA = qw(File::Spec::Unix); +# Some regexes we use for path splitting +my $DRIVE_RX = '[a-zA-Z]:'; +my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+'; +my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)"; + + =head1 NAME File::Spec::Win32 - methods for Win32 file specs @@ -35,6 +42,9 @@ sub devnull { return "nul"; } +sub rootdir { '\\' } + + =item tmpdir Returns a string representation of the first existing directory @@ -44,36 +54,70 @@ from the following list: $ENV{TEMP} $ENV{TMP} SYS:/temp + C:\system\temp C:/temp /tmp / -The SYS:/temp is preferred in Novell NetWare (the File::Spec::Win32 -is used also for NetWare). +The SYS:/temp is preferred in Novell NetWare and the C:\system\temp +for Symbian (the File::Spec::Win32 is used also for those platforms). -Since Perl 5.8.0, if running under taint mode, and if the environment +If running under taint mode, and if the environment variables are tainted, they are not used. =cut -my $tmpdir; sub tmpdir { + my $tmpdir = $_[0]->_cached_tmpdir(qw(TMPDIR TEMP TMP)); return $tmpdir if defined $tmpdir; - my $self = shift; - $tmpdir = $self->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)}, + $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ), 'SYS:/temp', + 'C:\system\temp', 'C:/temp', '/tmp', '/' ); + $_[0]->_cache_tmpdir($tmpdir, qw(TMPDIR TEMP TMP)); } +=item case_tolerant + +MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE, +indicating the case significance when comparing file specifications. +Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem. +See http://cygwin.com/ml/cygwin/2007-07/msg00891.html +Default: 1 + +=cut + sub case_tolerant { - return 1; + eval { require Win32API::File; } or return 1; + my $drive = shift || "C:"; + my $osFsType = "\0"x256; + my $osVolName = "\0"x256; + my $ouFsFlags = 0; + Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 ); + if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; } + else { return 1; } } +=item file_name_is_absolute + +As of right now, this returns 2 if the path is absolute with a +volume, 1 if it's absolute with no volume, 0 otherwise. + +=cut + sub file_name_is_absolute { + my ($self,$file) = @_; - return scalar($file =~ m{^([a-z]:)?[\\/]}is); + + if ($file =~ m{^($VOL_RX)}o) { + my $vol = $1; + return ($vol =~ m{^$UNC_RX}o ? 2 + : $file =~ m{^$DRIVE_RX[\\/]}o ? 2 + : 0); + } + return $file =~ m{^[\\/]} ? 1 : 0; } =item catfile @@ -84,29 +128,44 @@ complete path ending with a filename =cut sub catfile { - my $self = shift; - my $file = $self->canonpath(pop @_); - return $file unless @_; - my $dir = $self->catdir(@_); - $dir .= "\\" unless substr($dir,-1) eq "\\"; - return $dir.$file; + shift; + + # Legacy / compatibility support + # + shift, return _canon_cat( "/", @_ ) + if $_[0] eq ""; + + # Compatibility with File::Spec <= 3.26: + # catfile('A:', 'foo') should return 'A:\foo'. + return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) + if $_[0] =~ m{^$DRIVE_RX\z}o; + + return _canon_cat( @_ ); } sub catdir { - my $self = shift; - my @args = @_; - foreach (@args) { - tr[/][\\]; - # append a backslash to each argument unless it has one there - $_ .= "\\" unless m{\\$}; - } - return $self->canonpath(join('', @args)); + shift; + + # Legacy / compatibility support + # + return "" + unless @_; + shift, return _canon_cat( "/", @_ ) + if $_[0] eq ""; + + # Compatibility with File::Spec <= 3.26: + # catdir('A:', 'foo') should return 'A:\foo'. + return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) + if $_[0] =~ m{^$DRIVE_RX\z}o; + + return _canon_cat( @_ ); } sub path { - my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'}; - my @path = split(';',$path); - foreach (@path) { $_ = '.' if $_ eq '' } + my @path = split(';', $ENV{PATH}); + s/"//g for @path; + @path = grep length, @path; + unshift(@path, "."); return @path; } @@ -122,53 +181,17 @@ On Win32 makes =cut sub canonpath { - my ($self,$path) = @_; - my $orig_path = $path; - $path =~ s/^([a-z]:)/\u$1/s; - $path =~ s|/|\\|g; - $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx - $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx - $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx - $path =~ s|\\\Z(?!\n)|| - unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx - # xx1/xx2/xx3/../../xx -> xx1/xx - $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up - $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up - return $path if $path =~ m|^\.\.|; # skip relative paths - return $path unless $path =~ /\.\./; # too few .'s to cleanup - return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup - $path =~ s{^\\\.\.$}{\\}; # \.. -> \ - 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx - - my ($vol,$dirs,$file) = $self->splitpath($path); - my @dirs = $self->splitdir($dirs); - my (@base_dirs, @path_dirs); - my $dest = \@base_dirs; - for my $dir (@dirs){ - $dest = \@path_dirs if $dir eq $self->updir; - push @$dest, $dir; - } - # for each .. in @path_dirs pop one item from - # @base_dirs - while (my $dir = shift @path_dirs){ - unless ($dir eq $self->updir){ - unshift @path_dirs, $dir; - last; - } - pop @base_dirs; - } - $path = $self->catpath( - $vol, - $self->catdir(@base_dirs, @path_dirs), - $file - ); - return $path; + # Legacy / compatibility support + # + return $_[1] if !defined($_[1]) or $_[1] eq ''; + return _canon_cat( $_[1] ); } =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 ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, + $no_file ); Splits a path into volume, directory, and filename portions. Assumes that the last file is a path unless the path ends in '\\', '\\.', '\\..' @@ -189,21 +212,16 @@ sub splitpath { my ($volume,$directory,$file) = ('','',''); if ( $nofile ) { $path =~ - m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) - (.*) - }xs; + m{^ ( $VOL_RX ? ) (.*) }sox; $volume = $1; $directory = $2; } else { $path =~ - m{^ ( (?: [a-zA-Z]: | - (?:\\\\|//)[^\\/]+[\\/][^\\/]+ - )? - ) - ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? ) + m{^ ( $VOL_RX ? ) + ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? ) (.*) - }xs; + }sox; $volume = $1; $directory = $2; $file = $3; @@ -215,7 +233,7 @@ sub splitpath { =item splitdir -The opposite of L<catdir()|File::Spec/catdir()>. +The opposite of L<catdir()|File::Spec/catdir>. @dirs = File::Spec->splitdir( $directories ); @@ -270,8 +288,9 @@ sub catpath { # If it's UNC, make sure the glue separator is there, reusing # whatever separator is first in the $volume - $volume .= $1 - if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s && + my $v; + $volume .= $v + if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) && $directory =~ m@^[^\\/]@s ) ; @@ -293,69 +312,47 @@ sub catpath { return $volume ; } +sub _same { + lc($_[1]) eq lc($_[2]); +} -sub abs2rel { - my($self,$path,$base) = @_; - $base = $self->_cwd() unless defined $base and length $base; - - for ($path, $base) { $_ = $self->canonpath($_) } - - 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; - - for ($path, $base) { $_ = $self->rel2abs($_) } +sub rel2abs { + my ($self,$path,$base ) = @_; - my $path_directories = ($self->splitpath($path, 1))[1]; - my $base_directories = ($self->splitpath($base, 1))[1]; + my $is_abs = $self->file_name_is_absolute($path); - # Now, remove all leading components that are the same - my @pathchunks = $self->splitdir( $path_directories ); - my @basechunks = $self->splitdir( $base_directories ); + # Check for volume (should probably document the '2' thing...) + return $self->canonpath( $path ) if $is_abs == 2; - while ( @pathchunks && - @basechunks && - lc( $pathchunks[0] ) eq lc( $basechunks[0] ) - ) { - shift @pathchunks ; - shift @basechunks ; + if ($is_abs) { + # It's missing a volume, add one + my $vol = ($self->splitpath( $self->_cwd() ))[0]; + return $self->canonpath( $vol . $path ); } - my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks ); - - return $self->canonpath( $self->catpath('', $result_dirs, '') ); -} + if ( !defined( $base ) || $base eq '' ) { + require Cwd ; + $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ; + $base = $self->_cwd() unless defined $base ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + my ( $path_directories, $path_file ) = + ($self->splitpath( $path, 1 ))[1,2] ; -sub rel2abs { - my ($self,$path,$base ) = @_; + my ( $base_volume, $base_directories ) = + $self->splitpath( $base, 1 ) ; - if ( ! $self->file_name_is_absolute( $path ) ) { - - if ( !defined( $base ) || $base eq '' ) { - $base = $self->_cwd() ; - } - elsif ( ! $self->file_name_is_absolute( $base ) ) { - $base = $self->rel2abs( $base ) ; - } - else { - $base = $self->canonpath( $base ) ; - } - - my ( $path_directories, $path_file ) = - ($self->splitpath( $path, 1 ))[1,2] ; - - my ( $base_volume, $base_directories ) = - $self->splitpath( $base, 1 ) ; - - $path = $self->catpath( - $base_volume, - $self->catdir( $base_directories, $path_directories ), - $path_file - ) ; - } + $path = $self->catpath( + $base_volume, + $self->catdir( $base_directories, $path_directories ), + $path_file + ) ; return $self->canonpath( $path ) ; } @@ -366,6 +363,13 @@ sub rel2abs { Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32. +=head1 COPYRIGHT + +Copyright (c) 2004,2007 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. + =head1 SEE ALSO See L<File::Spec> and L<File::Spec::Unix>. This package overrides the @@ -373,4 +377,70 @@ implementation of these methods, not the semantics. =cut + +sub _canon_cat # @path -> path +{ + my ($first, @rest) = @_; + + my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter + ? ucfirst( $1 ).( $2 ? "\\" : "" ) + : $first =~ s{ \A (?:\\\\|//) ([^\\/]+) + (?: [\\/] ([^\\/]+) )? + [\\/]? }{}xs # UNC volume + ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\" + : $first =~ s{ \A [\\/] }{}x # root dir + ? "\\" + : ""; + my $path = join "\\", $first, @rest; + + $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy + + # xx/././yy --> xx/yy + $path =~ s{(?: + (?:\A|\\) # at begin or after a slash + \. + (?:\\\.)* # and more + (?:\\|\z) # at end or followed by slash + )+ # performance boost -- I do not know why + }{\\}gx; + + # XXX I do not know whether more dots are supported by the OS supporting + # this ... annotation (NetWare or symbian but not MSWin32). + # Then .... could easily become ../../.. etc: + # Replace \.\.\. by (\.\.\.+) and substitute with + # { $1 . ".." . "\\.." x (length($2)-2) }gex + # ... --> ../.. + $path =~ s{ (\A|\\) # at begin or after a slash + \.\.\. + (?=\\|\z) # at end or followed by slash + }{$1..\\..}gx; + # xx\yy\..\zz --> xx\zz + while ( $path =~ s{(?: + (?:\A|\\) # at begin or after a slash + [^\\]+ # rip this 'yy' off + \\\.\. + (?<!\A\.\.\\\.\.) # do *not* replace ^..\.. + (?<!\\\.\.\\\.\.) # do *not* replace \..\.. + (?:\\|\z) # at end or followed by slash + )+ # performance boost -- I do not know why + }{\\}sx ) {} + + $path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root + $path =~ s#\\\z##; # xx\ --> xx + + if ( $volume =~ m#\\\z# ) + { # <vol>\.. --> <vol>\ + $path =~ s{ \A # at begin + \.\. + (?:\\\.\.)* # and more + (?:\\|\z) # at end or followed by slash + }{}x; + + return $1 # \\HOST\SHARE\ --> \\HOST\SHARE + if $path eq "" + and $volume =~ m#\A(\\\\.*)\\\z#s; + } + return $path ne "" || $volume ? $volume.$path : "."; +} + 1; |