=head1 NAME
-File::Path - create or remove directory trees
+File::Path - Create or remove directory trees
+
+=head1 VERSION
+
+This document describes version 2.00 of File::Path, released
+2007-xx-xx.
=head1 SYNOPSIS
use File::Path;
+ # modern
+ mkpath( 'foo/bar/baz', '/zug/zwang', {verbose => 1} );
+
+ rmtree(
+ 'foo/bar/baz', '/zug/zwang',
+ { verbose => 1, errors => \my $err_list }
+ );
+
+ # traditional
mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
=head1 DESCRIPTION
-The C<mkpath> function provides a convenient way to create directories, even
-if your C<mkdir> kernel call won't create more than one level of directory at
-a time. C<mkpath> takes three arguments:
+The C<mkpath> function provides a convenient way to create directories,
+even if your C<mkdir> kernel call won't create more than one level
+of directory at a time. Similarly, the C<rmtree> function provides
+a convenient way to delete a subtree from the directory structure,
+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 an optional
+hash reference at the end of the parameter list that holds various
+keys that can be used to control the function's behaviour, following
+a plain list of directories upon which to operate.
+
+=head3 C<mkpath>
+
+The following keys are recognised as as parameters to C<mkpath>.
+It 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;
+
+=over 4
+
+=item mode
+
+The numeric mode to use when creating the directories (defaults
+to 07777), to be modified by the current C<umask>. (C<mask> is
+recognised as an alias for this parameter).
+
+=item verbose
+
+If present, will cause C<mkpath> to print the name of each directory
+as it is created. By default nothing is printed.
+
+=item error
+
+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 below to find out more.
+
+If this parameter is not used, any errors encountered will raise a
+fatal error that need to be trapped in an C<eval> block, or the
+program will halt.
+
+=back
+
+=head3 C<rmtree>
+
+=over 4
+
+=item verbose
+
+If present, will cause C<rmtree> to print the name of each file as
+it is unlinked. By default nothing is printed.
+
+=item skip_others
+
+When set to a true value, 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.
+
+=item keep_root
+
+When set to a true value, will cause everything except the specified
+base directories to be unlinked. This comes in handy when cleaning
+out an application's scratch directory.
+
+ rmtree( '/tmp', {keep_root => 1} );
+
+=item result
+
+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>).
+
+ rmtree( '/tmp', {result => \my $list} );
+ print "unlinked $_\n" for @$list;
+
+=item error
+
+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 below to find out more.
+
+If this parameter is not used, any errors encountered will
+raise a fatal error that need to be trapped in an C<eval>
+block, or the program will halt.
+
+=back
+
+=head2 TRADITIONAL INTERFACE
+
+The old interface for 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 you don't care how the initial
+positional parameters are specified but only the last
+one needs to be specified. The calls themselves are also
+less self-documenting.
+
+C<mkpath> takes three arguments:
=over 4
=item *
-the name of the path to create, or a reference
+The name of the path to create, or a reference
to a list of paths to create,
=item *
print "Couldn't create $dir: $@";
}
-Similarly, the C<rmtree> function provides a convenient way to delete a
-subtree from the directory structure, much like the Unix command C<rm -r>.
-C<rmtree> takes three arguments:
+In the traditional form, C<rmtree> takes three arguments:
=over 4
It returns the number of files, directories and symlinks successfully
deleted. Symlinks are simply deleted and not followed.
-B<NOTE:> There are race conditions internal to the implementation of
-C<rmtree> making it unsafe to use on directory trees which may be
-altered or moved while C<rmtree> is running, and in particular on any
-directory trees with any path components or subdirectories potentially
-writable by untrusted users.
+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 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";
+ }
+
+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";
+ }
+ }
+
+=head2 NOTES
+
+=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.
-Additionally, if the third parameter is not TRUE and C<rmtree> is
-interrupted, it may leave files and directories with permissions altered
-to allow deletion (and older versions of this module would even set
-files and directories to world-read/writable!)
+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:
-Note also that the occurrence of errors in C<rmtree> can be determined I<only>
-by trapping diagnostic messages using C<$SIG{__WARN__}>; it is not apparent
-from the return value.
+ 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};
+
+=head3 RACE CONDITIONS
+
+There are race conditions internal to the implementation of C<rmtree>
+making it unsafe to use on directory trees which may be altered or
+moved while C<rmtree> is running, and in particular on any directory
+trees with any path components or subdirectories potentially writable
+by untrusted users.
+
+Additionally, if the C<skip_others> parareter is not set (or the
+third parameter in the traditional inferface is not TRUE) and
+C<rmtree> is interrupted, it may leave files and directories with
+permissions altered to allow deletion.
+
+C<File::Path> blindly exports C<mkpath> and C<rmtree> into the
+current namespace. These days, this is considered bad style, but
+to change it now would break too much code. Nonetheless, you are
+invited to specify what it is you are expecting to use:
+
+ use File::Path 'rmtree';
=head1 DIAGNOSTICS
=back
+=head1 SEE ALSO
+
+=over 4
+
+=item *
+
+L<Find::File::Rule>
+
+When removing directory trees, if you want to examine each file
+before deciding whether to deleting it (and possibly leaving large
+swathes alone), F<File::Find::Rule> offers a convenient and flexible
+approach.
+
+=back
+
+=head1 BUGS
+
+Please report all bugs on the RT queue:
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path>
+
=head1 AUTHORS
Tim Bunce <F<Tim.Bunce@ig.co.uk>> and
-Charles Bailey <F<bailey@newman.upenn.edu>>
+Charles Bailey <F<bailey@newman.upenn.edu>>.
+
+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.
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
=cut
-use 5.006;
-use File::Basename ();
-use Exporter ();
+use 5.005_04;
use strict;
-use warnings;
-our $VERSION = "1.09";
-our @ISA = qw( Exporter );
-our @EXPORT = qw( mkpath rmtree );
+use File::Basename ();
+use File::Spec ();
+BEGIN {
+ if ($] >= 5.006) {
+ eval "use warnings";
+ }
+ else {
+ # can't say 'opendir my $dh, $dirname'
+ # need to initialise $dh
+ eval "use Symbol";
+ }
+}
+
+use Exporter ();
+use vars qw($VERSION @ISA @EXPORT);
+$VERSION = '2.00';
+@ISA = qw(Exporter);
+@EXPORT = qw(mkpath rmtree);
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:
-my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' ||
+my $Force_Writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' ||
$^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc');
-sub carp {
+sub _carp {
require Carp;
goto &Carp::carp;
}
-sub croak {
+sub _croak {
require Carp;
goto &Carp::croak;
}
sub mkpath {
- my($paths, $verbose, $mode) = @_;
- # $paths -- either a path string or ref to list of paths
- # $verbose -- optional print "mkdir $path" for each directory created
- # $mode -- optional permissions, defaults to 0777
+ my $new_style = (
+ ref($_[0]) eq 'ARRAY'
+ or (@_ == 2 and $_[1] =~ /\A\d+\z/)
+ or (@_ == 3 and $_[1] =~ /\A\d+\z/ and $_[2] =~ /\A\d+\z/)
+ ) ? 0 : 1;
+
+ my $arg;
+ my $paths;
+
+ if ($new_style) {
+ if (ref $_[-1] eq '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);
+ }
+ $paths = [@_];
+ }
+ else {
+ my ($verbose, $mode);
+ ($paths, $verbose, $mode) = @_;
+ $paths = [$paths] unless ref($paths) eq 'ARRAY';
+ $arg->{verbose} = defined $verbose ? $verbose : 0;
+ $arg->{mode} = defined $mode ? $mode : 0777;
+ }
+ return _mkpath($arg, $paths);
+}
+
+sub _mkpath {
+ my $arg = shift;
+ my $paths = shift;
+
local($")=$Is_MacOS ? ":" : "/";
- $mode = 0777 unless defined($mode);
- $paths = [$paths] unless ref $paths;
my(@created,$path);
foreach $path (@$paths) {
+ next unless 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) {
next if -d $path;
my $parent = File::Basename::dirname($path);
unless (-d $parent or $path eq $parent) {
- push(@created,mkpath($parent, $verbose, $mode));
+ push(@created,_mkpath($arg, [$parent]));
+ }
+ print "mkdir $path\n" if $arg->{verbose};
+ if (mkdir($path,$arg->{mode})) {
+ push(@created, $path);
}
- print "mkdir $path\n" if $verbose;
- unless (mkdir($path,$mode)) {
- my ($e, $e1) = ($!, $^E);
+ else {
+ my $save_bang = $!;
+ my ($e, $e1) = ($save_bang, $^E);
$e .= "; $e1" if $e ne $e1;
# allow for another process to have created it meanwhile
- $! = $e, croak ("mkdir $path: $e") unless -d $path;
+ if (!-d $path) {
+ $! = $save_bang;
+ if ($arg->{error}) {
+ push @{${$arg->{error}}}, {$path => $e};
+ }
+ else {
+ _croak("mkdir $path: $e");
+ }
}
- push(@created, $path);
}
- @created;
+ }
+ return @created;
}
sub rmtree {
- my($roots, $verbose, $safe) = @_;
- my(@files);
- my($count) = 0;
- $verbose ||= 0;
- $safe ||= 0;
+ my $new_style = (
+ ref($_[0]) eq 'ARRAY'
+ or (@_ == 2 and $_[1] =~ /\A\d+\z/)
+ or (@_ == 3 and $_[1] =~ /\A\d+\z/ and $_[2] =~ /\A\d+\z/)
+ ) ? 0 : 1;
+
+ my $arg;
+ my $paths;
+
+ if ($new_style) {
+ if (ref $_[-1] eq 'HASH') {
+ $arg = pop @_;
+ ${$arg->{error}} = [] if exists $arg->{error};
+ ${$arg->{result}} = [] if exists $arg->{result};
+ }
+ else {
+ @{$arg}{qw(verbose safe)} = (0, 0);
+ }
+ $arg->{depth} = 0;
+ $paths = [@_];
+ }
+ else {
+ my ($verbose, $safe);
+ ($paths, $verbose, $safe) = @_;
+ $paths = [$paths] unless ref($paths) eq 'ARRAY';
+ $arg->{verbose} = defined $verbose ? $verbose : 0;
+ $arg->{safe} = defined $safe ? $safe : 0;
+ }
- if ( defined($roots) && length($roots) ) {
- $roots = [$roots] unless ref $roots;
+ if (@$paths < 1) {
+ if ($arg->{error}) {
+ push @{${$arg->{error}}}, {'' => "No root path(s) specified"};
}
else {
- carp ("No root path(s) specified\n");
+ _carp ("No root path(s) specified\n");
+ }
return 0;
}
+ return _rmtree($arg, $paths);
+}
- my($root);
- foreach $root (@{$roots}) {
+sub _rmtree {
+ my $arg = shift;
+ my $paths = shift;
+ my($count) = 0;
+ my (@files, $root);
+ foreach $root (@{$paths}) {
if ($Is_MacOS) {
$root = ":$root" if $root !~ /:/;
- $root =~ s#([^:])\z#$1:#;
- } else {
+ $root =~ s/([^:])\z/$1:/;
+ }
+ else {
$root =~ s#/\z##;
}
- (undef, undef, my $rp) = lstat $root or next;
+ my $rp = (lstat $root)[2] or next;
$rp &= 07777; # don't forget setuid, setgid, sticky bits
if ( -d _ ) {
# notabene: 0700 is for making readable in the first place,
# it's also intended to change it to writable in case we have
# to recurse in which case we are better than rm -rf for
# subtrees with strange permissions
- chmod($rp | 0700, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
- or carp ("Can't make directory $root read+writeable: $!")
- unless $safe;
-
- if (opendir my $d, $root) {
+ if (!chmod($rp | 0700,
+ ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
+ ) {
+ if (!$arg->{safe}) {
+ if ($arg->{error}) {
+ push @{${$arg->{error}}},
+ {$root => "Can't make directory read+writeable: $!"};
+ }
+ else {
+ _carp ("Can't make directory $root read+writeable: $!");
+ }
+ }
+ }
+
+ my $d;
+ $d = gensym() if $] < 5.006;
+ if (!opendir $d, $root) {
+ if ($arg->{error}) {
+ push @{${$arg->{error}}}, {$root => "opendir: $!"};
+ }
+ else {
+ _carp ("Can't read $root: $!");
+ }
+ @files = ();
+ }
+ else {
no strict 'refs';
if (!defined ${"\cTAINT"} or ${"\cTAINT"}) {
- # Blindly untaint dir names
- @files = map { /^(.*)$/s ; $1 } readdir $d;
- } else {
+ # Blindly untaint dir names if taint mode is
+ # active, or any perl < 5.006
+ @files = map { /\A(.*)\z/s; $1 } readdir $d;
+ }
+ else {
@files = readdir $d;
}
closedir $d;
}
- else {
- carp ("Can't read $root: $!");
- @files = ();
- }
# Deleting large numbers of files from VMS Files-11 filesystems
# is faster if done in reverse ASCIIbetical order
($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS;
if ($Is_MacOS) {
@files = map("$root$_", @files);
- } else {
- @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files);
}
- $count += rmtree(\@files,$verbose,$safe);
- if ($safe &&
+ else {
+ my $updir = File::Spec->updir();
+ my $curdir = File::Spec->curdir();
+ @files = map(File::Spec->catdir($root,$_),
+ grep {$_ ne $updir and $_ ne $curdir}
+ @files
+ );
+ }
+ $arg->{depth}++;
+ $count += _rmtree($arg, \@files);
+ $arg->{depth}--;
+ if ($arg->{depth} or !$arg->{keep_root}) {
+ if ($arg->{safe} &&
($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
- print "skipped $root\n" if $verbose;
+ print "skipped $root\n" if $arg->{verbose};
next;
}
- chmod $rp | 0700, $root
- or carp ("Can't make directory $root writeable: $!")
- if $force_writeable;
- print "rmdir $root\n" if $verbose;
+ if (!chmod $rp | 0700, $root) {
+ if ($Force_Writeable) {
+ if ($arg->{error}) {
+ push @{${$arg->{error}}},
+ {$root => "Can't make directory writeable: $!"};
+ }
+ else {
+ _carp ("Can't make directory $root writeable: $!")
+ }
+ }
+ }
+ print "rmdir $root\n" if $arg->{verbose};
if (rmdir $root) {
+ push @{${$arg->{result}}}, $root if $arg->{result};
++$count;
}
else {
- carp ("Can't remove directory $root: $!");
- chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
- or carp("and can't restore permissions to "
- . sprintf("0%o",$rp) . "\n");
+ if ($arg->{error}) {
+ push @{${$arg->{error}}}, {$root => "rmdir: $!"};
+ }
+ else {
+ _carp ("Can't remove directory $root: $!");
}
+ if (!chmod($rp,
+ ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
+ ) {
+ my $mask = sprintf("0%o",$rp);
+ if ($arg->{error}) {
+ push @{${$arg->{error}}}, {$root => "restore chmod: $!"};
}
else {
- if ($safe &&
+ _carp("and can't restore permissions to $mask\n");
+ }
+ }
+ }
+ }
+ }
+ else {
+ if ($arg->{safe} &&
($Is_VMS ? !&VMS::Filespec::candelete($root)
: !(-l $root || -w $root)))
{
- print "skipped $root\n" if $verbose;
+ print "skipped $root\n" if $arg->{verbose};
next;
}
- chmod $rp | 0600, $root
- or carp ("Can't make file $root writeable: $!")
- if $force_writeable;
- print "unlink $root\n" if $verbose;
+ if (!chmod $rp | 0600, $root) {
+ if ($Force_Writeable) {
+ if ($arg->{error}) {
+ push @{${$arg->{error}}},
+ {$root => "Can't make file writeable: $!"};
+ }
+ else {
+ _carp ("Can't make file $root writeable: $!")
+ }
+ }
+ }
+ print "unlink $root\n" if $arg->{verbose};
# delete all versions under VMS
for (;;) {
- unless (unlink $root) {
- carp ("Can't unlink file $root: $!");
- if ($force_writeable) {
- chmod $rp, $root
- or carp("and can't restore permissions to "
- . sprintf("0%o",$rp) . "\n");
+ if (unlink $root) {
+ push @{${$arg->{result}}}, $root if $arg->{result};
+ }
+ else {
+ if ($arg->{error}) {
+ push @{${$arg->{error}}},
+ {$root => "unlink: $!"};
+ }
+ else {
+ _carp ("Can't unlink file $root: $!");
+ }
+ if ($Force_Writeable) {
+ if (!chmod $rp, $root) {
+ my $mask = sprintf("0%o",$rp);
+ if ($arg->{error}) {
+ push @{${$arg->{error}}}, {$root => "restore chmod: $!"};
+ }
+ else {
+ _carp("and can't restore permissions to $mask\n");
+ }
+ }
}
last;
}
}
}
- $count;
+ return $count;
}
1;
-#!./perl -wT
+# Path.t -- tests for module File::Path
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
-}
-
-use File::Path;
-use File::Spec::Functions;
use strict;
-my $count = 0;
-use warnings;
+use Test::More tests => 72;
-print "1..4\n";
+BEGIN {
+ use_ok('File::Path');
+ use_ok('File::Spec::Functions');
+}
+
+eval "use Test::Output";
+my $has_Test_Output = $@ ? 0 : 1;
# first check for stupid permissions second for full, so we clean up
# behind ourselves
mkpath($path);
chmod $perm, "mhx", $path;
- print "not " unless -d "mhx" && -d $path;
- print "ok ", ++$count, "\n";
+ my $oct = sprintf('0%o', $perm);
+ ok(-d "mhx", "mkdir parent dir $oct");
+ ok(-d $path, "mkdir child dir $oct");
rmtree("mhx");
- print "not " if -e "mhx";
- print "ok ", ++$count, "\n";
+ ok(! -e "mhx", "mhx does not exist $oct");
+}
+
+# find a place to work
+my ($error, $list, $file, $message);
+my $tmp_base = catdir(
+ curdir(),
+ sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
+);
+
+# invent some names
+my @dir = (
+ catdir($tmp_base, qw(a b)),
+ catdir($tmp_base, qw(a c)),
+ catdir($tmp_base, qw(z b)),
+ catdir($tmp_base, qw(z c)),
+);
+
+# create them
+my @created = mkpath(@dir);
+
+is(scalar(@created), 7, "created list of directories");
+
+# pray for no race conditions blowing them out from under us
+@created = mkpath([$tmp_base]);
+is(scalar(@created), 0, "skipped making existing directory")
+ or diag("unexpectedly recreated @created");
+
+@created = mkpath('');
+is(scalar(@created), 0, "Can't create a directory named ''");
+
+my $dir;
+my $dir2;
+
+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;
+
+ @created = mkpath($dir2, {mask => 0700});
+ is(scalar(@created), 1, "make directory with trailing parent segment");
+ is($created[0], $dir, "made parent");
+};
+
+my $count = rmtree({error => \$error});
+is( $count, 0, 'rmtree of nothing, count of zero' );
+is( scalar(@$error), 1, 'one diagnostic captureed' );
+eval { ($file, $message) = each %{$error->[0]} }; # too early to die, just in case
+is( $@, '', 'decoded diagnostic' );
+is( $file, '', 'general diagnostic' );
+is( $message, 'No root path(s) specified', 'expected diagnostic received' );
+
+@created = mkpath($tmp_base, 0);
+is(scalar(@created), 0, "skipped making existing directories (old style 1)")
+ or diag("unexpectedly recreated @created");
+
+$dir = catdir($tmp_base,'C');
+@created = mkpath($tmp_base, $dir);
+is(scalar(@created), 1, "created directory (new style 1)");
+is($created[0], $dir, "created directory (new style 1) cross-check");
+
+@created = mkpath($tmp_base, 0, 0700);
+is(scalar(@created), 0, "skipped making existing directories (old style 2)")
+ or diag("unexpectedly recreated @created");
+
+$dir2 = catdir($tmp_base,'D');
+@created = mkpath($tmp_base, $dir, $dir2);
+is(scalar(@created), 1, "created directory (new style 2)");
+is($created[0], $dir2, "created directory (new style 2) cross-check");
+
+$count = rmtree($dir, 0);
+is($count, 1, "removed directory (old style 1)");
+
+$count = rmtree($dir2, 0, 1);
+is($count, 1, "removed directory (old style 2)");
+
+# mkdir foo ./E/../Y
+# Y should exist
+# existence of E is neither here nor there
+$dir = catdir($tmp_base, 'E', updir(), 'Y');
+@created =mkpath($dir);
+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));
+is(scalar(@created), 0, "nothing created")
+ or diag(@created);
+
+$dir = catdir($tmp_base, 'a');
+$dir2 = catdir($tmp_base, 'z');
+
+rmtree( $dir, $dir2,
+ {
+ error => \$error,
+ result => \$list,
+ keep_root => 1,
+ }
+);
+
+is(scalar(@$error), 0, "no errors unlinking a and z");
+is(scalar(@$list), 4, "list contains 4 elements")
+ or diag("@$list");
+
+ok(-d $dir, "dir a still exists");
+ok(-d $dir2, "dir z still exists");
+
+# borderline new-style heuristics
+if (chdir $tmp_base) {
+ pass("chdir to temp dir");
+}
+else {
+ fail("chdir to temp dir: $!");
}
+
+$dir = catdir('a', 'd1');
+$dir2 = catdir('a', 'd2');
+
+@created = mkpath( $dir, 0, $dir2 );
+is(scalar @created, 3, 'new-style 3 dirs created');
+
+$count = rmtree( $dir, 0, $dir2, );
+is($count, 3, 'new-style 3 dirs removed');
+
+@created = mkpath( $dir, $dir2, 1 );
+is(scalar @created, 3, 'new-style 3 dirs created (redux)');
+
+$count = rmtree( $dir, $dir2, 1 );
+is($count, 3, 'new-style 3 dirs removed (redux)');
+
+@created = mkpath( $dir, $dir2 );
+is(scalar @created, 2, 'new-style 2 dirs created');
+
+$count = rmtree( $dir, $dir2 );
+is($count, 2, 'new-style 2 dirs removed');
+
+if (chdir updir()) {
+ pass("chdir parent");
+}
+else {
+ fail("chdir parent: $!");
+}
+
+# see what happens if a file exists where we want a directory
+SKIP: {
+ my $entry = catdir($tmp_base, "file");
+ skip "Cannot create $entry", 4 unless open OUT, "> $entry";
+ print OUT "test file, safe to delete\n", scalar(localtime), "\n";
+ close OUT;
+ ok(-e $entry, "file exists in place of directory");
+
+ mkpath( $entry, {error => \$error} );
+ is( scalar(@$error), 1, "caught error condition" );
+ ($file, $message) = each %{$error->[0]};
+ is( $entry, $file, "and the message is: $message");
+
+ eval {@created = mkpath($entry, 0, 0700)};
+ $error = $@;
+ chomp $error; # just to remove silly # in TAP output
+ cmp_ok( $error, 'ne', "", "no directory created (old-style) err=$error" )
+ or diag(@created);
+}
+
+my $extra = catdir(curdir(), qw(EXTRA 1 a));
+
+SKIP: {
+ skip "extra scenarios not set up, see eg/setup-extra-tests", 8
+ unless -e $extra;
+
+ my ($list, $err);
+ $dir = catdir( 'EXTRA', '1' );
+ rmtree( $dir, {result => \$list, error => \$err} );
+ is(scalar(@$list), 2, "extra dir $dir removed");
+ is(scalar(@$err), 1, "one error encountered");
+
+ $dir = catdir( 'EXTRA', '3', 'N' );
+ rmtree( $dir, {result => \$list, error => \$err} );
+ is( @$list, 1, q{remove a symlinked dir} );
+ is( @$err, 0, q{with no errors} );
+
+ $dir = catdir('EXTRA', '3', 'S');
+ rmtree($dir, {error => \$error});
+ is( scalar(@$error), 2, 'two errors for an unreadable dir' );
+
+ $dir = catdir( 'EXTRA', '4' );
+ rmtree($dir, {result => \$list, error => \$err} );
+ is( @$list, 0, q{don't follow a symlinked dir} );
+ is( @$err, 1, q{one error when removing a symlink in r/o dir} );
+ eval { ($file, $message) = each %{$err->[0]} };
+ is( $file, $dir, 'symlink reported in error' );
+}
+
+SKIP: {
+ skip 'Test::Output not available', 10
+ unless $has_Test_Output;
+
+ SKIP: {
+ $dir = catdir('EXTRA', '3');
+ skip "extra scenarios not set up, see eg/setup-extra-tests", 2
+ unless -e $dir;
+
+ stderr_like(
+ sub {rmtree($dir, {})},
+ qr{\ACan't remove directory \S+: .*? at \S+ line \d+\n},
+ 'rmtree with file owned by root'
+ );
+
+ stderr_like(
+ sub {rmtree('EXTRA', {})},
+ qr{\ACan't make directory EXTRA read\+writeable: .*? at \S+ line \d+
+(?:Can't remove directory EXTRA/\d: .*? at \S+ line \d+
+)+Can't unlink file [^:]+: .*? at \S+ line \d+
+Can't remove directory EXTRA: .*? at \S+ line \d+
+and can't restore permissions to \d+
+ at \S+ line \d+},
+ 'rmtree with insufficient privileges'
+ );
+ }
+
+ my $base = catdir($tmp_base,'output');
+ $dir = catdir($base,'A');
+ $dir2 = catdir($base,'B');
+
+ stderr_like(
+ \&rmtree,
+ qr/\ANo root path\(s\) specified\b/,
+ "rmtree of nothing carps sensibly"
+ );
+
+ stdout_is(
+ sub {@created = mkpath($dir, 1)},
+ "mkdir $base\nmkdir $dir\n",
+ 'mkpath verbose (old style 1)'
+ );
+
+ stdout_is(
+ sub {@created = mkpath([$dir2], 1)},
+ "mkdir $dir2\n",
+ 'mkpath verbose (old style 2)'
+ );
+
+ stdout_is(
+ sub {$count = rmtree([$dir, $dir2], 1, 1)},
+ "rmdir $dir\nrmdir $dir2\n",
+ 'rmtree verbose (old style)'
+ );
+
+ stdout_is(
+ sub {@created = mkpath($dir, {verbose => 1, mask => 0750})},
+ "mkdir $dir\n",
+ 'mkpath verbose (new style 1)'
+ );
+
+ stdout_is(
+ sub {@created = mkpath($dir2, 1, 0771)},
+ "mkdir $dir2\n",
+ 'mkpath verbose (new style 2)'
+ );
+
+ SKIP: {
+ $file = catdir($dir2, "file");
+ skip "Cannot create $file", 2 unless open OUT, "> $file";
+ print OUT "test file, safe to delete\n", scalar(localtime), "\n";
+ close OUT;
+
+ ok(-e $file, "file created in directory");
+
+ stdout_is(
+ sub {$count = rmtree($dir, $dir2, {verbose => 1, safe => 1})},
+ "rmdir $dir\nunlink $file\nrmdir $dir2\n",
+ 'rmtree safe verbose (new style)'
+ );
+ }
+}
+
+SKIP: {
+ skip "extra scenarios not set up, see eg/setup-extra-tests", 6
+ unless -d catdir(qw(EXTRA 1));
+
+ rmtree 'EXTRA', {safe => 0, error => \$error};
+ is( scalar(@$error), 7, 'seven deadly sins' );
+
+ rmtree 'EXTRA', {safe => 1, error => \$error};
+ is( scalar(@$error), 4, 'safe is better' );
+ for (@$error) {
+ ($file, $message) = each %$_;
+ if ($file =~ /[123]\z/) {
+ is(index($message, 'rmdir: '), 0, "failed to remove $file with rmdir")
+ or diag($message);
+ }
+ else {
+ is(index($message, 'unlink: '), 0, "failed to remove $file with unlink")
+ or diag($message);
+ }
+ }
+}
+
+rmtree($tmp_base, {result => \$list} );
+is(ref($list), 'ARRAY', "received a final list of results");
+ok( !(-d $tmp_base), "test base directory gone" );
projects / p5sagit/p5-mst-13.2.git / commitdiff