Upgrade to PathTools-3.27
authorSteve Peters <steve@fisharerojo.org>
Wed, 23 Jan 2008 04:12:37 +0000 (04:12 +0000)
committerSteve Peters <steve@fisharerojo.org>
Wed, 23 Jan 2008 04:12:37 +0000 (04:12 +0000)
p4raw-id: //depot/perl@33042

15 files changed:
ext/Cwd/Cwd.xs
ext/Cwd/t/cwd.t
lib/Cwd.pm
lib/File/Spec.pm
lib/File/Spec/Cygwin.pm
lib/File/Spec/Epoc.pm
lib/File/Spec/Functions.pm
lib/File/Spec/Mac.pm
lib/File/Spec/OS2.pm
lib/File/Spec/Unix.pm
lib/File/Spec/VMS.pm
lib/File/Spec/Win32.pm
lib/File/Spec/t/Spec.t
lib/File/Spec/t/crossplatform.t
lib/File/Spec/t/tmpdir.t

index 4958bd2..4864ba1 100644 (file)
@@ -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 <unistd.h>
 #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
  */
 
 /*
- * 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 <kostik@iclub.nsu.ru>
  *
  * Redistribution and use in source and binary forms, with or without
  * modification, are permitted provided that the following conditions
  * 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)
  * 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,
index 148682a..3be500a 100644 (file)
@@ -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);
 
index b273464..0896327 100644 (file)
@@ -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;
index cc3f172..3a83b99 100644 (file)
@@ -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',
index aa89563..df2904f 100644 (file)
@@ -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'));
index 2fb26be..67dd04b 100644 (file)
@@ -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
index 99894dd..1f95a50 100644 (file)
@@ -5,7 +5,7 @@ use strict;
 
 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
 
-$VERSION = '3.2501';
+$VERSION = '3.27';
 
 require Exporter;
 
index fcf2616..4122c10 100644 (file)
@@ -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;
index 948ccb2..66a2e33 100644 (file)
@@ -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
index 9985f34..0fb4943 100644 (file)
@@ -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
index 35755ce..b038b66 100644 (file)
@@ -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);
 
index 6e9abc8..98f2ea2 100644 (file)
@@ -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
+               \\\.\.
+               (?<!\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;
index a39779f..9d06f63 100644 (file)
@@ -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'      ],
 
 ) ;
 
index 0391aaa..91ea01c 100644 (file)
@@ -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');
index bc004f9..fc5ec0b 100644 (file)
@@ -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";