- use a better BuildRoot - drop a redundant mkdir in %%install - call patchlevel.h only once; rm patchlevel.bak - update modules Sys::Syslog, Module::Load::Conditional, Module::CoreList, Test::Harness, Test::Simple, CGI.pm (dropping the upstreamed patch), File::Path (that includes our perl-5.10.0-CVE-2008-2827.patch), constant, Pod::Simple, Archive::Tar, Archive::Extract, File::Fetch, File::Temp, IPC::Cmd, Time::HiRes, Module::Build, ExtUtils::CBuilder - standardize the patches for updating embedded modules - work around a bug in Module::Build tests bu setting TMPDIR to a directory inside the source tree
1216 lines
42 KiB
Diff
1216 lines
42 KiB
Diff
File-Path-2.07
|
|
|
|
diff -urN perl-5.10.0.orig/lib/File/Path.pm perl-5.10.0/lib/File/Path.pm
|
|
--- perl-5.10.0.orig/lib/File/Path.pm 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/File/Path.pm 2009-02-17 14:50:05.000000000 +0100
|
|
@@ -16,13 +16,14 @@
|
|
}
|
|
|
|
use Exporter ();
|
|
-use vars qw($VERSION @ISA @EXPORT);
|
|
-$VERSION = '2.04';
|
|
-@ISA = qw(Exporter);
|
|
-@EXPORT = qw(mkpath rmtree);
|
|
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
|
|
+$VERSION = '2.07';
|
|
+@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';
|
|
+my $Is_VMS = $^O eq 'VMS';
|
|
+my $Is_MacOS = $^O eq 'MacOS';
|
|
|
|
# These OSes complain if you want to remove a file that you have no
|
|
# write permission to:
|
|
@@ -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 @_, {} unless @_ 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 = !(@_ and UNIVERSAL::isa($_[-1],'HASH'));
|
|
|
|
my $arg;
|
|
my $paths;
|
|
@@ -69,19 +69,14 @@
|
|
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;
|
|
+ $arg->{verbose} = $verbose;
|
|
+ $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->{mode} = 0777 unless exists $arg->{mode};
|
|
- ${$arg->{error}} = [] if exists $arg->{error};
|
|
- }
|
|
- else {
|
|
- @{$arg}{qw(verbose mode)} = (0, 0777);
|
|
- }
|
|
+ $arg = pop @_;
|
|
+ $arg->{mode} = delete $arg->{mask} if exists $arg->{mask};
|
|
+ $arg->{mode} = 0777 unless exists $arg->{mode};
|
|
+ ${$arg->{error}} = [] if exists $arg->{error};
|
|
$paths = [@_];
|
|
}
|
|
return _mkpath($arg, $paths);
|
|
@@ -91,10 +86,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 +123,13 @@
|
|
return @created;
|
|
}
|
|
|
|
+sub remove_tree {
|
|
+ push @_, {} unless @_ 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 = !(@_ and UNIVERSAL::isa($_[-1],'HASH'));
|
|
|
|
my $arg;
|
|
my $paths;
|
|
@@ -145,7 +137,7 @@
|
|
if ($old_style) {
|
|
my ($verbose, $safe);
|
|
($paths, $verbose, $safe) = @_;
|
|
- $arg->{verbose} = defined $verbose ? $verbose : 0;
|
|
+ $arg->{verbose} = $verbose;
|
|
$arg->{safe} = defined $safe ? $safe : 0;
|
|
|
|
if (defined($paths) and length($paths)) {
|
|
@@ -157,32 +149,55 @@
|
|
}
|
|
}
|
|
else {
|
|
- 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 = pop @_;
|
|
+ ${$arg->{error}} = [] if exists $arg->{error};
|
|
+ ${$arg->{result}} = [] if exists $arg->{result};
|
|
$paths = [@_];
|
|
}
|
|
|
|
$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};
|
|
+ my $ortho_root_length = length($ortho_root);
|
|
+ $ortho_root_length-- if $^O eq 'VMS'; # don't compare '.' with ']'
|
|
+ if ($ortho_root_length
|
|
+ && (substr($ortho_root, 0, $ortho_root_length)
|
|
+ eq substr($ortho_cwd, 0, $ortho_root_length))) {
|
|
+ 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 +211,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 +241,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 +294,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, \@files);
|
|
}
|
|
|
|
@@ -304,11 +311,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,10 +323,8 @@
|
|
print "skipped $root\n" if $arg->{verbose};
|
|
next ROOT_DIR;
|
|
}
|
|
- if (!chmod $perm | 0700, $root) {
|
|
- if ($Force_Writeable) {
|
|
- _error($arg, "cannot make directory writeable", $canon);
|
|
- }
|
|
+ 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) {
|
|
@@ -338,7 +343,7 @@
|
|
else {
|
|
# not a directory
|
|
$root = VMS::Filespec::vmsify("./$root")
|
|
- if $Is_VMS
|
|
+ if $Is_VMS
|
|
&& !File::Spec->file_name_is_absolute($root)
|
|
&& ($root !~ m/(?<!\^)[\]>]+/); # not already in VMS syntax
|
|
|
|
@@ -351,10 +356,8 @@
|
|
}
|
|
|
|
my $nperm = $perm & 07777 | 0600;
|
|
- if ($nperm != $perm and not chmod $nperm, $root) {
|
|
- if ($Force_Writeable) {
|
|
- _error($arg, "cannot make file writeable", $canon);
|
|
- }
|
|
+ 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
|
|
@@ -373,10 +376,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,59 +396,65 @@
|
|
|
|
=head1 VERSION
|
|
|
|
-This document describes version 2.04 of File::Path, released
|
|
-2007-11-13.
|
|
+This document describes version 2.07 of File::Path, released
|
|
+2008-11-09.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
- use File::Path;
|
|
-
|
|
- # modern
|
|
- mkpath( 'foo/bar/baz', '/zug/zwang', {verbose => 1} );
|
|
+ use File::Path qw(make_path remove_tree);
|
|
|
|
- rmtree(
|
|
- 'foo/bar/baz', '/zug/zwang',
|
|
- { verbose => 1, error => \my $err_list }
|
|
- );
|
|
-
|
|
- # traditional
|
|
- mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
|
|
- rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
|
|
+ make_path('foo/bar/baz', '/zug/zwang');
|
|
+ make_path('foo/bar/baz', '/zug/zwang', {
|
|
+ verbose => 1,
|
|
+ mode => 0711,
|
|
+ });
|
|
+
|
|
+ remove_tree('foo/bar/baz', '/zug/zwang');
|
|
+ remove_tree('foo/bar/baz', '/zug/zwang', {
|
|
+ verbose => 1,
|
|
+ error => \my $err_list,
|
|
+ });
|
|
+
|
|
+ # legacy (interface promoted before v2.00)
|
|
+ mkpath('/foo/bar/baz');
|
|
+ mkpath('/foo/bar/baz', 1, 0711);
|
|
+ mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
|
|
+ rmtree('foo/bar/baz', 1, 1);
|
|
+ rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
|
|
+
|
|
+ # legacy (interface promoted before v2.06)
|
|
+ mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 });
|
|
+ rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 });
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
-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>.
|
|
-
|
|
-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.
|
|
-
|
|
-=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.
|
|
-
|
|
-=head3 C<mkpath>
|
|
-
|
|
-The following keys are recognised as parameters to C<mkpath>.
|
|
-The function returns the list of files actually created during the
|
|
-call.
|
|
-
|
|
- my @created = mkpath(
|
|
- qw(/tmp /flub /home/nobody),
|
|
- {verbose => 1, mode => 0750},
|
|
- );
|
|
- print "created $_\n" for @created;
|
|
+This module provide a convenient way to create directories of
|
|
+arbitrary depth and to delete an entire directory subtree from the
|
|
+filesystem.
|
|
|
|
-=over 4
|
|
+The following functions are provided:
|
|
+
|
|
+=over
|
|
+
|
|
+=item make_path( $dir1, $dir2, .... )
|
|
|
|
-=item mode
|
|
+=item make_path( $dir1, $dir2, ...., \%opts )
|
|
+
|
|
+The C<make_path> function creates the given directories if they don't
|
|
+exists before, much like the Unix command C<mkdir -p>.
|
|
+
|
|
+The function 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.
|
|
+
|
|
+The function returns the list of directories actually created during
|
|
+the call; in scalar context the number of directories created.
|
|
+
|
|
+The following keys are recognised in the option hash:
|
|
+
|
|
+=over
|
|
+
|
|
+=item mode => $num
|
|
|
|
The numeric permissions mode to apply to each created directory
|
|
(defaults to 0777), to be modified by the current C<umask>. If the
|
|
@@ -447,16 +463,17 @@
|
|
|
|
C<mask> is recognised as an alias for this parameter.
|
|
|
|
-=item verbose
|
|
+=item verbose => $bool
|
|
|
|
-If present, will cause C<mkpath> to print the name of each directory
|
|
+If present, will cause C<make_path> to print the name of each directory
|
|
as it is created. By default nothing is printed.
|
|
|
|
-=item error
|
|
+=item error => \$err
|
|
|
|
-If present, will be interpreted as a reference to a list, and will
|
|
-be used to store any errors that are encountered. See the ERROR
|
|
-HANDLING section for more information.
|
|
+If present, it should be a reference to a scalar.
|
|
+This scalar will be made to reference an array, which will
|
|
+be used to store any errors that are encountered. See the L</"ERROR
|
|
+HANDLING"> section for more information.
|
|
|
|
If this parameter is not used, certain error conditions may raise
|
|
a fatal error that will cause the program will halt, unless trapped
|
|
@@ -464,53 +481,80 @@
|
|
|
|
=back
|
|
|
|
-=head3 C<rmtree>
|
|
+=item mkpath( $dir )
|
|
|
|
-=over 4
|
|
+=item mkpath( $dir, $verbose, $mode )
|
|
+
|
|
+=item mkpath( [$dir1, $dir2,...], $verbose, $mode )
|
|
+
|
|
+=item mkpath( $dir1, $dir2,..., \%opt )
|
|
+
|
|
+The mkpath() function provide the legacy interface of make_path() with
|
|
+a different interpretation of the arguments passed. The behaviour and
|
|
+return value of the function is otherwise identical to make_path().
|
|
|
|
-=item verbose
|
|
+=item remove_tree( $dir1, $dir2, .... )
|
|
|
|
-If present, will cause C<rmtree> to print the name of each file as
|
|
+=item remove_tree( $dir1, $dir2, ...., \%opts )
|
|
+
|
|
+The C<remove_tree> function deletes the given directories and any
|
|
+files and subdirectories they might contain, much like the Unix
|
|
+command C<rm -r> or C<del /s> on Windows.
|
|
+
|
|
+The function 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.
|
|
+
|
|
+The functions returns the number of files successfully deleted.
|
|
+
|
|
+The following keys are recognised in the option hash:
|
|
+
|
|
+=over
|
|
+
|
|
+=item verbose => $bool
|
|
+
|
|
+If present, will cause C<remove_tree> to print the name of each file as
|
|
it is unlinked. By default nothing is printed.
|
|
|
|
-=item safe
|
|
+=item safe => $bool
|
|
|
|
-When set to a true value, will cause C<rmtree> to skip the files
|
|
+When set to a true value, will cause C<remove_tree> to skip the files
|
|
for which the process lacks the required privileges needed to delete
|
|
files, such as delete privileges on VMS. In other words, the code
|
|
will make no attempt to alter file permissions. Thus, if the process
|
|
is interrupted, no filesystem object will be left in a more
|
|
permissive mode.
|
|
|
|
-=item keep_root
|
|
+=item keep_root => $bool
|
|
|
|
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
|
|
+=item result => \$res
|
|
|
|
-If present, will be interpreted as a reference to a list, and will
|
|
-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<undef>).
|
|
+If present, it should be a reference to a scalar.
|
|
+This scalar will be made to reference an array, which will
|
|
+be used to store all files and directories unlinked
|
|
+during the call. If nothing is unlinked, the array will be empty.
|
|
|
|
- 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.
|
|
|
|
-=item error
|
|
+=item error => \$err
|
|
|
|
-If present, will be interpreted as a reference to a list,
|
|
-and will be used to store any errors that are encountered.
|
|
-See the ERROR HANDLING section for more information.
|
|
+If present, it should be a reference to a scalar.
|
|
+This scalar will be made to reference an array, which will
|
|
+be used to store any errors that are encountered. See the L</"ERROR
|
|
+HANDLING"> section for more information.
|
|
|
|
Removing things is a much more dangerous proposition than
|
|
creating things. As such, there are certain conditions that
|
|
-C<rmtree> may encounter that are so dangerous that the only
|
|
+C<remove_tree> may encounter that are so dangerous that the only
|
|
sane action left is to kill the program.
|
|
|
|
Use C<error> to trap all that is reasonable (problems with
|
|
@@ -519,131 +563,67 @@
|
|
|
|
=back
|
|
|
|
-=head2 TRADITIONAL INTERFACE
|
|
-
|
|
-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.
|
|
-
|
|
-This design made it difficult to add additional functionality, as
|
|
-well as posed the problem of what to do when the calling code only
|
|
-needs to set the last parameter. Even though the code doesn't care
|
|
-how the initial positional parameters are set, the programmer is
|
|
-forced to learn what the defaults are, and specify them.
|
|
-
|
|
-Worse, if it turns out in the future that it would make more sense
|
|
-to change the default behaviour of the first parameter (for example,
|
|
-to avoid a security vulnerability), all existing code will remain
|
|
-hard-wired to the wrong defaults.
|
|
-
|
|
-Finally, a series of numeric parameters are much less self-documenting
|
|
-in terms of communicating to the reader what the code is doing. Named
|
|
-parameters do not have this problem.
|
|
-
|
|
-In the traditional API, C<mkpath> takes three arguments:
|
|
-
|
|
-=over 4
|
|
-
|
|
-=item *
|
|
-
|
|
-The name of the path to create, or a reference to a list of paths
|
|
-to create,
|
|
+=item rmtree( $dir )
|
|
|
|
-=item *
|
|
+=item rmtree( $dir, $verbose, $safe )
|
|
|
|
-a boolean value, which if TRUE will cause C<mkpath> to print the
|
|
-name of each directory as it is created (defaults to FALSE), and
|
|
+=item rmtree( [$dir1, $dir2,...], $verbose, $safe )
|
|
|
|
-=item *
|
|
+=item rmtree( $dir1, $dir2,..., \%opt )
|
|
|
|
-the numeric mode to use when creating the directories (defaults to
|
|
-0777), to be modified by the current umask.
|
|
+The rmtree() function provide the legacy interface of remove_tree()
|
|
+with a different interpretation of the arguments passed. The behaviour
|
|
+and return value of the function is otherwise identical to
|
|
+remove_tree().
|
|
|
|
=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.
|
|
-
|
|
-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:
|
|
-
|
|
- eval { mkpath($dir) };
|
|
- if ($@) {
|
|
- print "Couldn't create $dir: $@";
|
|
- }
|
|
-
|
|
-In the traditional API, C<rmtree> takes three arguments:
|
|
+=head2 ERROR HANDLING
|
|
|
|
=over 4
|
|
|
|
-=item *
|
|
+=item B<NOTE:>
|
|
|
|
-the root of the subtree to delete, or a reference to a list of
|
|
-roots. All of the files and directories below each root, as well
|
|
-as the roots themselves, will be deleted. If you want to keep
|
|
-the roots themselves, you must use the modern API.
|
|
-
|
|
-=item *
|
|
-
|
|
-a boolean value, which if TRUE will cause C<rmtree> to print a
|
|
-message each time it examines a file, giving the name of the file,
|
|
-and indicating whether it's using C<rmdir> or C<unlink> to remove
|
|
-it, or that it's skipping it. (defaults to FALSE)
|
|
-
|
|
-=item *
|
|
-
|
|
-a boolean value, which if TRUE will cause C<rmtree> to skip any
|
|
-files to which you do not have delete access (if running under VMS)
|
|
-or write access (if running under another OS). This will change
|
|
-in the future when a criterion for 'delete permission' under OSs
|
|
-other than VMS is settled. (defaults to FALSE)
|
|
+The following error handling mechanism is considered
|
|
+experimental and is subject to change pending feedback from
|
|
+users.
|
|
|
|
=back
|
|
|
|
-It 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
|
|
-messages using C<$SIG{__WARN__}>; it is not apparent from the return
|
|
-value. (The modern interface may use the C<error> parameter to
|
|
-record any problems encountered).
|
|
-
|
|
-=head2 ERROR HANDLING
|
|
-
|
|
-If C<mkpath> or C<rmtree> encounter an error, a diagnostic message
|
|
-will be printed to C<STDERR> via C<carp> (for non-fatal errors),
|
|
-or via C<croak> (for fatal errors).
|
|
+If C<make_path> or C<remove_tree> encounter an error, a diagnostic
|
|
+message will be printed to C<STDERR> via C<carp> (for non-fatal
|
|
+errors), or via C<croak> (for fatal errors).
|
|
|
|
If this behaviour is not desirable, the C<error> attribute may be
|
|
used to hold a reference to a variable, which will be used to store
|
|
-the diagnostics. The result is a reference to a list of hash
|
|
-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} );
|
|
- for my $diag (@$err) {
|
|
- my ($file, $message) = each %$diag;
|
|
- print "problem unlinking $file: $message\n";
|
|
+the diagnostics. The variable is made a reference to an array of hash
|
|
+references. Each hash contain a single key/value pair where the key
|
|
+is the name of the file, and the value is the error message (including
|
|
+the contents of C<$!> when appropriate). If a general error is
|
|
+encountered the diagnostic key will be empty.
|
|
+
|
|
+An example usage looks like:
|
|
+
|
|
+ remove_tree( 'foo/bar', 'bar/rat', {error => \my $err} );
|
|
+ if (@$err) {
|
|
+ for my $diag (@$err) {
|
|
+ my ($file, $message) = %$diag;
|
|
+ if ($file eq '') {
|
|
+ print "general error: $message\n";
|
|
+ }
|
|
+ else {
|
|
+ print "problem unlinking $file: $message\n";
|
|
+ }
|
|
+ }
|
|
}
|
|
-
|
|
-If no errors are encountered, C<$err> will point to an empty list
|
|
-(thus there is no need to test for C<undef>). If a general error
|
|
-is encountered (for instance, C<rmtree> 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} );
|
|
- for my $diag (@$err) {
|
|
- my ($file, $message) = each %$diag;
|
|
- if ($file eq '') {
|
|
- print "general error: $message\n";
|
|
- }
|
|
+ else {
|
|
+ print "No error encountered\n";
|
|
}
|
|
|
|
+Note that if no errors are encountered, C<$err> will reference an
|
|
+empty array. This means that C<$err> will always end up TRUE; so you
|
|
+need to test C<@$err> to determine if errors occured.
|
|
+
|
|
=head2 NOTES
|
|
|
|
C<File::Path> blindly exports C<mkpath> and C<rmtree> into the
|
|
@@ -653,38 +633,18 @@
|
|
|
|
use File::Path 'rmtree';
|
|
|
|
-=head3 HEURISTICS
|
|
+The routines C<make_path> and C<remove_tree> are B<not> exported
|
|
+by default. You must specify which ones you want to use.
|
|
|
|
-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...
|
|
+ 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.
|
|
|
|
-... 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.
|
|
-
|
|
-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:
|
|
-
|
|
- mkpath [486], 487, 488;
|
|
-
|
|
-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
|
|
|
|
@@ -701,7 +661,7 @@
|
|
|
|
Additionally, unless the C<safe> parameter is set (or the
|
|
third parameter in the traditional interface is TRUE), should a
|
|
-C<rmtree> be interrupted, files that were originally in read-only
|
|
+C<remove_tree> be interrupted, files that were originally in read-only
|
|
mode may now have their permissions set to a read-write (or "delete
|
|
OK") mode.
|
|
|
|
@@ -723,43 +683,43 @@
|
|
|
|
=item mkdir [path]: [errmsg] (SEVERE)
|
|
|
|
-C<mkpath> was unable to create the path. Probably some sort of
|
|
+C<make_path> was unable to create the path. Probably some sort of
|
|
permissions error at the point of departure, or insufficient resources
|
|
(such as free inodes on Unix).
|
|
|
|
=item No root path(s) specified
|
|
|
|
-C<mkpath> was not given any paths to create. This message is only
|
|
+C<make_path> was not given any paths to create. This message is only
|
|
emitted if the routine is called with the traditional interface.
|
|
The modern interface will remain silent if given nothing to do.
|
|
|
|
=item No such file or directory
|
|
|
|
-On Windows, if C<mkpath> gives you this warning, it may mean that
|
|
+On Windows, if C<make_path> gives you this warning, it may mean that
|
|
you have exceeded your filesystem's maximum path length.
|
|
|
|
=item cannot fetch initial working directory: [errmsg]
|
|
|
|
-C<rmtree> attempted to determine the initial directory by calling
|
|
+C<remove_tree> attempted to determine the initial directory by calling
|
|
C<Cwd::getcwd>, but the call failed for some reason. No attempt
|
|
will be made to delete anything.
|
|
|
|
=item cannot stat initial working directory: [errmsg]
|
|
|
|
-C<rmtree> attempted to stat the initial directory (after having
|
|
+C<remove_tree> attempted to stat the initial directory (after having
|
|
successfully obtained its name via C<getcwd>), however, the call
|
|
failed for some reason. No attempt will be made to delete anything.
|
|
|
|
=item cannot chdir to [dir]: [errmsg]
|
|
|
|
-C<rmtree> attempted to set the working directory in order to
|
|
+C<remove_tree> attempted to set the working directory in order to
|
|
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<rmtree> recorded the device and inode of a directory, and then
|
|
+C<remove_tree> recorded the device and inode of a directory, and then
|
|
moved into it. It then performed a C<stat> on the current directory
|
|
and detected that the device and inode were no longer the same. As
|
|
this is at the heart of the race condition problem, the program
|
|
@@ -767,14 +727,14 @@
|
|
|
|
=item cannot make directory [dir] read+writeable: [errmsg]
|
|
|
|
-C<rmtree> attempted to change the permissions on the current directory
|
|
+C<remove_tree> attempted to change the permissions on the current directory
|
|
to ensure that subsequent unlinkings would not run into problems,
|
|
but was unable to do so. The permissions remain as they were, and
|
|
the program will carry on, doing the best it can.
|
|
|
|
=item cannot read [dir]: [errmsg]
|
|
|
|
-C<rmtree> tried to read the contents of the directory in order
|
|
+C<remove_tree> tried to read the contents of the directory in order
|
|
to acquire the names of the directory entries to be unlinked, but
|
|
was unsuccessful. This is usually a permissions issue. The
|
|
program will continue, but the files in this directory will remain
|
|
@@ -782,61 +742,70 @@
|
|
|
|
=item cannot reset chmod [dir]: [errmsg]
|
|
|
|
-C<rmtree>, after having deleted everything in a directory, attempted
|
|
+C<remove_tree>, 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</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.
|
|
+C<remove_tree>, after having deleted everything and restored the permissions
|
|
+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)
|
|
|
|
-C<rmtree> was unable to stat the parent directory after have returned
|
|
+C<remove_tree> was unable to stat the parent directory after have returned
|
|
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<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
|
|
+When C<remove_tree> returned from deleting files in a child directory, a
|
|
check revealed that the parent directory it returned to wasn't the one
|
|
it started out from. This is considered a sign of malicious activity.
|
|
|
|
=item cannot make directory [dir] writeable: [errmsg]
|
|
|
|
Just before removing a directory (after having successfully removed
|
|
-everything it contained), C<rmtree> attempted to set the permissions
|
|
+everything it contained), C<remove_tree> attempted to set the permissions
|
|
on the directory to ensure it could be removed and failed. Program
|
|
execution continues, but the directory may possibly not be deleted.
|
|
|
|
=item cannot remove directory [dir]: [errmsg]
|
|
|
|
-C<rmtree> attempted to remove a directory, but failed. This may because
|
|
+C<remove_tree> attempted to remove a directory, but failed. This may because
|
|
some objects that were unable to be removed remain in the directory, or
|
|
a permissions issue. The directory will be left behind.
|
|
|
|
=item cannot restore permissions of [dir] to [0nnn]: [errmsg]
|
|
|
|
-After having failed to remove a directory, C<rmtree> was unable to
|
|
+After having failed to remove a directory, C<remove_tree> was unable to
|
|
restore its permissions from a permissive state back to a possibly
|
|
more restrictive setting. (Permissions given in octal).
|
|
|
|
=item cannot make file [file] writeable: [errmsg]
|
|
|
|
-C<rmtree> attempted to force the permissions of a file to ensure it
|
|
+C<remove_tree> attempted to force the permissions of a file to ensure it
|
|
could be deleted, but failed to do so. It will, however, still attempt
|
|
to unlink the file.
|
|
|
|
=item cannot unlink file [file]: [errmsg]
|
|
|
|
-C<rmtree> failed to remove a file. Probably a permissions issue.
|
|
+C<remove_tree> 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<rmtree> was also unable
|
|
+After having failed to remove a file, C<remove_tree> was also unable
|
|
to restore the permissions on the file to a possibly less permissive
|
|
setting. (Permissions given in octal).
|
|
|
|
@@ -879,16 +848,18 @@
|
|
That code was used as a basis for the current code. Their efforts
|
|
are greatly appreciated.
|
|
|
|
+Gisle Aas made a number of improvements to the documentation for
|
|
+2.07 and his advice and assistance is also greatly appreciated.
|
|
+
|
|
=head1 AUTHORS
|
|
|
|
-Tim Bunce <F<Tim.Bunce@ig.co.uk>> and Charles Bailey
|
|
-<F<bailey@newman.upenn.edu>>. Currently maintained by David Landgren
|
|
+Tim Bunce and Charles Bailey. Currently maintained by David Landgren
|
|
<F<david@landgren.net>>.
|
|
|
|
=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 -urN perl-5.10.0.orig/lib/File/Path.t perl-5.10.0/lib/File/Path.t
|
|
--- perl-5.10.0.orig/lib/File/Path.t 2007-12-18 11:47:07.000000000 +0100
|
|
+++ perl-5.10.0/lib/File/Path.t 2009-02-17 14:53:32.000000000 +0100
|
|
@@ -2,17 +2,19 @@
|
|
|
|
use strict;
|
|
|
|
-use Test::More tests => 99;
|
|
+use Test::More tests => 114;
|
|
+use Config;
|
|
|
|
BEGIN {
|
|
- use_ok('File::Path');
|
|
+ use_ok('Cwd');
|
|
+ use_ok('File::Path', qw(rmtree mkpath make_path remove_tree));
|
|
use_ok('File::Spec::Functions');
|
|
}
|
|
|
|
eval "use Test::Output";
|
|
my $has_Test_Output = $@ ? 0 : 1;
|
|
|
|
-my $Is_VMS = $^O eq 'VMS';
|
|
+my $Is_VMS = $^O eq 'VMS';
|
|
|
|
# first check for stupid permissions second for full, so we clean up
|
|
# behind ourselves
|
|
@@ -45,7 +47,7 @@
|
|
);
|
|
|
|
# create them
|
|
-my @created = mkpath(@dir);
|
|
+my @created = mkpath([@dir]);
|
|
|
|
is(scalar(@created), 7, "created list of directories");
|
|
|
|
@@ -79,18 +81,98 @@
|
|
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';
|
|
+ open my $f, '>', 'foo.dat';
|
|
+ close $f;
|
|
+ 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';
|
|
+ open my $f, '>', 'foo.dat';
|
|
+ close $f;
|
|
+ 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';
|
|
-
|
|
- @created = mkpath($dir2, {mask => 0700});
|
|
- is(scalar(@created), 1, "make directory with trailing parent segment");
|
|
- is($created[0], $dir, "made parent");
|
|
+ # 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');
|
|
+
|
|
+ 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 +186,7 @@
|
|
$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 +197,7 @@
|
|
$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");
|
|
|
|
@@ -123,8 +205,7 @@
|
|
is($count, 1, "removed directory unsafe mode");
|
|
|
|
$count = rmtree($dir2, 0, 1);
|
|
-my $removed = $Is_VMS ? 0 : 1;
|
|
-is($count, $removed, "removed directory safe mode");
|
|
+is($count, 1, "removed directory safe mode");
|
|
|
|
# mkdir foo ./E/../Y
|
|
# Y should exist
|
|
@@ -135,7 +216,7 @@
|
|
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 +276,22 @@
|
|
$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 +301,43 @@
|
|
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);
|
|
+ skip "Symlinks not available", 4 unless $Config{'d_symlink'};
|
|
+ $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");
|
|
@@ -245,6 +363,7 @@
|
|
SKIP: {
|
|
skip "extra scenarios not set up, see eg/setup-extra-tests", 14
|
|
unless -e $extra;
|
|
+ skip "Symlinks not available", 14 unless $Config{'d_symlink'};
|
|
|
|
my ($list, $err);
|
|
$dir = catdir( 'EXTRA', '1' );
|
|
@@ -355,8 +474,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 {@created = mkpath($dir, 1)},
|