From: Nicholas Clark <nick@ccl4.org>
Date: Thu, 25 Jun 2009 12:57:57 +0000 (+0100)
Subject: Upgrade to File::Path 2.07_03
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=839bc55ad61e73319e7d4ae40fd6ece8ff36b147;p=p5sagit%2Fp5-mst-13.2.git

Upgrade to File::Path 2.07_03
---

diff --git a/lib/File/Path.pm b/lib/File/Path.pm
index 7b687cd..e31191f 100644
--- a/lib/File/Path.pm
+++ b/lib/File/Path.pm
@@ -17,7 +17,7 @@ BEGIN {
 
 use Exporter ();
 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-$VERSION   = '2.07_02';
+$VERSION   = '2.07_03';
 @ISA       = qw(Exporter);
 @EXPORT    = qw(mkpath rmtree);
 @EXPORT_OK = qw(make_path remove_tree);
@@ -29,6 +29,10 @@ my $Is_MacOS   = $^O eq 'MacOS';
 # write permission to:
 my $Force_Writeable = grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
 
+# Unix-like systems need to stat each directory in order to detect
+# race condition. MS-Windows is immune to this particular attack.
+my $Need_Stat_Check = !($^O eq 'MSWin32');
+
 sub _carp {
     require Carp;
     goto &Carp::carp;
@@ -242,6 +246,7 @@ sub _rmtree {
 
         if ( -d _ ) {
             $root = VMS::Filespec::pathify($root) if $Is_VMS;
+
             if (!chdir($root)) {
                 # see if we can escalate privileges to get in
                 # (e.g. funny protection mask such as -w- instead of rwx)
@@ -262,8 +267,10 @@ sub _rmtree {
                 next ROOT_DIR;
             };
 
-            ($ldev eq $cur_dev and $lino eq $cur_inode)
-                or _croak("directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");
+            if ($Need_Stat_Check) {
+                ($ldev eq $cur_dev and $lino eq $cur_inode)
+                    or _croak("directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");
+            }
 
             $perm &= 07777; # don't forget setuid, setgid, sticky bits
             my $nperm = $perm | 0700;
@@ -304,6 +311,7 @@ sub _rmtree {
                 @files = map {$_ eq '.' ? '.;' : $_} reverse @files;
                 ($root = VMS::Filespec::unixify($root)) =~ s/\.dir\z//;
             }
+
             @files = grep {$_ ne $updir and $_ ne $curdir} @files;
 
             if (@files) {
@@ -330,8 +338,10 @@ sub _rmtree {
             ($cur_dev, $cur_inode) = (stat $curdir)[0,1]
                 or _croak("cannot stat prior working directory $arg->{cwd}: $!, aborting.");
 
-            ($arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode)
-                or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");
+            if ($Need_Stat_Check) {
+                ($arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode)
+                    or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");
+            }
 
             if ($arg->{depth} or !$arg->{keep_root}) {
                 if ($arg->{safe} &&
diff --git a/lib/File/Path.t b/lib/File/Path.t
index 3ecd8f6..319c3d0 100644
--- a/lib/File/Path.t
+++ b/lib/File/Path.t
@@ -2,7 +2,7 @@
 
 use strict;
 
-use Test::More tests => 120;
+use Test::More tests => 121;
 use Config;
 
 BEGIN {
@@ -303,6 +303,23 @@ else {
 }
 
 SKIP: {
+    skip "This is not a MSWin32 platform", 1
+        unless $^O eq 'MSWin32';
+
+    my $UNC_path_taint = $ENV{PERL_FILE_PATH_UNC_TESTDIR};
+    skip "PERL_FILE_PATH_UNC_TESTDIR environment variable not set", 1
+        unless defined($UNC_path_taint);
+
+    my ($UNC_path) = ($UNC_path_taint =~ m{^([/\\]{2}\w+[/\\]\w+[/\\]\w+)$});
+    
+    skip "PERL_FILE_PATH_UNC_TESTDIR environment variable does not point to a directory", 1
+        unless -d $UNC_path;
+    
+    my $removed = rmtree($UNC_path);
+    cmp_ok($removed, '>', 0, "removed $removed entries from $UNC_path");
+}
+
+SKIP: {
     # test bug http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=487319
     skip "Don't need Force_Writeable semantics on $^O", 4
         if grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
@@ -453,8 +470,7 @@ cannot remove directory for [^:]+: .* at \1 line \2
 cannot unlink file for [^:]+: .* at \1 line \2
 cannot restore permissions to \d+ for [^:]+: .* at \1 line \2
 cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
-cannot remove directory for [^:]+: .* at \1 line \2
-cannot restore permissions to \d+ for [^:]+: .* at \1 line \2},
+cannot remove directory for [^:]+: .* at \1 line \2},
             'rmtree with insufficient privileges'
         );
     }
@@ -529,7 +545,7 @@ SKIP: {
         unless -d catdir(qw(EXTRA 1));
 
     rmtree 'EXTRA', {safe => 0, error => \$error};
-    is( scalar(@$error), 11, 'seven deadly sins' ); # well there used to be 7
+    is( scalar(@$error), 10, 'seven deadly sins' ); # well there used to be 7
 
     rmtree 'EXTRA', {safe => 1, error => \$error};
     is( scalar(@$error), 9, 'safe is better' );