From: David Landgren Date: Wed, 27 Jun 2007 21:46:39 +0000 (+0200) Subject: bring File-Path up to 2.01 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cd117d8b374566f3c2f8a903761a66f472e5fc54;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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",