From: David Landgren Date: Mon, 17 Sep 2007 23:27:45 +0000 (+0200) Subject: minor changes to File::Path (and more tests) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=37b1cd441a1f821f5d79b453121d560286349812;p=p5sagit%2Fp5-mst-13.2.git minor changes to File::Path (and more tests) Message-ID: <46EEF151.6010409@landgren.net> p4raw-id: //depot/perl@31903 --- diff --git a/lib/File/Path.pm b/lib/File/Path.pm index c6a4f66..bd54bbc 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_11 of File::Path, released -2007-09-08. +This document describes version 2.00_12 of File::Path, released +2007-09-17. =head1 SYNOPSIS @@ -317,7 +317,7 @@ See the following pages for more information: http://www.debian.org/security/2005/dsa-696 Additionally, unless the C parameter is set (or the -third parameter in the traditional inferface is TRUE), should a +third parameter in the traditional interface is TRUE), should a C be interrupted, files that were originally in read-only mode may now have their permissions set to a read-write (or "delete OK") mode. @@ -338,7 +338,7 @@ they will be Ced about. Program execution will not be halted. =over 4 -=item mkdir [ppath]: [errmsg] (SEVERE) +=item mkdir [path]: [errmsg] (SEVERE) C was unable to create the path. Probably some sort of permissions error at the point of departure, or insufficient resources @@ -454,7 +454,7 @@ C failed to remove a file. Probably a permissions issue. =item cannot restore permissions of [file] to [0nnn]: [errmsg] After having failed to remove a file, C was also unable -to restore the permissions on the file to a possibily less permissive +to restore the permissions on the file to a possibly less permissive setting. (Permissions given in octal). =back @@ -482,7 +482,7 @@ L =head1 ACKNOWLEDGEMENTS -Paul Szabo identified the race condition orignially, and Brendan +Paul Szabo identified the race condition originally, and Brendan O'Dea wrote an implementation for Debian that addressed the problem. That code was used as a basis for the current code. Their efforts are greatly appreciated. @@ -522,7 +522,7 @@ BEGIN { use Exporter (); use vars qw($VERSION @ISA @EXPORT); -$VERSION = '2.00_12'; +$VERSION = '2.00_11'; @ISA = qw(Exporter); @EXPORT = qw(mkpath rmtree); @@ -700,6 +700,7 @@ sub _rmtree { my $updir = File::Spec->updir(); my (@files, $root); + ROOT_DIR: foreach $root (@$paths) { if ($Is_MacOS) { $root = ":$root" unless $root =~ /:/; @@ -720,7 +721,7 @@ sub _rmtree { : $root ; - my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next; + my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next ROOT_DIR; if ( -d _ ) { $root = VMS::Filespec::pathify($root) if $Is_VMS; @@ -731,17 +732,17 @@ sub _rmtree { my $nperm = $perm | 0700; if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $root))) { _error($arg, "cannot make child directory read-write-exec", $canon); - next; + next ROOT_DIR; } elsif (!chdir($root)) { _error($arg, "cannot chdir to child", $canon); - next; + next ROOT_DIR; } } my ($device, $inode, $perm) = (stat $curdir)[0,1,2] or do { _error($arg, "cannot stat current working directory", $canon); - return $count; + next ROOT_DIR; }; ($ldev eq $device and $lino eq $inode) @@ -819,7 +820,7 @@ sub _rmtree { if ($arg->{safe} && ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { print "skipped $root\n" if $arg->{verbose}; - next; + next ROOT_DIR; } if (!chmod $perm | 0700, $root) { if ($Force_Writeable) { @@ -851,7 +852,7 @@ sub _rmtree { : !(-l $root || -w $root))) { print "skipped $root\n" if $arg->{verbose}; - next; + next ROOT_DIR; } my $nperm = $perm & 07777 | 0600; diff --git a/lib/File/Path.t b/lib/File/Path.t index 1a5f326..1e007e8 100755 --- a/lib/File/Path.t +++ b/lib/File/Path.t @@ -2,7 +2,7 @@ use strict; -use Test::More tests => 93; +use Test::More tests => 98; BEGIN { use_ok('File::Path'); @@ -221,7 +221,7 @@ SKIP: { my $extra = catdir(curdir(), qw(EXTRA 1 a)); SKIP: { - skip "extra scenarios not set up, see eg/setup-extra-tests", 9 + skip "extra scenarios not set up, see eg/setup-extra-tests", 14 unless -e $extra; my ($list, $err); @@ -238,17 +238,30 @@ SKIP: { $dir = catdir('EXTRA', '3', 'S'); rmtree($dir, {error => \$error}); is( scalar(@$error), 1, 'one error for an unreadable dir' ); + eval { ($file, $message) = each %{$error->[0]}}; + is( $file, $dir, 'unreadable dir reported in error' ) + or diag($message); $dir = catdir('EXTRA', '3', 'T'); rmtree($dir, {error => \$error}); - is( scalar(@$error), 1, 'one error for an unreadable dir' ); + is( scalar(@$error), 1, 'one error for an unreadable dir T' ); + eval { ($file, $message) = each %{$error->[0]}}; + is( $file, $dir, 'unreadable dir reported in error T' ); $dir = catdir( 'EXTRA', '4' ); rmtree($dir, {result => \$list, error => \$err} ); - is( @$list, 0, q{don't follow a symlinked dir} ); - is( @$err, 2, q{two errors when removing a symlink in r/o dir} ); + is( scalar(@$list), 0, q{don't follow a symlinked dir} ); + is( scalar(@$err), 2, q{two errors when removing a symlink in r/o dir} ); eval { ($file, $message) = each %{$err->[0]} }; is( $file, $dir, 'symlink reported in error' ); + + $dir = catdir('EXTRA', '3', 'U'); + $dir2 = catdir('EXTRA', '3', 'V'); + rmtree($dir, $dir2, {verbose => 0, error => \$err, result => \$list}); + is( scalar(@$list), 1, q{deleted 1 out of 2 directories} ); + is( scalar(@$error), 1, q{left behind 1 out of 2 directories} ); + eval { ($file, $message) = each %{$err->[0]} }; + is( $file, $dir, 'first dir reported in error' ); } {