Integrate:
authorNicholas Clark <nick@ccl4.org>
Sat, 6 Dec 2008 14:47:47 +0000 (14:47 +0000)
committerNicholas Clark <nick@ccl4.org>
Sat, 6 Dec 2008 14:47:47 +0000 (14:47 +0000)
[ 35034]
Integrate:
[ 35008]
Subject: Re: File::Path regression in 5.8.9
From: Gisle Aas <gisle@activestate.com>
Date: Wed, 19 Nov 2008 19:09:20 +0100
Message-Id: <C72B3504-E0B8-4622-89AA-3C07C57C14E2@activestate.com>

[plus bump $VERSION. Gah. Format F-word must die]

[ 35009]
For now, remove the 'cannot remove [dir] when cwd is [dir]' message,
because the existing code will think that /tmp/abc is a subdirectory
of /tmp/aa, and whilst we have a patch for Win32 and *nix, we've not
tested on VMS, which has "interesting" path syntax.

[ 35011]
Revert 35009 so we can take another swing at ancestor detection.

[ 35012]
Subject: Re: File::Path regression in 5.8.9
From: Marcus Holland-Moritz <mhx-perl@gmx.net>
Date: Fri, 14 Nov 2008 10:58:09 +0100
Message-ID: <20081114105809.6435cba1@r2d2>

Plus replace "$p/$x" with catdir($p, $x) in the test.

[ 35013]
While we are off the reservation, revert a stupid, VMS-specific
test regression I caused David to make in 2.07.  (See
http://rt.cpan.org/Public/Bug/Display.html?id=40512 ).
p4raw-link: @35034 on //depot/maint-5.10/perl: d903733d444208e3103338071f7f93f42b4e2c55
p4raw-link: @35013 on //depot/perl: 33839f2f0661d0502f129769a85cfcf904354d39
p4raw-link: @35012 on //depot/perl: 0e5b5e32d0d031de37957bb60fb704952b9fb8b0
p4raw-link: @35011 on //depot/perl: c42ebacb0e17be8ca87dc9a9f52e0b720fab0209
p4raw-link: @35009 on //depot/perl: aa119509815264ca46da9f8ef37082ad657bdb94
p4raw-link: @35008 on //depot/perl: 210707008b520f8aa498d2091080e67662d4b270

p4raw-id: //depot/maint-5.8/perl@35037
p4raw-integrated: from //depot/maint-5.10/perl@35035 'copy in'
lib/File/Path.pm lib/File/Path.t (@34787..)

lib/File/Path.pm
lib/File/Path.t

index 128d95b..7b687cd 100644 (file)
@@ -17,7 +17,7 @@ BEGIN {
 
 use Exporter ();
 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-$VERSION   = '2.07';
+$VERSION   = '2.07_02';
 @ISA       = qw(Exporter);
 @EXPORT    = qw(mkpath rmtree);
 @EXPORT_OK = qw(make_path remove_tree);
@@ -128,6 +128,24 @@ sub remove_tree {
     goto &rmtree;
 }
 
+sub _is_subdir {
+    my($dir, $test) = @_;
+
+    my($dv, $dd) = File::Spec->splitpath($dir, 1);
+    my($tv, $td) = File::Spec->splitpath($test, 1);
+
+    # not on same volume
+    return 0 if $dv ne $tv;
+
+    my @d = File::Spec->splitdir($dd);
+    my @t = File::Spec->splitdir($td);
+
+    # @t can't be a subdir if it's shorter than @d
+    return 0 if @t < @d;
+
+    return join('/', @d) eq join('/', splice @t, 0, +@d);
+}
+
 sub rmtree {
     my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH'));
 
@@ -171,9 +189,7 @@ sub rmtree {
         my $ortho_cwd  = $^O eq 'MSWin32' ? _slash_lc($arg->{cwd}) : $arg->{cwd};
         my $ortho_root_length = length($ortho_root);
         $ortho_root_length-- if $^O eq 'VMS'; # don't compare '.' with ']'
-        if ($ortho_root_length
-            && (substr($ortho_root, 0, $ortho_root_length) 
-             eq substr($ortho_cwd, 0, $ortho_root_length))) {
+        if ($ortho_root_length && _is_subdir($ortho_root, $ortho_cwd)) {
             local $! = 0;
             _error($arg, "cannot remove path when cwd is $arg->{cwd}", $p);
             next;
@@ -333,7 +349,7 @@ sub _rmtree {
                 }
                 else {
                     _error($arg, "cannot remove directory", $canon);
-                    if (!chmod($perm, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
+                    if ($Force_Writeable && !chmod($perm, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
                     ) {
                         _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon);
                     }
index 34e316e..3ecd8f6 100755 (executable)
@@ -2,7 +2,7 @@
 
 use strict;
 
-use Test::More tests => 114;
+use Test::More tests => 120;
 use Config;
 
 BEGIN {
@@ -205,7 +205,8 @@ $count = rmtree($dir, 0);
 is($count, 1, "removed directory unsafe mode");
 
 $count = rmtree($dir2, 0, 1);
-is($count, 1, "removed directory safe mode");
+my $removed = $Is_VMS ? 0 : 1;
+is($count, $removed, "removed directory safe mode");
 
 # mkdir foo ./E/../Y
 # Y should exist
@@ -545,6 +546,27 @@ SKIP: {
     }
 }
 
-rmtree($tmp_base, {result => \$list} );
-is(ref($list), 'ARRAY', "received a final list of results");
-ok( !(-d $tmp_base), "test base directory gone" );
+SKIP: {
+    my $nr_tests = 6;
+    my $cwd = getcwd() or skip "failed to getcwd: $!", $nr_tests;
+    rmtree($tmp_base, {result => \$list} );
+    is(ref($list), 'ARRAY', "received a final list of results");
+    ok( !(-d $tmp_base), "test base directory gone" );
+    
+    my $p = getcwd();
+    my $x = "x$$";
+    my $xx = $x . "x";
+    
+    # setup
+    ok(mkpath($xx));
+    ok(chdir($xx));
+    END {
+         ok(chdir($p));
+         ok(rmtree($xx));
+    }
+    
+    # create and delete directory
+    my $px = catdir($p, $x);
+    ok(mkpath($px));
+    ok(rmtree($px), "rmtree");     # fails in File-Path-2.07
+}