use strict;
-use Test::More tests => 84;
+use Test::More tests => 99;
BEGIN {
use_ok('File::Path');
eval "use Test::Output";
my $has_Test_Output = $@ ? 0 : 1;
+my $Is_VMS = $^O eq 'VMS';
+
# first check for stupid permissions second for full, so we clean up
# behind ourselves
for my $perm (0111,0777) {
is(scalar(@created), 0, "skipped making existing directory")
or diag("unexpectedly recreated @created");
+# create a file
+my $file_name = catfile( $tmp_base, 'a', 'delete.me' );
+my $file_count = 0;
+if (open OUT, "> $file_name") {
+ print OUT "this file may be deleted\n";
+ close OUT;
+ ++$file_count;
+}
+else {
+ diag( "Failed to create file $file_name: $!" );
+}
+
+SKIP: {
+ skip "cannot remove a file we failed to create", 1
+ unless $file_count == 1;
+ my $count = rmtree($file_name);
+ is($count, 1, "rmtree'ed a file");
+}
+
@created = mkpath('');
is(scalar(@created), 0, "Can't create a directory named ''");
$dir = catdir($tmp_base,'C');
# mkpath returns unix syntax filespecs on VMS
-$dir = VMS::Filespec::unixify($dir) if $^O eq 'VMS';
+$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
@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");
$dir2 = catdir($tmp_base,'D');
# mkpath returns unix syntax filespecs on VMS
-$dir2 = VMS::Filespec::unixify($dir2) if $^O eq 'VMS';
+$dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS;
@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)");
+is($count, 1, "removed directory unsafe mode");
$count = rmtree($dir2, 0, 1);
-is($count, 1, "removed directory (old style 2)");
+my $removed = $Is_VMS ? 0 : 1;
+is($count, $removed, "removed directory safe mode");
# mkdir foo ./E/../Y
# Y should exist
ok(-d $dir2, "dir z still exists");
$dir = catdir($tmp_base,'F');
+# mkpath returns unix syntax filespecs on VMS
+$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
@created = mkpath($dir, undef, 0770);
is(scalar(@created), 1, "created directory (old style 2 verbose undef)");
is($created[0], $dir, "created directory (old style 3 mode undef) cross-check");
is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef");
+$dir = catdir($tmp_base,'G');
+$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
+
+@created = mkpath($dir, undef, 0200);
+is(scalar(@created), 1, "created write-only dir");
+is($created[0], $dir, "created write-only directory cross-check");
+is(rmtree($dir), 1, "removed write-only dir");
+
# borderline new-style heuristics
if (chdir $tmp_base) {
pass("chdir to temp dir");
my $extra = catdir(curdir(), qw(EXTRA 1 a));
SKIP: {
- skip "extra scenarios not set up, see eg/setup-extra-tests", 8
+ skip "extra scenarios not set up, see eg/setup-extra-tests", 14
unless -e $extra;
my ($list, $err);
$dir = catdir('EXTRA', '3', 'S');
rmtree($dir, {error => \$error});
- is( scalar(@$error), 2, 'two errors for an unreadable dir' );
+ is( scalar(@$error), 1, 'one error for an unreadable dir' );
+ eval { ($file, $message) = each %{$error->[0]}};
+ is( $file, $dir, 'unreadable dir reported in error' )
+ or diag($message);
$dir = catdir('EXTRA', '3', 'T');
rmtree($dir, {error => \$error});
+ is( scalar(@$error), 1, 'one error for an unreadable dir T' );
+ eval { ($file, $message) = each %{$error->[0]}};
+ is( $file, $dir, 'unreadable dir reported in error T' );
$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} );
+ is( scalar(@$list), 0, q{don't follow a symlinked dir} );
+ is( scalar(@$err), 2, q{two errors when removing a symlink in r/o dir} );
eval { ($file, $message) = each %{$err->[0]} };
is( $file, $dir, 'symlink reported in error' );
+
+ $dir = catdir('EXTRA', '3', 'U');
+ $dir2 = catdir('EXTRA', '3', 'V');
+ rmtree($dir, $dir2, {verbose => 0, error => \$err, result => \$list});
+ is( scalar(@$list), 1, q{deleted 1 out of 2 directories} );
+ is( scalar(@$error), 1, q{left behind 1 out of 2 directories} );
+ eval { ($file, $message) = each %{$err->[0]} };
+ is( $file, $dir, 'first dir reported in error' );
}
{
SKIP: {
$dir = catdir('EXTRA', '3');
- skip "extra scenarios not set up, see eg/setup-extra-tests", 2
+ skip "extra scenarios not set up, see eg/setup-extra-tests", 3
unless -e $dir;
$dir = catdir('EXTRA', '3', 'U');
stderr_like(
sub {rmtree($dir, {verbose => 0})},
- qr{\bCan't read \Q$dir\E: },
- q(rmtree can't read root dir)
+ qr{\Acannot make child directory read-write-exec for [^:]+: .* at \S+ line \d+},
+ q(rmtree can't chdir into root dir)
);
$dir = catdir('EXTRA', '3');
stderr_like(
sub {rmtree($dir, {})},
- qr{\ACan't remove directory \S+: .*? at \S+ line \d+\n},
+ qr{\Acannot make child directory read-write-exec for [^:]+: .* at (\S+) line (\d+)
+cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
+cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
+cannot remove directory for [^:]+: .* at \1 line \2},
'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+},
+ qr{\Acannot remove directory for [^:]+: .* at (\S+) line (\d+)
+cannot remove directory for [^:]+: .* at \1 line \2
+cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
+cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
+cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
+cannot remove directory for [^:]+: .* at \1 line \2
+cannot unlink file for [^:]+: .* at \1 line \2
+cannot restore permissions to \d+ for [^:]+: .* at \1 line \2
+cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
+cannot remove directory for [^:]+: .* at \1 line \2
+cannot restore permissions to \d+ for [^:]+: .* at \1 line \2},
'rmtree with insufficient privileges'
);
}
}
SKIP: {
- skip "extra scenarios not set up, see eg/setup-extra-tests", 6
+ skip "extra scenarios not set up, see eg/setup-extra-tests", 11
unless -d catdir(qw(EXTRA 1));
rmtree 'EXTRA', {safe => 0, error => \$error};
- is( scalar(@$error), 7, 'seven deadly sins' );
+ is( scalar(@$error), 11, 'seven deadly sins' ); # well there used to be 7
rmtree 'EXTRA', {safe => 1, error => \$error};
- is( scalar(@$error), 4, 'safe is better' );
+ is( scalar(@$error), 9, 'safe is better' );
for (@$error) {
($file, $message) = each %$_;
if ($file =~ /[123]\z/) {
- is(index($message, 'rmdir: '), 0, "failed to remove $file with rmdir")
+ is(index($message, 'cannot remove directory: '), 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);
+ like($message, qr(\Acannot (?:restore permissions to \d+|chdir to child|unlink file): ), "failed to remove $file with unlink")
+ or diag($message)
}
}
}
projects / p5sagit/p5-mst-13.2.git / blobdiff