From: Marcus Holland-Moritz <mhx-perl@gmx.net>
Date: Fri, 14 Nov 2008 10:58:09 +0000 (+0100)
Subject: Re: File::Path regression in 5.8.9
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0e5b5e32d0d031de37957bb60fb704952b9fb8b0;p=p5sagit%2Fp5-mst-13.2.git

Re: File::Path regression in 5.8.9
Message-ID: <20081114105809.6435cba1@r2d2>

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

p4raw-id: //depot/perl@35012
---

diff --git a/lib/File/Path.pm b/lib/File/Path.pm
index 602a500..156597e 100644
--- a/lib/File/Path.pm
+++ b/lib/File/Path.pm
@@ -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;
diff --git a/lib/File/Path.t b/lib/File/Path.t
index 34e316e..001fcc3 100755
--- a/lib/File/Path.t
+++ b/lib/File/Path.t
@@ -2,7 +2,7 @@
 
 use strict;
 
-use Test::More tests => 114;
+use Test::More tests => 120;
 use Config;
 
 BEGIN {
@@ -545,6 +545,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
+}