lib/File/Path.t

   1 # Path.t -- tests for module File::Path
   2
   3 use strict;
   4
   5 use Test::More tests => 114;
   6
   7 BEGIN {
   8     use_ok('Cwd');
   9     use_ok('File::Path', qw(rmtree mkpath make_path remove_tree));
  10     use_ok('File::Spec::Functions');
  11 }
  12
  13 eval "use Test::Output";
  14 my $has_Test_Output = $@ ? 0 : 1;
  15
  16 my $Is_VMS   = $^O eq 'VMS';
  17
  18 # first check for stupid permissions second for full, so we clean up
  19 # behind ourselves
  20 for my $perm (0111,0777) {
  21     my $path = catdir(curdir(), "mhx", "bar");
  22     mkpath($path);
  23     chmod $perm, "mhx", $path;
  24
  25     my $oct = sprintf('0%o', $perm);
  26     ok(-d "mhx", "mkdir parent dir $oct");
  27     ok(-d $path, "mkdir child dir $oct");
  28
  29     rmtree("mhx");
  30     ok(! -e "mhx", "mhx does not exist $oct");
  31 }
  32
  33 # find a place to work
  34 my ($error, $list, $file, $message);
  35 my $tmp_base = catdir(
  36     curdir(),
  37     sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
  38 );
  39
  40 # invent some names
  41 my @dir = (
  42     catdir($tmp_base, qw(a b)),
  43     catdir($tmp_base, qw(a c)),
  44     catdir($tmp_base, qw(z b)),
  45     catdir($tmp_base, qw(z c)),
  46 );
  47
  48 # create them
  49 my @created = mkpath([@dir]);
  50
  51 is(scalar(@created), 7, "created list of directories");
  52
  53 # pray for no race conditions blowing them out from under us
  54 @created = mkpath([$tmp_base]);
  55 is(scalar(@created), 0, "skipped making existing directory")
  56     or diag("unexpectedly recreated @created");
  57
  58 # create a file
  59 my $file_name = catfile( $tmp_base, 'a', 'delete.me' );
  60 my $file_count = 0;
  61 if (open OUT, "> $file_name") {
  62     print OUT "this file may be deleted\n";
  63     close OUT;
  64     ++$file_count;
  65 }
  66 else {
  67     diag( "Failed to create file $file_name: $!" );
  68 }
  69
  70 SKIP: {
  71     skip "cannot remove a file we failed to create", 1
  72         unless $file_count == 1;
  73     my $count = rmtree($file_name);
  74     is($count, 1, "rmtree'ed a file");
  75 }
  76
  77 @created = mkpath('');
  78 is(scalar(@created), 0, "Can't create a directory named ''");
  79
  80 my $dir;
  81 my $dir2;
  82
  83 sub gisle {
  84     # background info: @_ = 1; !shift # gives '' not 0
  85     # Message-Id: <3C820CE6-4400-4E91-AF43-A3D19B356E68@activestate.com>
  86     # http://www.nntp.perl.org/group/perl.perl5.porters/2008/05/msg136625.html
  87     mkpath(shift, !shift, 0755);
  88 }
  89
  90 sub count {
  91     opendir D, shift or return -1;
  92     my $count = () = readdir D;
  93     closedir D or return -1;
  94     return $count;
  95 }
  96
  97 {
  98     mkdir 'solo', 0755;
  99     chdir 'solo';
 100     my $before = count(curdir());
 101     cmp_ok($before, '>', 0, "baseline $before");
 102
 103     gisle('1st', 1);
 104     is(count(curdir()), $before + 1, "first after $before");
 105
 106     $before = count(curdir());
 107     gisle('2nd', 1);
 108     is(count(curdir()), $before + 1, "second after $before");
 109
 110     chdir updir();
 111     rmtree 'solo';
 112 }
 113
 114 {
 115     mkdir 'solo', 0755;
 116     chdir 'solo';
 117     my $before = count(curdir());
 118     cmp_ok($before, '>', 0, "ARGV $before");
 119     {
 120         local @ARGV = (1);
 121         mkpath('3rd', !shift, 0755);
 122     }
 123     is(count(curdir()), $before + 1, "third after $before");
 124
 125     $before = count(curdir());
 126     {
 127         local @ARGV = (1);
 128         mkpath('4th', !shift, 0755);
 129     }
 130     is(count(curdir()), $before + 1, "fourth after $before");
 131
 132     chdir updir();
 133     rmtree 'solo';
 134 }
 135
 136 SKIP: {
 137     # tests for rmtree() of ancestor directory
 138     my $nr_tests = 6;
 139     my $cwd = getcwd() or skip "failed to getcwd: $!", $nr_tests;
 140     my $dir  = catdir($cwd, 'remove');
 141     my $dir2 = catdir($cwd, 'remove', 'this', 'dir');
 142
 143     skip "failed to mkpath '$dir2': $!", $nr_tests
 144         unless mkpath($dir2, {verbose => 0});
 145     skip "failed to chdir dir '$dir2': $!", $nr_tests
 146         unless chdir($dir2);
 147
 148     rmtree($dir, {error => \$error});
 149     my $nr_err = @$error;
 150     is($nr_err, 1, "ancestor error");
 151
 152     if ($nr_err) {
 153         my ($file, $message) = each %{$error->[0]};
 154         is($file, $dir, "ancestor named");
 155         my $ortho_dir = $^O eq 'MSWin32' ? File::Path::_slash_lc($dir2) : $dir2;
 156         $^O eq 'MSWin32' and $message
 157             =~ s/\A(cannot remove path when cwd is )(.*)\Z/$1 . File::Path::_slash_lc($2)/e;
 158         is($message, "cannot remove path when cwd is $ortho_dir", "ancestor reason");
 159         ok(-d $dir2, "child not removed");
 160         ok(-d $dir, "ancestor not removed");
 161     }
 162     else {
 163         fail( "ancestor 1");
 164         fail( "ancestor 2");
 165         fail( "ancestor 3");
 166         fail( "ancestor 4");
 167     }
 168     chdir $cwd;
 169     rmtree($dir);
 170     ok(!(-d $dir), "ancestor now removed");
 171 };
 172
 173 my $count = rmtree({error => \$error});
 174 is( $count, 0, 'rmtree of nothing, count of zero' );
 175 is( scalar(@$error), 0, 'no diagnostic captured' );
 176
 177 @created = mkpath($tmp_base, 0);
 178 is(scalar(@created), 0, "skipped making existing directories (old style 1)")
 179     or diag("unexpectedly recreated @created");
 180
 181 $dir = catdir($tmp_base,'C');
 182 # mkpath returns unix syntax filespecs on VMS
 183 $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 184 @created = make_path($tmp_base, $dir);
 185 is(scalar(@created), 1, "created directory (new style 1)");
 186 is($created[0], $dir, "created directory (new style 1) cross-check");
 187
 188 @created = mkpath($tmp_base, 0, 0700);
 189 is(scalar(@created), 0, "skipped making existing directories (old style 2)")
 190     or diag("unexpectedly recreated @created");
 191
 192 $dir2 = catdir($tmp_base,'D');
 193 # mkpath returns unix syntax filespecs on VMS
 194 $dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS;
 195 @created = make_path($tmp_base, $dir, $dir2);
 196 is(scalar(@created), 1, "created directory (new style 2)");
 197 is($created[0], $dir2, "created directory (new style 2) cross-check");
 198
 199 $count = rmtree($dir, 0);
 200 is($count, 1, "removed directory unsafe mode");
 201
 202 $count = rmtree($dir2, 0, 1);
 203 my $removed = $Is_VMS ? 0 : 1;
 204 is($count, $removed, "removed directory safe mode");
 205
 206 # mkdir foo ./E/../Y
 207 # Y should exist
 208 # existence of E is neither here nor there
 209 $dir = catdir($tmp_base, 'E', updir(), 'Y');
 210 @created =mkpath($dir);
 211 cmp_ok(scalar(@created), '>=', 1, "made one or more dirs because of ..");
 212 cmp_ok(scalar(@created), '<=', 2, "made less than two dirs because of ..");
 213 ok( -d catdir($tmp_base, 'Y'), "directory after parent" );
 214
 215 @created = make_path(catdir(curdir(), $tmp_base));
 216 is(scalar(@created), 0, "nothing created")
 217     or diag(@created);
 218
 219 $dir  = catdir($tmp_base, 'a');
 220 $dir2 = catdir($tmp_base, 'z');
 221
 222 rmtree( $dir, $dir2,
 223     {
 224         error     => \$error,
 225         result    => \$list,
 226         keep_root => 1,
 227     }
 228 );
 229
 230 is(scalar(@$error), 0, "no errors unlinking a and z");
 231 is(scalar(@$list),  4, "list contains 4 elements")
 232     or diag("@$list");
 233
 234 ok(-d $dir,  "dir a still exists");
 235 ok(-d $dir2, "dir z still exists");
 236
 237 $dir = catdir($tmp_base,'F');
 238 # mkpath returns unix syntax filespecs on VMS
 239 $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 240
 241 @created = mkpath($dir, undef, 0770);
 242 is(scalar(@created), 1, "created directory (old style 2 verbose undef)");
 243 is($created[0], $dir, "created directory (old style 2 verbose undef) cross-check");
 244 is(rmtree($dir, undef, 0), 1, "removed directory 2 verbose undef");
 245
 246 @created = mkpath($dir, undef);
 247 is(scalar(@created), 1, "created directory (old style 2a verbose undef)");
 248 is($created[0], $dir, "created directory (old style 2a verbose undef) cross-check");
 249 is(rmtree($dir, undef), 1, "removed directory 2a verbose undef");
 250
 251 @created = mkpath($dir, 0, undef);
 252 is(scalar(@created), 1, "created directory (old style 3 mode undef)");
 253 is($created[0], $dir, "created directory (old style 3 mode undef) cross-check");
 254 is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef");
 255
 256 $dir = catdir($tmp_base,'G');
 257 $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 258
 259 @created = mkpath($dir, undef, 0200);
 260 is(scalar(@created), 1, "created write-only dir");
 261 is($created[0], $dir, "created write-only directory cross-check");
 262 is(rmtree($dir), 1, "removed write-only dir");
 263
 264 # borderline new-style heuristics
 265 if (chdir $tmp_base) {
 266     pass("chdir to temp dir");
 267 }
 268 else {
 269     fail("chdir to temp dir: $!");
 270 }
 271
 272 $dir   = catdir('a', 'd1');
 273 $dir2  = catdir('a', 'd2');
 274
 275 @created = make_path( $dir, 0, $dir2 );
 276 is(scalar @created, 3, 'new-style 3 dirs created');
 277
 278 $count = remove_tree( $dir, 0, $dir2, );
 279 is($count, 3, 'new-style 3 dirs removed');
 280
 281 @created = make_path( $dir, $dir2, 1 );
 282 is(scalar @created, 3, 'new-style 3 dirs created (redux)');
 283
 284 $count = remove_tree( $dir, $dir2, 1 );
 285 is($count, 3, 'new-style 3 dirs removed (redux)');
 286
 287 @created = make_path( $dir, $dir2 );
 288 is(scalar @created, 2, 'new-style 2 dirs created');
 289
 290 $count = remove_tree( $dir, $dir2 );
 291 is($count, 2, 'new-style 2 dirs removed');
 292
 293 if (chdir updir()) {
 294     pass("chdir parent");
 295 }
 296 else {
 297     fail("chdir parent: $!");
 298 }
 299
 300 SKIP: {
 301     # test bug http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=487319
 302     skip "Don't need Force_Writeable semantics on $^O", 4
 303         if grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
 304     $dir  = 'bug487319';
 305     $dir2 = 'bug487319-symlink';
 306     @created = make_path($dir, {mask => 0700});
 307     is(scalar @created, 1, 'bug 487319 setup');
 308     symlink($dir, $dir2);
 309     ok(-e $dir2, "debian bug 487319 setup symlink") or diag($dir2);
 310
 311     chmod 0500, $dir;
 312     my $mask_initial = (stat $dir)[2];
 313     remove_tree($dir2);
 314
 315     my $mask = (stat $dir)[2];
 316     is( $mask, $mask_initial, 'mask of symlink target dir unchanged (debian bug 487319)');
 317
 318     # now try a file
 319     my $file = catfile($dir, 'file');
 320     open my $out, '>', $file;
 321     close $out;
 322
 323     chmod 0500, $file;
 324     $mask_initial = (stat $file)[2];
 325
 326     my $file2 = catfile($dir, 'symlink');
 327     symlink($file, $file2);
 328     remove_tree($file2);
 329
 330     $mask = (stat $file)[2];
 331     is( $mask, $mask_initial, 'mask of symlink target file unchanged (debian bug 487319)');
 332
 333     remove_tree($dir);
 334 }
 335
 336 # see what happens if a file exists where we want a directory
 337 SKIP: {
 338     my $entry = catdir($tmp_base, "file");
 339     skip "Cannot create $entry", 4 unless open OUT, "> $entry";
 340     print OUT "test file, safe to delete\n", scalar(localtime), "\n";
 341     close OUT;
 342     ok(-e $entry, "file exists in place of directory");
 343
 344     mkpath( $entry, {error => \$error} );
 345     is( scalar(@$error), 1, "caught error condition" );
 346     ($file, $message) = each %{$error->[0]};
 347     is( $entry, $file, "and the message is: $message");
 348
 349     eval {@created = mkpath($entry, 0, 0700)};
 350     $error = $@;
 351     chomp $error; # just to remove silly # in TAP output
 352     cmp_ok( $error, 'ne', "", "no directory created (old-style) err=$error" )
 353         or diag(@created);
 354 }
 355
 356 my $extra =  catdir(curdir(), qw(EXTRA 1 a));
 357
 358 SKIP: {
 359     skip "extra scenarios not set up, see eg/setup-extra-tests", 14
 360         unless -e $extra;
 361
 362     my ($list, $err);
 363     $dir = catdir( 'EXTRA', '1' );
 364     rmtree( $dir, {result => \$list, error => \$err} );
 365     is(scalar(@$list), 2, "extra dir $dir removed");
 366     is(scalar(@$err), 1, "one error encountered");
 367
 368     $dir = catdir( 'EXTRA', '3', 'N' );
 369     rmtree( $dir, {result => \$list, error => \$err} );
 370     is( @$list, 1, q{remove a symlinked dir} );
 371     is( @$err,  0, q{with no errors} );
 372
 373     $dir = catdir('EXTRA', '3', 'S');
 374     rmtree($dir, {error => \$error});
 375     is( scalar(@$error), 1, 'one error for an unreadable dir' );
 376     eval { ($file, $message) = each %{$error->[0]}};
 377     is( $file, $dir, 'unreadable dir reported in error' )
 378         or diag($message);
 379
 380     $dir = catdir('EXTRA', '3', 'T');
 381     rmtree($dir, {error => \$error});
 382     is( scalar(@$error), 1, 'one error for an unreadable dir T' );
 383     eval { ($file, $message) = each %{$error->[0]}};
 384     is( $file, $dir, 'unreadable dir reported in error T' );
 385
 386     $dir = catdir( 'EXTRA', '4' );
 387     rmtree($dir,  {result => \$list, error => \$err} );
 388     is( scalar(@$list), 0, q{don't follow a symlinked dir} );
 389     is( scalar(@$err),  2, q{two errors when removing a symlink in r/o dir} );
 390     eval { ($file, $message) = each %{$err->[0]} };
 391     is( $file, $dir, 'symlink reported in error' );
 392
 393     $dir  = catdir('EXTRA', '3', 'U');
 394     $dir2 = catdir('EXTRA', '3', 'V');
 395     rmtree($dir, $dir2, {verbose => 0, error => \$err, result => \$list});
 396     is( scalar(@$list),  1, q{deleted 1 out of 2 directories} );
 397     is( scalar(@$error), 1, q{left behind 1 out of 2 directories} );
 398     eval { ($file, $message) = each %{$err->[0]} };
 399     is( $file, $dir, 'first dir reported in error' );
 400 }
 401
 402 {
 403     $dir = catdir($tmp_base, 'ZZ');
 404     @created = mkpath($dir);
 405     is(scalar(@created), 1, "create a ZZ directory");
 406
 407     local @ARGV = ($dir);
 408     rmtree( [grep -e $_, @ARGV], 0, 0 );
 409     ok(!-e $dir, "blow it away via \@ARGV");
 410 }
 411
 412 SKIP: {
 413     skip 'Test::Output not available', 14
 414         unless $has_Test_Output;
 415
 416     SKIP: {
 417         $dir = catdir('EXTRA', '3');
 418         skip "extra scenarios not set up, see eg/setup-extra-tests", 3
 419             unless -e $dir;
 420
 421         $dir = catdir('EXTRA', '3', 'U');
 422         stderr_like(
 423             sub {rmtree($dir, {verbose => 0})},
 424             qr{\Acannot make child directory read-write-exec for [^:]+: .* at \S+ line \d+},
 425             q(rmtree can't chdir into root dir)
 426         );
 427
 428         $dir = catdir('EXTRA', '3');
 429         stderr_like(
 430             sub {rmtree($dir, {})},
 431             qr{\Acannot make child directory read-write-exec for [^:]+: .* at (\S+) line (\d+)
 432 cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
 433 cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
 434 cannot remove directory for [^:]+: .* at \1 line \2},
 435             'rmtree with file owned by root'
 436         );
 437
 438         stderr_like(
 439             sub {rmtree('EXTRA', {})},
 440             qr{\Acannot remove directory for [^:]+: .* at (\S+) line (\d+)
 441 cannot remove directory for [^:]+: .* at \1 line \2
 442 cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
 443 cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
 444 cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
 445 cannot remove directory for [^:]+: .* at \1 line \2
 446 cannot unlink file for [^:]+: .* at \1 line \2
 447 cannot restore permissions to \d+ for [^:]+: .* at \1 line \2
 448 cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
 449 cannot remove directory for [^:]+: .* at \1 line \2
 450 cannot restore permissions to \d+ for [^:]+: .* at \1 line \2},
 451             'rmtree with insufficient privileges'
 452         );
 453     }
 454
 455     my $base = catdir($tmp_base,'output');
 456     $dir  = catdir($base,'A');
 457     $dir2 = catdir($base,'B');
 458
 459     stderr_like(
 460         sub { rmtree( undef, 1 ) },
 461         qr/\ANo root path\(s\) specified\b/,
 462         "rmtree of nothing carps sensibly"
 463     );
 464
 465     stderr_like(
 466         sub { rmtree( '', 1 ) },
 467         qr/\ANo root path\(s\) specified\b/,
 468         "rmtree of empty dir carps sensibly"
 469     );
 470
 471     stderr_is( sub { make_path() }, '', "make_path no args does not carp" );
 472     stderr_is( sub { remove_tree() }, '', "remove_tree no args does not carp" );
 473
 474     stdout_is(
 475         sub {@created = mkpath($dir, 1)},
 476         "mkdir $base\nmkdir $dir\n",
 477         'mkpath verbose (old style 1)'
 478     );
 479
 480     stdout_is(
 481         sub {@created = mkpath([$dir2], 1)},
 482         "mkdir $dir2\n",
 483         'mkpath verbose (old style 2)'
 484     );
 485
 486     stdout_is(
 487         sub {$count = rmtree([$dir, $dir2], 1, 1)},
 488         "rmdir $dir\nrmdir $dir2\n",
 489         'rmtree verbose (old style)'
 490     );
 491
 492     stdout_is(
 493         sub {@created = mkpath($dir, {verbose => 1, mask => 0750})},
 494         "mkdir $dir\n",
 495         'mkpath verbose (new style 1)'
 496     );
 497
 498     stdout_is(
 499         sub {@created = mkpath($dir2, 1, 0771)},
 500         "mkdir $dir2\n",
 501         'mkpath verbose (new style 2)'
 502     );
 503
 504     SKIP: {
 505         $file = catdir($dir2, "file");
 506         skip "Cannot create $file", 2 unless open OUT, "> $file";
 507         print OUT "test file, safe to delete\n", scalar(localtime), "\n";
 508         close OUT;
 509
 510         ok(-e $file, "file created in directory");
 511
 512         stdout_is(
 513             sub {$count = rmtree($dir, $dir2, {verbose => 1, safe => 1})},
 514             "rmdir $dir\nunlink $file\nrmdir $dir2\n",
 515             'rmtree safe verbose (new style)'
 516         );
 517     }
 518 }
 519
 520 SKIP: {
 521     skip "extra scenarios not set up, see eg/setup-extra-tests", 11
 522         unless -d catdir(qw(EXTRA 1));
 523
 524     rmtree 'EXTRA', {safe => 0, error => \$error};
 525     is( scalar(@$error), 11, 'seven deadly sins' ); # well there used to be 7
 526
 527     rmtree 'EXTRA', {safe => 1, error => \$error};
 528     is( scalar(@$error), 9, 'safe is better' );
 529     for (@$error) {
 530         ($file, $message) = each %$_;
 531         if ($file =~  /[123]\z/) {
 532             is(index($message, 'cannot remove directory: '), 0, "failed to remove $file with rmdir")
 533                 or diag($message);
 534         }
 535         else {
 536             like($message, qr(\Acannot (?:restore permissions to \d+|chdir to child|unlink file): ), "failed to remove $file with unlink")
 537                 or diag($message)
 538         }
 539     }
 540 }
 541
 542 rmtree($tmp_base, {result => \$list} );
 543 is(ref($list), 'ARRAY', "received a final list of results");
 544 ok( !(-d $tmp_base), "test base directory gone" );