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

p4raw-id: //depot/perl@35011

diff --git a/lib/File/Path.pm b/lib/File/Path.pm
index 932ae64..602a500 100644 (file)
--- a/lib/File/Path.pm
+++ b/lib/File/Path.pm
@@ -166,6 +166,19 @@ sub rmtree {
     for ($arg->{cwd}) { /\A(.*)\Z/; $_ = $1 } # untaint
 
     for my $p (@$paths) {
+        # need to fixup case and map \ to / on Windows
+        my $ortho_root = $^O eq 'MSWin32' ? _slash_lc($p)          : $p;
+        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))) {
+            local $! = 0;
+            _error($arg, "cannot remove path when cwd is $arg->{cwd}", $p);
+            next;
+        }
+
         if ($Is_MacOS) {
             $p  = ":$p" unless $p =~ /:/;
             $p .= ":"   unless $p =~ /:\z/;
@@ -733,6 +746,15 @@ C<remove_tree>, after having deleted everything in a directory, attempted
 to restore its permissions to the original state but failed. The
 directory may wind up being left behind.
 
+=item cannot remove [dir] when cwd is [dir]
+
+The current working directory of the program is F</some/path/to/here>
+and you are attempting to remove an ancestor, such as F</some/path>.
+The directory tree is left untouched.
+
+The solution is to C<chdir> out of the child directory to a place
+outside the directory tree to be removed.
+
 =item cannot chdir to [parent-dir] from [child-dir]: [errmsg], aborting. (FATAL)
 
 C<remove_tree>, after having deleted everything and restored the permissions

diff --git a/lib/File/Path.t b/lib/File/Path.t
index ca9eaf6..34e316e 100755 (executable)
--- a/lib/File/Path.t
+++ b/lib/File/Path.t
@@ -2,7 +2,7 @@
 
 use strict;
 
-use Test::More tests => 108;
+use Test::More tests => 114;
 use Config;
 
 BEGIN {
@@ -138,6 +138,43 @@ sub count {
     rmtree 'solo';
 }
 
+SKIP: {
+    # tests for rmtree() of ancestor directory
+    my $nr_tests = 6;
+    my $cwd = getcwd() or skip "failed to getcwd: $!", $nr_tests;
+    my $dir  = catdir($cwd, 'remove');
+    my $dir2 = catdir($cwd, 'remove', 'this', 'dir');
+
+    skip "failed to mkpath '$dir2': $!", $nr_tests
+        unless mkpath($dir2, {verbose => 0});
+    skip "failed to chdir dir '$dir2': $!", $nr_tests
+        unless chdir($dir2);
+
+    rmtree($dir, {error => \$error});
+    my $nr_err = @$error;
+    is($nr_err, 1, "ancestor error");
+
+    if ($nr_err) {
+        my ($file, $message) = each %{$error->[0]};
+        is($file, $dir, "ancestor named");
+        my $ortho_dir = $^O eq 'MSWin32' ? File::Path::_slash_lc($dir2) : $dir2;
+        $^O eq 'MSWin32' and $message
+            =~ s/\A(cannot remove path when cwd is )(.*)\Z/$1 . File::Path::_slash_lc($2)/e;
+        is($message, "cannot remove path when cwd is $ortho_dir", "ancestor reason");
+        ok(-d $dir2, "child not removed");
+        ok(-d $dir, "ancestor not removed");
+    }
+    else {
+        fail( "ancestor 1");
+        fail( "ancestor 2");
+        fail( "ancestor 3");
+        fail( "ancestor 4");
+    }
+    chdir $cwd;
+    rmtree($dir);
+    ok(!(-d $dir), "ancestor now removed");
+};
+
 my $count = rmtree({error => \$error});
 is( $count, 0, 'rmtree of nothing, count of zero' );
 is( scalar(@$error), 0, 'no diagnostic captured' );