From: Steve Peters Date: Wed, 23 Jan 2008 04:12:37 +0000 (+0000) Subject: Upgrade to PathTools-3.27 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bf7c0a3d502aa1d17e29d2ca8b76bc8a32c9d393;p=p5sagit%2Fp5-mst-13.2.git Upgrade to PathTools-3.27 p4raw-id: //depot/perl@33042 --- diff --git a/ext/Cwd/Cwd.xs b/ext/Cwd/Cwd.xs index 4958bd2..4864ba1 100644 --- a/ext/Cwd/Cwd.xs +++ b/ext/Cwd/Cwd.xs @@ -2,7 +2,8 @@ #include "perl.h" #include "XSUB.h" #ifndef NO_PPPORT_H -# define NEED_sv_2pv_nolen +# define NEED_my_strlcpy +# define NEED_my_strlcat # include "ppport.h" #endif @@ -10,9 +11,8 @@ # include #endif -/* The realpath() implementation from OpenBSD 2.9 (realpath.c 1.4) +/* The realpath() implementation from OpenBSD 3.9 to 4.2 (realpath.c 1.13) * Renamed here to bsd_realpath() to avoid library conflicts. - * --jhi 2000-06-20 */ /* See @@ -22,11 +22,7 @@ */ /* - * Copyright (c) 1994 - * The Regents of the University of California. All rights reserved. - * - * This code is derived from software contributed to Berkeley by - * Jan-Simon Pendry. + * Copyright (c) 2003 Constantin S. Svintsoff * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions @@ -36,14 +32,14 @@ * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. - * 3. Neither the name of the University nor the names of its contributors - * may be used to endorse or promote products derived from this software - * without specific prior written permission. + * 3. The names of the authors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. * - * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) @@ -53,10 +49,6 @@ * SUCH DAMAGE. */ -#if defined(LIBC_SCCS) && !defined(lint) -static char *rcsid = "$OpenBSD: realpath.c,v 1.4 1998/05/18 09:55:19 deraadt Exp $"; -#endif /* LIBC_SCCS and not lint */ - /* OpenBSD system #includes removed since the Perl ones should do. --jhi */ #ifndef MAXSYMLINKS @@ -64,7 +56,7 @@ static char *rcsid = "$OpenBSD: realpath.c,v 1.4 1998/05/18 09:55:19 deraadt Exp #endif /* - * char *realpath(const char *path, char resolved_path[MAXPATHLEN]); + * char *realpath(const char *path, char resolved[MAXPATHLEN]); * * Find the real name of path, by removing all ".", ".." and symlink * components. Returns (resolved) on success, or (NULL) on failure, diff --git a/ext/Cwd/t/cwd.t b/ext/Cwd/t/cwd.t index 148682a..3be500a 100644 --- a/ext/Cwd/t/cwd.t +++ b/ext/Cwd/t/cwd.t @@ -135,16 +135,11 @@ foreach my $func (qw(cwd getcwd fastcwd fastgetcwd)) { # Cwd::chdir should also update $ENV{PWD} dir_ends_with( $ENV{PWD}, $Test_Dir, 'Cwd::chdir() updates $ENV{PWD}' ); my $updir = File::Spec->updir; -Cwd::chdir $updir; -print "#$ENV{PWD}\n"; -Cwd::chdir $updir; -print "#$ENV{PWD}\n"; -Cwd::chdir $updir; -print "#$ENV{PWD}\n"; -Cwd::chdir $updir; -print "#$ENV{PWD}\n"; -Cwd::chdir $updir; -print "#$ENV{PWD}\n"; + +for (1..@test_dirs) { + Cwd::chdir $updir; + print "#$ENV{PWD}\n"; +} rmtree($test_dirs[0], 0, 0); diff --git a/lib/Cwd.pm b/lib/Cwd.pm index b273464..0896327 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -171,7 +171,7 @@ use strict; use Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); -$VERSION = '3.2501'; +$VERSION = '3.27'; @ISA = qw/ Exporter /; @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); @@ -540,8 +540,8 @@ sub _perl_abs_path local *PARENT; unless (opendir(PARENT, $dotdots)) { - _carp("opendir($dotdots): $!"); - return ''; + # probably a permissions issue. Try the native command. + return File::Spec->rel2abs( $start, _backtick_pwd() ); } unless (@cst = stat($dotdots)) { @@ -653,6 +653,25 @@ sub _vms_abs_path { return _vms_abs_path($link_target); } + if (defined &VMS::Filespec::vms_realpath) { + my $path = $_[0]; + if ($path =~ m#(?<=\^)/# ) { + # Unix format + return VMS::Filespec::vms_realpath($path); + } + + # VMS format + + my $new_path = VMS::Filespec::vms_realname($path); + + # Perl expects directories to be in directory format + $new_path = VMS::Filespec::pathify($new_path) if -d $path; + return $new_path; + } + + # Fallback to older algorithm if correct ones are not + # available. + # may need to turn foo.dir into [.foo] my $pathified = VMS::Filespec::pathify($path); $path = $pathified if defined $pathified; diff --git a/lib/File/Spec.pm b/lib/File/Spec.pm index cc3f172..3a83b99 100644 --- a/lib/File/Spec.pm +++ b/lib/File/Spec.pm @@ -3,7 +3,7 @@ package File::Spec; use strict; use vars qw(@ISA $VERSION); -$VERSION = '3.2501'; +$VERSION = '3.27'; $VERSION = eval $VERSION; my %module = (MacOS => 'Mac', diff --git a/lib/File/Spec/Cygwin.pm b/lib/File/Spec/Cygwin.pm index aa89563..df2904f 100644 --- a/lib/File/Spec/Cygwin.pm +++ b/lib/File/Spec/Cygwin.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.2501'; +$VERSION = '3.27'; @ISA = qw(File::Spec::Unix); @@ -39,6 +39,8 @@ and then File::Spec::Unix canonpath() is called on the result. sub canonpath { my($self,$path) = @_; + return unless defined $path; + $path =~ s|\\|/|g; # Handle network path names beginning with double slash @@ -51,6 +53,7 @@ sub canonpath { 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 '\\')) { @@ -109,9 +112,9 @@ Default: 1 =cut sub case_tolerant () { - if ($^O ne 'cygwin') { - return 1; - } + return 1 unless $^O eq 'cygwin' + and defined &Cygwin::mount_flags; + my $drive = shift; if (! $drive) { my @flags = split(/,/, Cygwin::mount_flags('/cygwin')); diff --git a/lib/File/Spec/Epoc.pm b/lib/File/Spec/Epoc.pm index 2fb26be..67dd04b 100644 --- a/lib/File/Spec/Epoc.pm +++ b/lib/File/Spec/Epoc.pm @@ -3,7 +3,7 @@ package File::Spec::Epoc; use strict; use vars qw($VERSION @ISA); -$VERSION = '3.2501'; +$VERSION = '3.27'; require File::Spec::Unix; @ISA = qw(File::Spec::Unix); @@ -45,6 +45,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 diff --git a/lib/File/Spec/Functions.pm b/lib/File/Spec/Functions.pm index 99894dd..1f95a50 100644 --- a/lib/File/Spec/Functions.pm +++ b/lib/File/Spec/Functions.pm @@ -5,7 +5,7 @@ use strict; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); -$VERSION = '3.2501'; +$VERSION = '3.27'; require Exporter; diff --git a/lib/File/Spec/Mac.pm b/lib/File/Spec/Mac.pm index fcf2616..4122c10 100644 --- a/lib/File/Spec/Mac.pm +++ b/lib/File/Spec/Mac.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.2501'; +$VERSION = '3.27'; @ISA = qw(File::Spec::Unix); @@ -530,7 +530,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; diff --git a/lib/File/Spec/OS2.pm b/lib/File/Spec/OS2.pm index 948ccb2..66a2e33 100644 --- a/lib/File/Spec/OS2.pm +++ b/lib/File/Spec/OS2.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.2501'; +$VERSION = '3.27'; @ISA = qw(File::Spec::Unix); @@ -54,6 +54,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 diff --git a/lib/File/Spec/Unix.pm b/lib/File/Spec/Unix.pm index 9985f34..0fb4943 100644 --- a/lib/File/Spec/Unix.pm +++ b/lib/File/Spec/Unix.pm @@ -3,7 +3,7 @@ package File::Spec::Unix; use strict; use vars qw($VERSION); -$VERSION = '3.2501'; +$VERSION = '3.27'; =head1 NAME @@ -41,6 +41,7 @@ actually traverse the filesystem cleaning up paths like this. sub canonpath { my ($self,$path) = @_; + return unless defined $path; # Handle POSIX-style node names beginning with double slash (qnx, nto) # (POSIX says: "a pathname that begins with two successive slashes diff --git a/lib/File/Spec/VMS.pm b/lib/File/Spec/VMS.pm index 35755ce..b038b66 100644 --- a/lib/File/Spec/VMS.pm +++ b/lib/File/Spec/VMS.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.2501'; +$VERSION = '3.27'; @ISA = qw(File::Spec::Unix); diff --git a/lib/File/Spec/Win32.pm b/lib/File/Spec/Win32.pm index 6e9abc8..98f2ea2 100644 --- a/lib/File/Spec/Win32.pm +++ b/lib/File/Spec/Win32.pm @@ -5,7 +5,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.2501'; +$VERSION = '3.27'; @ISA = qw(File::Spec::Unix); @@ -126,23 +126,27 @@ 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 ""; + + 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 ""; + + return _canon_cat( @_ ); } sub path { @@ -165,25 +169,10 @@ On Win32 makes =cut sub canonpath { - my ($self,$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 - - return $self->_collapse($path); + # Legacy / compatibility support + # + return $_[1] if !defined($_[1]) or $_[1] eq ''; + return _canon_cat( $_[1] ); } =item splitpath @@ -375,4 +364,69 @@ implementation of these methods, not the semantics. =cut + +sub _canon_cat(@) # @path -> path +{ + my $first = shift; + 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, @_; + + $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 + \\\.\. + (? xx NOTE: this is *not* root + $path =~ s#\\\z##; # xx\ --> xx + + if ( $volume =~ m#\\\z# ) + { # \.. --> \ + $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; diff --git a/lib/File/Spec/t/Spec.t b/lib/File/Spec/t/Spec.t index a39779f..9d06f63 100644 --- a/lib/File/Spec/t/Spec.t +++ b/lib/File/Spec/t/Spec.t @@ -191,10 +191,10 @@ if ($^O eq 'MacOS') { [ "Win32->catdir('\\d1','d2')", '\\d1\\d2' ], [ "Win32->catdir('\\d1','\\d2')", '\\d1\\d2' ], [ "Win32->catdir('\\d1','\\d2\\')", '\\d1\\d2' ], -[ "Win32->catdir('','/d1','d2')", '\\\\d1\\d2' ], -[ "Win32->catdir('','','/d1','d2')", '\\\\\\d1\\d2' ], -[ "Win32->catdir('','//d1','d2')", '\\\\\\d1\\d2' ], -[ "Win32->catdir('','','//d1','d2')", '\\\\\\\\d1\\d2' ], +[ "Win32->catdir('','/d1','d2')", '\\d1\\d2' ], +[ "Win32->catdir('','','/d1','d2')", '\\d1\\d2' ], +[ "Win32->catdir('','//d1','d2')", '\\d1\\d2' ], +[ "Win32->catdir('','','//d1','d2')", '\\d1\\d2' ], [ "Win32->catdir('','d1','','d2','')", '\\d1\\d2' ], [ "Win32->catdir('','d1','d2','d3','')", '\\d1\\d2\\d3' ], [ "Win32->catdir('d1','d2','d3','')", 'd1\\d2\\d3' ], @@ -206,13 +206,14 @@ if ($^O eq 'MacOS') { [ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\B:\\d2\\d3' ], [ "Win32->catdir('A:/')", 'A:\\' ], [ "Win32->catdir('\\', 'foo')", '\\foo' ], - +[ "Win32->catdir('','','..')", '\\' ], [ "Win32->catfile('a','b','c')", 'a\\b\\c' ], [ "Win32->catfile('a','b','.\\c')", 'a\\b\\c' ], [ "Win32->catfile('.\\a','b','c')", 'a\\b\\c' ], [ "Win32->catfile('c')", 'c' ], [ "Win32->catfile('.\\c')", 'c' ], +[ "Win32->catfile('a/..','../b')", '..\\b' ], [ "Win32->canonpath('')", '' ], @@ -224,9 +225,9 @@ if ($^O eq 'MacOS') { [ "Win32->canonpath('//a\\b//c')", '\\\\a\\b\\c' ], [ "Win32->canonpath('/a/..../c')", '\\a\\....\\c' ], [ "Win32->canonpath('//a/b\\c')", '\\\\a\\b\\c' ], -[ "Win32->canonpath('////')", '\\\\\\' ], +[ "Win32->canonpath('////')", '\\' ], [ "Win32->canonpath('//')", '\\' ], -[ "Win32->canonpath('/.')", '\\.' ], +[ "Win32->canonpath('/.')", '\\' ], [ "Win32->canonpath('//a/b/../../c')", '\\\\a\\b\\c' ], [ "Win32->canonpath('//a/b/c/../d')", '\\\\a\\b\\d' ], [ "Win32->canonpath('//a/b/c/../../d')",'\\\\a\\b\\d' ], @@ -694,6 +695,7 @@ if ($^O eq 'MacOS') { [ "Cygwin->rel2abs('..','/t1/t2/t3')", '/t1/t2/t3/..' ], [ "Cygwin->rel2abs('../t4','/t1/t2/t3')", '/t1/t2/t3/../t4' ], [ "Cygwin->rel2abs('/t1','/t1/t2/t3')", '/t1' ], +[ "Cygwin->rel2abs('//t1/t2/t3','/foo')", '//t1/t2/t3' ], ) ; diff --git a/lib/File/Spec/t/crossplatform.t b/lib/File/Spec/t/crossplatform.t index 0391aaa..91ea01c 100644 --- a/lib/File/Spec/t/crossplatform.t +++ b/lib/File/Spec/t/crossplatform.t @@ -7,7 +7,7 @@ use Test::More; local $|=1; my @platforms = qw(Cygwin Epoc Mac OS2 Unix VMS Win32); -my $tests_per_platform = 7; +my $tests_per_platform = 10; plan tests => 1 + @platforms * $tests_per_platform; @@ -56,6 +56,17 @@ foreach my $platform (@platforms) { is $module->file_name_is_absolute($base), 1, "$base is absolute on $platform"; + # splitdir('') -> () + my @result = $module->splitdir(''); + is @result, 0, "$platform->splitdir('') -> ()"; + + # canonpath() -> undef + $result = $module->canonpath(); + is $result, undef, "$platform->canonpath() -> undef"; + + # canonpath(undef) -> undef + $result = $module->canonpath(undef); + is $result, undef, "$platform->canonpath(undef) -> undef"; # abs2rel('A:/foo/bar', 'A:/foo') -> 'bar' $file = $module->catpath($v, $module->catdir($module->rootdir, 'foo', 'bar'), 'file'); diff --git a/lib/File/Spec/t/tmpdir.t b/lib/File/Spec/t/tmpdir.t index bc004f9..fc5ec0b 100644 --- a/lib/File/Spec/t/tmpdir.t +++ b/lib/File/Spec/t/tmpdir.t @@ -14,9 +14,8 @@ File::Spec->tmpdir; ok scalar keys %ENV, $num_keys, "tmpdir() shouldn't change the contents of %ENV"; if ($^O eq 'VMS') { - skip('Can\'t make list assignment to \%ENV on this system', 1); -} -else { + skip("Can't make list assignment to %ENV on this system", 1); +} else { local %ENV; File::Spec::Win32->tmpdir; ok scalar keys %ENV, 0, "Win32->tmpdir() shouldn't change the contents of %ENV";