bring File-Path up to 2.01

Message-ID: <4682BE9F.6080502@landgren.net>

p4raw-id: //depot/perl@31484

diff --git a/lib/File/Path.pm b/lib/File/Path.pm
index 441b312..37ec8ea 100644 (file)
--- a/lib/File/Path.pm
+++ b/lib/File/Path.pm
@@ -6,8 +6,8 @@ File::Path - Create or remove directory trees
 
 =head1 VERSION
 
-This document describes version 2.00_04 of File::Path, released
-2007-06-07.
+This document describes version 2.01 of File::Path, released
+2007-06-27.
 
 =head1 SYNOPSIS
 
@@ -371,7 +371,7 @@ BEGIN {
 
 use Exporter ();
 use vars qw($VERSION @ISA @EXPORT);
-$VERSION = '2.00_04';
+$VERSION = '2.01';
 @ISA     = qw(Exporter);
 @EXPORT  = qw(mkpath rmtree);
 
@@ -394,19 +394,26 @@ sub _croak {
 }
 
 sub mkpath {
-    my $new_style = (
+    my $old_style = (
         UNIVERSAL::isa($_[0],'ARRAY')
         or (@_ == 2 and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1))
         or (@_ == 3
             and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1)
             and (defined $_[2] ? $_[2] =~ /\A\d+\z/ : 1)
         )
-    ) ? 0 : 1;
+    ) ? 1 : 0;
 
     my $arg;
     my $paths;
 
-    if ($new_style) {
+    if ($old_style) {
+        my ($verbose, $mode);
+        ($paths, $verbose, $mode) = @_;
+        $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY');
+        $arg->{verbose} = defined $verbose ? $verbose : 0;
+        $arg->{mode}    = defined $mode    ? $mode    : 0777;
+    }
+    else {
         if (@_ > 0 and UNIVERSAL::isa($_[-1], 'HASH')) {
             $arg = pop @_;
             exists $arg->{mask} and $arg->{mode} = delete $arg->{mask};
@@ -418,13 +425,6 @@ sub mkpath {
         }
         $paths = [@_];
     }
-    else {
-        my ($verbose, $mode);
-        ($paths, $verbose, $mode) = @_;
-        $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY');
-        $arg->{verbose} = defined $verbose ? $verbose : 0;
-        $arg->{mode}    = defined $mode    ? $mode    : 0777;
-    }
     return _mkpath($arg, $paths);
 }
 
@@ -471,31 +471,19 @@ sub _mkpath {
 }
 
 sub rmtree {
-    my $new_style = (
+    my $old_style = (
         UNIVERSAL::isa($_[0],'ARRAY')
         or (@_ == 2 and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1))
         or (@_ == 3
             and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1)
             and (defined $_[2] ? $_[2] =~ /\A\d+\z/ : 1)
         )
-    ) ? 0 : 1;
+    ) ? 1 : 0;
 
     my $arg;
     my $paths;
 
-    if ($new_style) {
-        if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH')) {
-            $arg = pop @_;
-            ${$arg->{error}}  = [] if exists $arg->{error};
-            ${$arg->{result}} = [] if exists $arg->{result};
-        }
-        else {
-            @{$arg}{qw(verbose safe)} = (0, 0);
-        }
-        $arg->{depth} = 0;
-        $paths = [@_];
-    }
-    else {
+    if ($old_style) {
         my ($verbose, $safe);
         ($paths, $verbose, $safe) = @_;
         $arg->{verbose} = defined $verbose ? $verbose : 0;
@@ -505,14 +493,21 @@ sub rmtree {
             $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY');
         }
         else {
-        if ($arg->{error}) {
-            push @{${$arg->{error}}}, {'' => "No root path(s) specified"};
+            _carp ("No root path(s) specified\n");
+            return 0;
+        }
     }
     else {
-                _carp ("No root path(s) specified\n");
+        if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH')) {
+            $arg = pop @_;
+            ${$arg->{error}}  = [] if exists $arg->{error};
+            ${$arg->{result}} = [] if exists $arg->{result};
         }
-      return 0;
+        else {
+            @{$arg}{qw(verbose safe)} = (0, 0);
     }
+        $arg->{depth} = 0;
+        $paths = [@_];
     }
     return _rmtree($arg, $paths);
 }
