From: Nicholas Clark Date: Tue, 28 Oct 2008 11:27:58 +0000 (+0000) Subject: Upgrade to File::Path 2.06_06. (a diff from David via http) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3f083399695aa47ad00262eeef44bb1d66b9dc05;p=p5sagit%2Fp5-mst-13.2.git Upgrade to File::Path 2.06_06. (a diff from David via http) p4raw-id: //depot/perl@34615 --- diff --git a/lib/File/Path.pm b/lib/File/Path.pm index 19b5750..a622ac7 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -16,10 +16,11 @@ BEGIN { } use Exporter (); -use vars qw($VERSION @ISA @EXPORT); -$VERSION = '2.04'; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); +$VERSION = '2.06_06'; @ISA = qw(Exporter); @EXPORT = qw(mkpath rmtree); +@EXPORT_OK = qw(make_path remove_tree); my $Is_VMS = $^O eq 'VMS'; my $Is_MacOS = $^O eq 'MacOS'; @@ -45,22 +46,21 @@ sub _error { if ($arg->{error}) { $object = '' unless defined $object; - push @{${$arg->{error}}}, {$object => "$message: $!"}; + $message .= ": $!" if $!; + push @{${$arg->{error}}}, {$object => $message}; } else { _carp(defined($object) ? "$message for $object: $!" : "$message: $!"); } } +sub make_path { + push @_, {} if !@_ or (@_ and !UNIVERSAL::isa($_[-1],'HASH')); + goto &mkpath; +} + sub mkpath { - 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) - ) - ) ? 1 : 0; + my $old_style = !(@_ > 0 and UNIVERSAL::isa($_[-1],'HASH')); my $arg; my $paths; @@ -73,15 +73,11 @@ sub mkpath { $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}; + $arg->{verbose} ||= 0; + $arg->{mode} = delete $arg->{mask} if exists $arg->{mask}; $arg->{mode} = 0777 unless exists $arg->{mode}; ${$arg->{error}} = [] if exists $arg->{error}; - } - else { - @{$arg}{qw(verbose mode)} = (0, 0777); - } $paths = [@_]; } return _mkpath($arg, $paths); @@ -91,10 +87,9 @@ sub _mkpath { my $arg = shift; my $paths = shift; - local($")=$Is_MacOS ? ":" : "/"; my(@created,$path); foreach $path (@$paths) { - next unless length($path); + next unless defined($path) and length($path); $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT # Logic wants Unix paths, so go with the flow. if ($Is_VMS) { @@ -129,15 +124,13 @@ sub _mkpath { return @created; } +sub remove_tree { + push @_, {} if !@_ or (@_ and !UNIVERSAL::isa($_[-1],'HASH')); + goto &rmtree; +} + sub rmtree { - 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) - ) - ) ? 1 : 0; + my $old_style = !(@_ > 0 and UNIVERSAL::isa($_[-1],'HASH')); my $arg; my $paths; @@ -171,18 +164,42 @@ sub rmtree { $arg->{prefix} = ''; $arg->{depth} = 0; + my @clean_path; $arg->{cwd} = getcwd() or do { _error($arg, "cannot fetch initial working directory"); return 0; }; for ($arg->{cwd}) { /\A(.*)\Z/; $_ = $1 } # untaint - @{$arg}{qw(device inode)} = (stat $arg->{cwd})[0,1] or do { + 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}; + if ($ortho_root eq substr($ortho_cwd, 0, length($ortho_root))) { + 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/; + } + elsif ($^O eq 'MSWin32') { + $p =~ s{[/\\]\z}{}; + } + else { + $p =~ s{/\z}{}; + } + push @clean_path, $p; + } + + @{$arg}{qw(device inode perm)} = (lstat $arg->{cwd})[0,1] or do { _error($arg, "cannot stat initial working directory", $arg->{cwd}); return 0; }; - return _rmtree($arg, $paths); + return _rmtree($arg, \@clean_path); } sub _rmtree { @@ -196,14 +213,6 @@ sub _rmtree { my (@files, $root); ROOT_DIR: foreach $root (@$paths) { - if ($Is_MacOS) { - $root = ":$root" unless $root =~ /:/; - $root .= ":" unless $root =~ /:\z/; - } - else { - $root =~ s{/\z}{}; - } - # since we chdir into each directory, it may not be obvious # to figure out where we are if we generate a message about # a file name. We therefore construct a semi-canonical @@ -234,13 +243,13 @@ sub _rmtree { } } - my ($device, $inode, $perm) = (stat $curdir)[0,1,2] or do { + my ($cur_dev, $cur_inode, $perm) = (stat $curdir)[0,1,2] or do { _error($arg, "cannot stat current working directory", $canon); next ROOT_DIR; }; - ($ldev eq $device and $lino eq $inode) - or _croak("directory $canon changed before chdir, expected dev=$ldev inode=$lino, actual dev=$device ino=$inode, aborting."); + ($ldev eq $cur_dev and $lino eq $cur_inode) + or _croak("directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."); $perm &= 07777; # don't forget setuid, setgid, sticky bits my $nperm = $perm | 0700; @@ -287,7 +296,7 @@ sub _rmtree { # remove the contained files before the directory itself my $narg = {%$arg}; @{$narg}{qw(device inode cwd prefix depth)} - = ($device, $inode, $updir, $canon, $arg->{depth}+1); + = ($cur_dev, $cur_inode, $updir, $canon, $arg->{depth}+1); $count += _rmtree($narg, \@files); } @@ -304,11 +313,11 @@ sub _rmtree { # ensure that a chdir upwards didn't take us somewhere other # than we expected (see CVE-2002-0435) - ($device, $inode) = (stat $curdir)[0,1] + ($cur_dev, $cur_inode) = (stat $curdir)[0,1] or _croak("cannot stat prior working directory $arg->{cwd}: $!, aborting."); - ($arg->{device} eq $device and $arg->{inode} eq $inode) - or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev inode=$lino, actual dev=$device ino=$inode, aborting."); + ($arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode) + or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."); if ($arg->{depth} or !$arg->{keep_root}) { if ($arg->{safe} && @@ -316,11 +325,9 @@ sub _rmtree { print "skipped $root\n" if $arg->{verbose}; next ROOT_DIR; } - if (!chmod $perm | 0700, $root) { - if ($Force_Writeable) { + if ($Force_Writeable and !chmod $perm | 0700, $root) { _error($arg, "cannot make directory writeable", $canon); } - } print "rmdir $root\n" if $arg->{verbose}; if (rmdir $root) { push @{${$arg->{result}}}, $root if $arg->{result}; @@ -351,11 +358,9 @@ sub _rmtree { } my $nperm = $perm & 07777 | 0600; - if ($nperm != $perm and not chmod $nperm, $root) { - if ($Force_Writeable) { + if ($Force_Writeable and $nperm != $perm and not chmod $nperm, $root) { _error($arg, "cannot make file writeable", $canon); } - } print "unlink $canon\n" if $arg->{verbose}; # delete all versions under VMS for (;;) { @@ -373,10 +378,17 @@ sub _rmtree { } } } - return $count; } +sub _slash_lc { + # fix up slashes and case on MSWin32 so that we can determine that + # c:\path\to\dir is underneath C:/Path/To + my $path = shift; + $path =~ tr{\\}{/}; + return lc($path); +} + 1; __END__ @@ -386,20 +398,24 @@ File::Path - Create or remove directory trees =head1 VERSION -This document describes version 2.04 of File::Path, released -2007-11-13. +This document describes version 2.06_06 of File::Path, released +2008-10-05. =head1 SYNOPSIS use File::Path; # modern + make_path( 'foo/bar/baz', '/zug/zwang' ); + # or mkpath( 'foo/bar/baz', '/zug/zwang', {verbose => 1} ); rmtree( 'foo/bar/baz', '/zug/zwang', { verbose => 1, error => \my $err_list } ); + # or + remove_tree( 'foo/bar/baz', '/zug/zwang' ); # traditional mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); @@ -410,32 +426,48 @@ This document describes version 2.04 of File::Path, released The C function provides a convenient way to create directories of arbitrary depth. Similarly, the C function provides a convenient way to delete an entire directory subtree from the -filesystem, much like the Unix command C. +filesystem, much like the Unix command C or C on +Windows. -Both functions may be called in one of two ways, the traditional, -compatible with code written since the dawn of time, and modern, -that offers a more flexible and readable idiom. New code should use -the modern interface. +There are two further functions, C and C +that perform the same task and offer a more intuitive interface. =head2 FUNCTIONS The modern way of calling C and C is with a list -of directories to create, or remove, respectively, followed by an -optional hash reference containing keys to control the -function's behaviour. +of directories to create, or remove, respectively, followed by a +hash reference containing keys to control the function's behaviour. -=head3 C +=head3 C + +The C routine accepts a list of directories to be +created. Its behaviour may be tuned by an optional hashref +appearing as the last parameter on the call. + + my @created = make_path(qw(/tmp /flub /home/nobody)); + print "created $_\n" for @created; -The following keys are recognised as parameters to C. The function returns the list of files actually created during the call. +=head3 C + +The C routine will recognise a final hashref in the +same manner as C. If no hashref is present, the +parameters are interpreted according to the traditional interface +(see below). + my @created = mkpath( qw(/tmp /flub /home/nobody), {verbose => 1, mode => 0750}, ); print "created $_\n" for @created; +The function returns the list of directories actually created during +the call. + +The following keys are recognised: + =over 4 =item mode @@ -464,8 +496,24 @@ in an C block. =back +=head3 C + +The C routine accepts a list of directories to be +removed. Its behaviour may be tuned by an optional hashref +appearing as the last parameter on the call. + + remove_tree( 'this/dir', 'that/dir' ); + =head3 C +The C routine will recognise a final hashref in the +same manner as C. If no hashref is present, the +parameters are interpreted according to the traditional interface. + + rmtree( 'mydir', 1 ); # traditional + rmtree( ['mydir'], 1 ); # traditional + rmtree( 'mydir', 1, {verbose => 0} ); # modern + =over 4 =item verbose @@ -488,7 +536,7 @@ When set to a true value, will cause all files and subdirectories to be removed, except the initially specified directories. This comes in handy when cleaning out an application's scratch directory. - rmtree( '/tmp', {keep_root => 1} ); + remove_tree( '/tmp', {keep_root => 1} ); =item result @@ -497,7 +545,7 @@ be used to store the list of all files and directories unlinked during the call. If nothing is unlinked, a reference to an empty list is returned (rather than C). - rmtree( '/tmp', {result => \my $list} ); + remove_tree( '/tmp', {result => \my $list} ); print "unlinked $_\n" for @$list; This is a useful alternative to the C key. @@ -524,6 +572,11 @@ of hand. This is the safest course of action. The old interfaces of C and C take a reference to a list of directories (to create or remove), followed by a series of positional, numeric, modal parameters that control their behaviour. +If only one directory is being created or removed, a simple scalar +may be used instead of the reference. + + rmtree( ['dir1', 'dir2'], 0, 1 ); + rmtree( 'dir3', 1, 1 ); This design made it difficult to add additional functionality, as well as posed the problem of what to do when the calling code only @@ -561,13 +614,13 @@ the numeric mode to use when creating the directories (defaults to =back -It returns a list of all directories (including intermediates, determined -using the Unix '/' separator) created. In scalar context it returns -the number of directories created. +It returns a list of all directories (including intermediates, +determined using the Unix '/' separator) created. In scalar context +it returns the number of directories created. If a system error prevents a directory from being created, then the -C function throws a fatal error with C. This error -can be trapped with an C block: +C function throws a fatal error with C. This +error can be trapped with an C block: eval { mkpath($dir) }; if ($@) { @@ -602,8 +655,8 @@ other than VMS is settled. (defaults to FALSE) =back -It returns the number of files, directories and symlinks successfully -deleted. Symlinks are simply deleted and not followed. +C returns the number of files, directories and symlinks +successfully deleted. Symlinks are simply deleted and not followed. Note also that the occurrence of errors in C using the traditional interface can be determined I by trapping diagnostic @@ -611,6 +664,9 @@ messages using C<$SIG{__WARN__}>; it is not apparent from the return value. (The modern interface may use the C parameter to record any problems encountered). +It is not possible to invoke the C functionality through +the traditional interface. + =head2 ERROR HANDLING If C or C encounter an error, a diagnostic message @@ -624,7 +680,7 @@ references. For each hash reference, the key is the name of the file, and the value is the error message (usually the contents of C<$!>). An example usage looks like: - rmpath( 'foo/bar', 'bar/rat', {error => \my $err} ); + remove_tree( 'foo/bar', 'bar/rat', {error => \my $err} ); for my $diag (@$err) { my ($file, $message) = each %$diag; print "problem unlinking $file: $message\n"; @@ -636,7 +692,7 @@ is encountered (for instance, C attempts to remove a directory tree that does not exist), the diagnostic key will be empty, only the value will be set: - rmpath( '/no/such/path', {error => \my $err} ); + remove_tree( '/no/such/path', {error => \my $err} ); for my $diag (@$err) { my ($file, $message) = each %$diag; if ($file eq '') { @@ -653,38 +709,18 @@ invited to specify what it is you are expecting to use: use File::Path 'rmtree'; -=head3 HEURISTICS - -The functions detect (as far as possible) which way they are being -called and will act appropriately. It is important to remember that -the heuristic for detecting the old style is either the presence -of an array reference, or two or three parameters total and second -and third parameters are numeric. Hence... - - mkpath 486, 487, 488; - -... will not assume the modern style and create three directories, rather -it will create one directory verbosely, setting the permission to -0750 (488 being the decimal equivalent of octal 750). Here, old -style trumps new. It must, for backwards compatibility reasons. +The routines C and C are B exported +by default. You must specify which ones you want to use. -If you want to ensure there is absolutely no ambiguity about which -way the function will behave, make sure the first parameter is a -reference to a one-element list, to force the old style interpretation: + use File::Path 'remove_tree'; - mkpath [486], 487, 488; +Note that a side-effect of the above is that C and C +are no longer exported at all. This is due to the way the C +module works. If you are migrating a codebase to use the new +interface, you will have to list everything explicitly. But that's +just good practice anyway. -and get only one directory created. Or add a reference to an empty -parameter hash, to force the new style: - - mkpath 486, 487, 488, {}; - -... and hence create the three directories. If the empty hash -reference seems a little strange to your eyes, or you suspect a -subsequent programmer might I optimise it away, you -can add a parameter set to a default value: - - mkpath 486, 487, 488, {verbose => 0}; + use File::Path qw(remove_tree rmtree); =head3 SECURITY CONSIDERATIONS @@ -757,7 +793,7 @@ begin deleting the objects therein, but was unsuccessful. This is usually a permissions issue. The routine will continue to delete other things, but this directory will be left intact. -=item directory [dir] changed before chdir, expected dev=[n] inode=[n], actual dev=[n] ino=[n], aborting. (FATAL) +=item directory [dir] changed before chdir, expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL) C recorded the device and inode of a directory, and then moved into it. It then performed a C on the current directory @@ -786,11 +822,20 @@ C, 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 +and you are attempting to remove an ancestor, such as F. +The directory tree is left untouched. + +The solution is to C 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, after having deleted everything and restored the permissions -of a directory, was unable to chdir back to the parent. This is usually -a sign that something evil this way comes. +of a directory, was unable to chdir back to the parent. The program +halts to avoid a race condition from occurring. =item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL) @@ -799,7 +844,7 @@ from the child. Since there is no way of knowing if we returned to where we think we should be (by comparing device and inode) the only way out is to C. -=item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] inode=[n], actual dev=[n] ino=[n], aborting. (FATAL) +=item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL) When C returned from deleting files in a child directory, a check revealed that the parent directory it returned to wasn't the one @@ -881,14 +926,13 @@ are greatly appreciated. =head1 AUTHORS -Tim Bunce > and Charles Bailey ->. Currently maintained by David Landgren +Tim Bunce and Charles Bailey. Currently maintained by David Landgren >. =head1 COPYRIGHT This module is copyright (C) Charles Bailey, Tim Bunce and -David Landgren 1995-2007. All rights reserved. +David Landgren 1995-2008. All rights reserved. =head1 LICENSE diff --git a/lib/File/Path.t b/lib/File/Path.t index f1b5928..b66b28d 100755 --- a/lib/File/Path.t +++ b/lib/File/Path.t @@ -2,10 +2,11 @@ use strict; -use Test::More tests => 99; +use Test::More tests => 114; BEGIN { - use_ok('File::Path'); + use_ok('Cwd'); + use_ok('File::Path', qw(rmtree mkpath make_path remove_tree)); use_ok('File::Spec::Functions'); } @@ -45,7 +46,7 @@ my @dir = ( ); # create them -my @created = mkpath(@dir); +my @created = mkpath([@dir]); is(scalar(@created), 7, "created list of directories"); @@ -79,18 +80,94 @@ is(scalar(@created), 0, "Can't create a directory named ''"); my $dir; my $dir2; +sub gisle { + # background info: @_ = 1; !shift # gives '' not 0 + # Message-Id: <3C820CE6-4400-4E91-AF43-A3D19B356E68@activestate.com> + # http://www.nntp.perl.org/group/perl.perl5.porters/2008/05/msg136625.html + mkpath(shift, !shift, 0755); +} + +sub count { + opendir D, shift or return -1; + my $count = () = readdir D; + closedir D or return -1; + return $count; +} + +{ + mkdir 'solo', 0755; + chdir 'solo'; + my $before = count(curdir()); + cmp_ok($before, '>', 0, "baseline $before"); + + gisle('1st', 1); + is(count(curdir()), $before + 1, "first after $before"); + + $before = count(curdir()); + gisle('2nd', 1); + is(count(curdir()), $before + 1, "second after $before"); + + chdir updir(); + rmtree 'solo'; +} + +{ + mkdir 'solo', 0755; + chdir 'solo'; + my $before = count(curdir()); + cmp_ok($before, '>', 0, "ARGV $before"); + { + local @ARGV = (1); + mkpath('3rd', !shift, 0755); + } + is(count(curdir()), $before + 1, "third after $before"); + + $before = count(curdir()); + { + local @ARGV = (1); + mkpath('4th', !shift, 0755); + } + is(count(curdir()), $before + 1, "fourth after $before"); + + chdir updir(); + rmtree 'solo'; +} + SKIP: { - $dir = catdir($tmp_base, 'B'); - $dir2 = catdir($dir, updir()); - # IOW: File::Spec->catdir( qw(foo bar), File::Spec->updir ) eq 'foo' - # rather than foo/bar/.. - skip "updir() canonicalises path on this platform", 2 - if $dir2 eq $tmp_base - or $^O eq 'cygwin'; + # 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'); - @created = mkpath($dir2, {mask => 0700}); - is(scalar(@created), 1, "make directory with trailing parent segment"); - is($created[0], $dir, "made parent"); + 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}); @@ -104,7 +181,7 @@ is(scalar(@created), 0, "skipped making existing directories (old style 1)") $dir = catdir($tmp_base,'C'); # mkpath returns unix syntax filespecs on VMS $dir = VMS::Filespec::unixify($dir) if $Is_VMS; -@created = mkpath($tmp_base, $dir); +@created = make_path($tmp_base, $dir); is(scalar(@created), 1, "created directory (new style 1)"); is($created[0], $dir, "created directory (new style 1) cross-check"); @@ -115,7 +192,7 @@ is(scalar(@created), 0, "skipped making existing directories (old style 2)") $dir2 = catdir($tmp_base,'D'); # mkpath returns unix syntax filespecs on VMS $dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS; -@created = mkpath($tmp_base, $dir, $dir2); +@created = make_path($tmp_base, $dir, $dir2); is(scalar(@created), 1, "created directory (new style 2)"); is($created[0], $dir2, "created directory (new style 2) cross-check"); @@ -135,7 +212,7 @@ cmp_ok(scalar(@created), '>=', 1, "made one or more dirs because of .."); cmp_ok(scalar(@created), '<=', 2, "made less than two dirs because of .."); ok( -d catdir($tmp_base, 'Y'), "directory after parent" ); -@created = mkpath(catdir(curdir(), $tmp_base)); +@created = make_path(catdir(curdir(), $tmp_base)); is(scalar(@created), 0, "nothing created") or diag(@created); @@ -195,22 +272,22 @@ else { $dir = catdir('a', 'd1'); $dir2 = catdir('a', 'd2'); -@created = mkpath( $dir, 0, $dir2 ); +@created = make_path( $dir, 0, $dir2 ); is(scalar @created, 3, 'new-style 3 dirs created'); -$count = rmtree( $dir, 0, $dir2, ); +$count = remove_tree( $dir, 0, $dir2, ); is($count, 3, 'new-style 3 dirs removed'); -@created = mkpath( $dir, $dir2, 1 ); +@created = make_path( $dir, $dir2, 1 ); is(scalar @created, 3, 'new-style 3 dirs created (redux)'); -$count = rmtree( $dir, $dir2, 1 ); +$count = remove_tree( $dir, $dir2, 1 ); is($count, 3, 'new-style 3 dirs removed (redux)'); -@created = mkpath( $dir, $dir2 ); +@created = make_path( $dir, $dir2 ); is(scalar @created, 2, 'new-style 2 dirs created'); -$count = rmtree( $dir, $dir2 ); +$count = remove_tree( $dir, $dir2 ); is($count, 2, 'new-style 2 dirs removed'); if (chdir updir()) { @@ -220,6 +297,42 @@ else { fail("chdir parent: $!"); } +SKIP: { + # test bug http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=487319 + skip "Don't need Force_Writeable semantics on $^O", 4 + if grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2); + $dir = 'bug487319'; + $dir2 = 'bug487319-symlink'; + @created = make_path($dir, {mask => 0700}); + is(scalar @created, 1, 'bug 487319 setup'); + symlink($dir, $dir2); + ok(-e $dir2, "debian bug 487319 setup symlink") or diag($dir2); + + chmod 0500, $dir; + my $mask_initial = (stat $dir)[2]; + remove_tree($dir2); + + my $mask = (stat $dir)[2]; + is( $mask, $mask_initial, 'mask of symlink target dir unchanged (debian bug 487319)'); + + # now try a file + my $file = catfile($dir, 'file'); + open my $out, '>', $file; + close $out; + + chmod 0500, $file; + $mask_initial = (stat $file)[2]; + + my $file2 = catfile($dir, 'symlink'); + symlink($file, $file2); + remove_tree($file2); + + $mask = (stat $file)[2]; + is( $mask, $mask_initial, 'mask of symlink target file unchanged (debian bug 487319)'); + + remove_tree($dir); +} + # see what happens if a file exists where we want a directory SKIP: { my $entry = catdir($tmp_base, "file"); @@ -355,8 +468,8 @@ cannot restore permissions to \d+ for [^:]+: .* at \1 line \2}, "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" ); + stderr_is( sub { make_path() }, '', "make_path no args does not carp" ); + stderr_is( sub { remove_tree() }, '', "remove_tree no args does not carp" ); stdout_is( sub {@created = mkpath($dir, 1)},