From 12c2e0168c650c45b4bee5ce9aa1888d920db917 Mon Sep 17 00:00:00 2001 From: David Landgren Date: Wed, 30 May 2007 21:50:38 +0200 Subject: [PATCH] Update File-Path to 2.00 Message-ID: <465DB96E.1020106@landgren.net> p4raw-id: //depot/perl@31315 --- lib/File/Path.pm | 586 ++++++++++++++++++++++++++++++++++++++++++++++--------- lib/File/Path.t | 329 +++++++++++++++++++++++++++++-- 2 files changed, 805 insertions(+), 110 deletions(-) diff --git a/lib/File/Path.pm b/lib/File/Path.pm index 002b9ef..9a0e48c 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -2,26 +2,153 @@ package File::Path; =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 function provides a convenient way to create directories, even -if your C kernel call won't create more than one level of directory at -a time. C takes three arguments: +The C function provides a convenient way to create directories, +even if your C kernel call won't create more than one level +of directory at a time. Similarly, the C function provides +a convenient way to delete a subtree from the directory structure, +much like the Unix command C. + +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 and C 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 + +The following keys are recognised as as parameters to C. +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. (C is +recognised as an alias for this parameter). + +=item verbose + +If present, will cause C 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 block, or the +program will halt. + +=back + +=head3 C + +=over 4 + +=item verbose + +If present, will cause C 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 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). + + 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 +block, or the program will halt. + +=back + +=head2 TRADITIONAL INTERFACE + +The old interface for C and C take a +reference to a list of directories (to create or remove), +followed by a series of positional numeric modal parameters that +control their behaviour. + +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 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 * @@ -50,9 +177,7 @@ can be trapped with an C block: print "Couldn't create $dir: $@"; } -Similarly, the C function provides a convenient way to delete a -subtree from the directory structure, much like the Unix command C. -C takes three arguments: +In the traditional form, C takes three arguments: =over 4 @@ -85,20 +210,99 @@ than VMS is settled. (defaults to FALSE) It returns the number of files, directories and symlinks successfully deleted. Symlinks are simply deleted and not followed. -B There are race conditions internal to the implementation of -C making it unsafe to use on directory trees which may be -altered or moved while C 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 using the +traditional interface can be determined I by trapping diagnostic +messages using C<$SIG{__WARN__}>; it is not apparent from the return +value. (The modern interface may use the C parameter to +record any problems encountered. + +=head2 ERROR HANDLING + +If C or C encounter an error, a diagnostic message +will be printed to C via C (for non-fatal errors), +or via C (for fatal errors). + +If this behaviour is not desirable, the C 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). If a general error +is encountered (for instance, C attempts to remove a directory +tree that does not exist), the diagnostic key will be empty, only +the value will be set: + + rmpath( '/no/such/path', {error => \my $err} ); + 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 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 can be determined I -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 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 +making it unsafe to use on directory trees which may be altered or +moved while C is running, and in particular on any directory +trees with any path components or subdirectories potentially writable +by untrusted users. + +Additionally, if the C parareter is not set (or the +third parameter in the traditional inferface is not TRUE) and +C is interrupted, it may leave files and directories with +permissions altered to allow deletion. + +C blindly exports C and C 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 @@ -112,51 +316,126 @@ maximum path length. =back +=head1 SEE ALSO + +=over 4 + +=item * + +L + +When removing directory trees, if you want to examine each file +before deciding whether to deleting it (and possibly leaving large +swathes alone), F offers a convenient and flexible +approach. + +=back + +=head1 BUGS + +Please report all bugs on the RT queue: + +L + =head1 AUTHORS Tim Bunce > and -Charles Bailey > +Charles Bailey >. + +Currently maintained by David Landgren >. + +=head1 COPYRIGHT + +This module is copyright (C) Charles Bailey, Tim Bunce and +David Landgren 1995-2007. All rights reserved. + +=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) { @@ -166,68 +445,130 @@ sub mkpath { 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 @@ -235,49 +576,104 @@ sub rmtree { ($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; } @@ -287,7 +683,7 @@ sub rmtree { } } - $count; + return $count; } 1; diff --git a/lib/File/Path.t b/lib/File/Path.t index 84575d7..6162cba 100755 --- a/lib/File/Path.t +++ b/lib/File/Path.t @@ -1,18 +1,16 @@ -#!./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 @@ -21,10 +19,311 @@ for my $perm (0111,0777) { 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" ); -- 2.7.4