@@ -522,7 +517,7 @@ sub _rmtree {
     my $paths = shift;
     my($count) = 0;
     my (@files, $root);
-    foreach $root (@{$paths}) {
+    foreach $root (@$paths) {
        if ($Is_MacOS) {
            $root = ":$root" if $root !~ /:/;
             $root =~ s/([^:])\z/$1:/;

diff --git a/lib/File/Path.t b/lib/File/Path.t
index d68351b..36ac5a9 100755 (executable)
--- a/lib/File/Path.t
+++ b/lib/File/Path.t
@@ -2,7 +2,7 @@
 
 use strict;
 
-use Test::More tests => 71;
+use Test::More tests => 84;
 
 BEGIN {
     use_ok('File::Path');
@@ -135,6 +135,23 @@ is(scalar(@$list),  4, "list contains 4 elements")
 ok(-d $dir,  "dir a still exists");
 ok(-d $dir2, "dir z still exists");
 
+$dir = catdir($tmp_base,'F');
+
+@created = mkpath($dir, undef, 0770);
+is(scalar(@created), 1, "created directory (old style 2 verbose undef)");
+is($created[0], $dir, "created directory (old style 2 verbose undef) cross-check");
+is(rmtree($dir, undef, 0), 1, "removed directory 2 verbose undef");
+
+@created = mkpath($dir, undef);
+is(scalar(@created), 1, "created directory (old style 2a verbose undef)");
+is($created[0], $dir, "created directory (old style 2a verbose undef) cross-check");
+is(rmtree($dir, undef), 1, "removed directory 2a verbose undef");
+
+@created = mkpath($dir, 0, undef);
+is(scalar(@created), 1, "created directory (old style 3 mode undef)");
+is($created[0], $dir, "created directory (old style 3 mode undef) cross-check");
+is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef");
+
 # borderline new-style heuristics
 if (chdir $tmp_base) {
     pass("chdir to temp dir");
@@ -212,6 +229,9 @@ SKIP: {
     rmtree($dir, {error => \$error});
     is( scalar(@$error), 2, 'two errors for an unreadable dir' );
 
+    $dir = catdir('EXTRA', '3', 'T');
+    rmtree($dir, {error => \$error});
+
     $dir = catdir( 'EXTRA', '4' );
     rmtree($dir,  {result => \$list, error => \$err} );
     is( @$list, 0, q{don't follow a symlinked dir} );
@@ -231,15 +251,22 @@ SKIP: {
 }
 
 SKIP: {
-    skip 'Test::Output not available', 10
+    skip 'Test::Output not available', 14
         unless $has_Test_Output;
 
-
     SKIP: {
         $dir = catdir('EXTRA', '3');
         skip "extra scenarios not set up, see eg/setup-extra-tests", 2
             unless -e $dir;
 
+        $dir = catdir('EXTRA', '3', 'U');
+        stderr_like( 
+            sub {rmtree($dir, {verbose => 0})},
+            qr{\bCan't read \Q$dir\E: },
+            q(rmtree can't read root dir)
+        );
+
+        $dir = catdir('EXTRA', '3');
         stderr_like( 
             sub {rmtree($dir, {})},
             qr{\ACan't remove directory \S+: .*? at \S+ line \d+\n},
@@ -268,6 +295,15 @@ and can't restore permissions to \d+
         "rmtree of nothing carps sensibly"
     );
 
+    stderr_like(
+        sub { rmtree( '', 1 ) },
+        qr/\ANo root path\(s\) specified\b/,
+        "rmtree of empty dir carps sensibly"
+    );
+
+    stderr_is( sub { mkpath() }, '', "mkpath no args does not carp" );
+    stderr_is( sub { rmtree() }, '', "rmtree no args does not carp" );
+
     stdout_is(
         sub {@created = mkpath($dir, 1)},
         "mkdir $base\nmkdir $dir\n",