Change 34615 by [EMAIL PROTECTED] on 2008/10/28 11:27:58
Upgrade to File::Path 2.06_06. (a diff from David via http)
Affected files ...
... //depot/perl/lib/File/Path.pm#59 edit
... //depot/perl/lib/File/Path.t#18 edit
Differences ...
==== //depot/perl/lib/File/Path.pm#59 (text) ====
Index: perl/lib/File/Path.pm
--- perl/lib/File/Path.pm#58~32305~ 2007-11-13 06:19:46.000000000 -0800
+++ perl/lib/File/Path.pm 2008-10-28 04:27:58.000000000 -0700
@@ -16,10 +16,11 @@
}
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);
[EMAIL PROTECTED] = qw(make_path remove_tree);
my $Is_VMS = $^O eq 'VMS';
my $Is_MacOS = $^O eq 'MacOS';
@@ -45,22 +46,21 @@
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 [EMAIL PROTECTED] 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 @@
$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 = [EMAIL PROTECTED];
}
return _mkpath($arg, $paths);
@@ -91,10 +87,9 @@
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 @@
return @created;
}
+sub remove_tree {
+ push @_, {} if [EMAIL PROTECTED] 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 @@
$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, [EMAIL PROTECTED]);
}
sub _rmtree {
@@ -196,14 +213,6 @@
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 @@
}
}
- 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 @@
# 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, [EMAIL PROTECTED]);
}
@@ -304,11 +313,11 @@
# 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 @@
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 @@
}
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 @@
}
}
}
-
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 @@
=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 @@
The C<mkpath> function provides a convenient way to create directories
of arbitrary depth. Similarly, the C<rmtree> function provides a
convenient way to delete an entire directory subtree from the
-filesystem, much like the Unix command C<rm -r>.
+filesystem, much like the Unix command C<rm -r> or C<del /s> 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<make_path> and C<remove_tree>
+that perform the same task and offer a more intuitive interface.
=head2 FUNCTIONS
The modern way of calling C<mkpath> and C<rmtree> 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<mkpath>
+=head3 C<make_path>
+
+The C<make_path> 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<mkpath>.
The function returns the list of files actually created during the
call.
+=head3 C<mkpath>
+
+The C<mkpath> routine will recognise a final hashref in the
+same manner as C<make_path>. 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 @@
=back
+=head3 C<remove_tree>
+
+The C<remove_tree> 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<rmtree>
+The C<rmtree> routine will recognise a final hashref in the
+same manner as C<remove_tree>. 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 @@
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 @@
during the call. If nothing is unlinked, a reference to an empty
list is returned (rather than C<undef>).
- rmtree( '/tmp', {result => \my $list} );
+ remove_tree( '/tmp', {result => \my $list} );
print "unlinked $_\n" for @$list;
This is a useful alternative to the C<verbose> key.
@@ -524,6 +572,11 @@
The old interfaces of C<mkpath> and C<rmtree> 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 @@
=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<mkpath> function throws a fatal error with C<Carp::croak>. This error
-can be trapped with an C<eval> block:
+C<mkpath> function throws a fatal error with C<Carp::croak>. This
+error can be trapped with an C<eval> block:
eval { mkpath($dir) };
if ($@) {
@@ -602,8 +655,8 @@
=back
-It returns the number of files, directories and symlinks successfully
-deleted. Symlinks are simply deleted and not followed.
+C<rmtree> 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<rmtree> using the
traditional interface can be determined I<only> by trapping diagnostic
@@ -611,6 +664,9 @@
value. (The modern interface may use the C<error> parameter to
record any problems encountered).
+It is not possible to invoke the C<keep_root> functionality through
+the traditional interface.
+
=head2 ERROR HANDLING
If C<mkpath> or C<rmtree> encounter an error, a diagnostic message
@@ -624,7 +680,7 @@
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 @@
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 @@
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<make_path> and C<remove_tree> are B<not> 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<mkpath> and C<rmtree>
+are no longer exported at all. This is due to the way the C<Exporter>
+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<helpfully> 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 @@
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<rmtree> recorded the device and inode of a directory, and then
moved into it. It then performed a C<stat> on the current directory
@@ -786,11 +822,20 @@
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</some/path/to/here>
+and you are attempting to remove an ancestor, such as F</some/path>.
+The directory tree is left untouched.
+
+The solution is to C<chdir> 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<rmtree>, 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 @@
where we think we should be (by comparing device and inode) the only
way out is to C<croak>.
-=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<rmtree> 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 @@
=head1 AUTHORS
-Tim Bunce <F<[EMAIL PROTECTED]>> and Charles Bailey
-<F<[EMAIL PROTECTED]>>. Currently maintained by David Landgren
+Tim Bunce and Charles Bailey. Currently maintained by David Landgren
<F<[EMAIL PROTECTED]>>.
=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
==== //depot/perl/lib/File/Path.t#18 (xtext) ====
Index: perl/lib/File/Path.t
--- perl/lib/File/Path.t#17~32305~ 2007-11-13 06:19:46.000000000 -0800
+++ perl/lib/File/Path.t 2008-10-28 04:27:58.000000000 -0700
@@ -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 @@
);
# create them
-my @created = mkpath(@dir);
+my @created = mkpath([EMAIL PROTECTED]);
is(scalar(@created), 7, "created list of directories");
@@ -79,18 +80,94 @@
my $dir;
my $dir2;
+sub gisle {
+ # background info: @_ = 1; !shift # gives '' not 0
+ # Message-Id: <[EMAIL PROTECTED]>
+ # 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 @@
$dir = catdir($tmp_base,'C');
# mkpath returns unix syntax filespecs on VMS
$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
[EMAIL PROTECTED] = mkpath($tmp_base, $dir);
[EMAIL PROTECTED] = 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 @@
$dir2 = catdir($tmp_base,'D');
# mkpath returns unix syntax filespecs on VMS
$dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS;
[EMAIL PROTECTED] = mkpath($tmp_base, $dir, $dir2);
[EMAIL PROTECTED] = 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), '<=', 2, "made less than two dirs because of ..");
ok( -d catdir($tmp_base, 'Y'), "directory after parent" );
[EMAIL PROTECTED] = mkpath(catdir(curdir(), $tmp_base));
[EMAIL PROTECTED] = make_path(catdir(curdir(), $tmp_base));
is(scalar(@created), 0, "nothing created")
or diag(@created);
@@ -195,22 +272,22 @@
$dir = catdir('a', 'd1');
$dir2 = catdir('a', 'd2');
[EMAIL PROTECTED] = mkpath( $dir, 0, $dir2 );
[EMAIL PROTECTED] = 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');
[EMAIL PROTECTED] = mkpath( $dir, $dir2, 1 );
[EMAIL PROTECTED] = 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)');
[EMAIL PROTECTED] = mkpath( $dir, $dir2 );
[EMAIL PROTECTED] = 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 @@
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 @@
"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 [EMAIL PROTECTED] = mkpath($dir, 1)},
End of Patch.
