cpan/File-Path/t/Path.t

   1 #! /usr/bin/env perl
   2 # Path.t -- tests for module File::Path
   3
   4 use strict;
   5
   6 use Test::More tests => 159;
   7 use Config;
   8 use Fcntl ':mode';
   9
  10 BEGIN {
  11     # 1
  12     use_ok('Cwd');
  13     # 2
  14     use_ok('File::Path', qw(rmtree mkpath make_path remove_tree));
  15     # 3
  16     use_ok('File::Spec::Functions');
  17 }
  18
  19 eval "use Test::Output";
  20 my $has_Test_Output = $@ ? 0 : 1;
  21
  22 my $Is_VMS = $^O eq 'VMS';
  23
  24 # first check for stupid permissions second for full, so we clean up
  25 # behind ourselves
  26 for my $perm (0111,0777) {
  27     my $path = catdir(curdir(), "mhx", "bar");
  28     mkpath($path);
  29     chmod $perm, "mhx", $path;
  30
  31     my $oct = sprintf('0%o', $perm);
  32     # 4
  33     ok(-d "mhx", "mkdir parent dir $oct");
  34     # 5
  35     ok(-d $path, "mkdir child dir $oct");
  36
  37     rmtree("mhx");
  38     # 6
  39     ok(! -e "mhx", "mhx does not exist $oct");
  40 }
  41
  42 # find a place to work
  43 my ($error, $list, $file, $message);
  44 my $tmp_base = catdir(
  45     curdir(),
  46     sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
  47 );
  48
  49 # invent some names
  50 my @dir = (
  51     catdir($tmp_base, qw(a b)),
  52     catdir($tmp_base, qw(a c)),
  53     catdir($tmp_base, qw(z b)),
  54     catdir($tmp_base, qw(z c)),
  55 );
  56
  57 # create them
  58 my @created = mkpath([@dir]);
  59
  60 # 7
  61 is(scalar(@created), 7, "created list of directories");
  62
  63 # pray for no race conditions blowing them out from under us
  64 @created = mkpath([$tmp_base]);
  65 is(scalar(@created), 0, "skipped making existing directory")
  66     or diag("unexpectedly recreated @created");
  67
  68 # create a file
  69 my $file_name = catfile( $tmp_base, 'a', 'delete.me' );
  70 my $file_count = 0;
  71 if (open OUT, "> $file_name") {
  72     print OUT "this file may be deleted\n";
  73     close OUT;
  74     ++$file_count;
  75 }
  76 else {
  77     diag( "Failed to create file $file_name: $!" );
  78 }
  79
  80 SKIP: {
  81     skip "cannot remove a file we failed to create", 1
  82         unless $file_count == 1;
  83     my $count = rmtree($file_name);
  84 # 8
  85     is($count, 1, "rmtree'ed a file");
  86 }
  87
  88 @created = mkpath('');
  89 # 9
  90 is(scalar(@created), 0, "Can't create a directory named ''");
  91
  92 my $dir;
  93 my $dir2;
  94
  95 sub gisle {
  96     # background info: @_ = 1; !shift # gives '' not 0
  97     # Message-Id: <3C820CE6-4400-4E91-AF43-A3D19B356E68@activestate.com>
  98     # http://www.nntp.perl.org/group/perl.perl5.porters/2008/05/msg136625.html
  99     mkpath(shift, !shift, 0755);
 100 }
 101
 102 sub count {
 103     opendir D, shift or return -1;
 104     my $count = () = readdir D;
 105     closedir D or return -1;
 106     return $count;
 107 }
 108
 109 {
 110     mkdir 'solo', 0755;
 111     chdir 'solo';
 112     open my $f, '>', 'foo.dat';
 113     close $f;
 114     my $before = count(curdir());
 115 # 10
 116     cmp_ok($before, '>', 0, "baseline $before");
 117
 118     gisle('1st', 1);
 119 # 11
 120     is(count(curdir()), $before + 1, "first after $before");
 121
 122     $before = count(curdir());
 123     gisle('2nd', 1);
 124 # 12
 125     is(count(curdir()), $before + 1, "second after $before");
 126
 127     chdir updir();
 128     rmtree 'solo';
 129 }
 130
 131 {
 132     mkdir 'solo', 0755;
 133     chdir 'solo';
 134     open my $f, '>', 'foo.dat';
 135     close $f;
 136     my $before = count(curdir());
 137 # 13
 138     cmp_ok($before, '>', 0, "ARGV $before");
 139     {
 140         local @ARGV = (1);
 141         mkpath('3rd', !shift, 0755);
 142     }
 143 # 14
 144     is(count(curdir()), $before + 1, "third after $before");
 145
 146     $before = count(curdir());
 147     {
 148         local @ARGV = (1);
 149         mkpath('4th', !shift, 0755);
 150     }
 151 # 15
 152     is(count(curdir()), $before + 1, "fourth after $before");
 153
 154     chdir updir();
 155     rmtree 'solo';
 156 }
 157
 158 SKIP: {
 159     # tests for rmtree() of ancestor directory
 160     my $nr_tests = 6;
 161     my $cwd = getcwd() or skip "failed to getcwd: $!", $nr_tests;
 162     my $dir  = catdir($cwd, 'remove');
 163     my $dir2 = catdir($cwd, 'remove', 'this', 'dir');
 164
 165     skip "failed to mkpath '$dir2': $!", $nr_tests
 166         unless mkpath($dir2, {verbose => 0});
 167     skip "failed to chdir dir '$dir2': $!", $nr_tests
 168         unless chdir($dir2);
 169
 170     rmtree($dir, {error => \$error});
 171     my $nr_err = @$error;
 172 # 16
 173     is($nr_err, 1, "ancestor error");
 174
 175     if ($nr_err) {
 176         my ($file, $message) = each %{$error->[0]};
 177 # 17
 178         is($file, $dir, "ancestor named");
 179         my $ortho_dir = $^O eq 'MSWin32' ? File::Path::_slash_lc($dir2) : $dir2;
 180         $^O eq 'MSWin32' and $message
 181             =~ s/\A(cannot remove path when cwd is )(.*)\Z/$1 . File::Path::_slash_lc($2)/e;
 182 # 18
 183         is($message, "cannot remove path when cwd is $ortho_dir", "ancestor reason");
 184 # 19
 185         ok(-d $dir2, "child not removed");
 186 # 20
 187         ok(-d $dir, "ancestor not removed");
 188     }
 189     else {
 190         fail( "ancestor 1");
 191         fail( "ancestor 2");
 192         fail( "ancestor 3");
 193         fail( "ancestor 4");
 194     }
 195     chdir $cwd;
 196     rmtree($dir);
 197 # 21
 198     ok(!(-d $dir), "ancestor now removed");
 199 };
 200
 201 my $count = rmtree({error => \$error});
 202 # 22
 203 is( $count, 0, 'rmtree of nothing, count of zero' );
 204 # 23
 205 is( scalar(@$error), 0, 'no diagnostic captured' );
 206
 207 @created = mkpath($tmp_base, 0);
 208 # 24
 209 is(scalar(@created), 0, "skipped making existing directories (old style 1)")
 210     or diag("unexpectedly recreated @created");
 211
 212 $dir = catdir($tmp_base,'C');
 213 # mkpath returns unix syntax filespecs on VMS
 214 $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 215 @created = make_path($tmp_base, $dir);
 216 # 25
 217 is(scalar(@created), 1, "created directory (new style 1)");
 218 # 26
 219 is($created[0], $dir, "created directory (new style 1) cross-check");
 220
 221 @created = mkpath($tmp_base, 0, 0700);
 222 # 27
 223 is(scalar(@created), 0, "skipped making existing directories (old style 2)")
 224     or diag("unexpectedly recreated @created");
 225
 226 $dir2 = catdir($tmp_base,'D');
 227 # mkpath returns unix syntax filespecs on VMS
 228 $dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS;
 229 @created = make_path($tmp_base, $dir, $dir2);
 230 # 28
 231 is(scalar(@created), 1, "created directory (new style 2)");
 232 # 29
 233 is($created[0], $dir2, "created directory (new style 2) cross-check");
 234
 235 $count = rmtree($dir, 0);
 236 # 30
 237 is($count, 1, "removed directory unsafe mode");
 238
 239 $count = rmtree($dir2, 0, 1);
 240 my $removed = $Is_VMS ? 0 : 1;
 241 # 31
 242 is($count, $removed, "removed directory safe mode");
 243
 244 # mkdir foo ./E/../Y
 245 # Y should exist
 246 # existence of E is neither here nor there
 247 $dir = catdir($tmp_base, 'E', updir(), 'Y');
 248 @created =mkpath($dir);
 249 # 32
 250 cmp_ok(scalar(@created), '>=', 1, "made one or more dirs because of ..");
 251 # 33
 252 cmp_ok(scalar(@created), '<=', 2, "made less than two dirs because of ..");
 253 # 34
 254 ok( -d catdir($tmp_base, 'Y'), "directory after parent" );
 255
 256 @created = make_path(catdir(curdir(), $tmp_base));
 257 # 35
 258 is(scalar(@created), 0, "nothing created")
 259     or diag(@created);
 260
 261 $dir  = catdir($tmp_base, 'a');
 262 $dir2 = catdir($tmp_base, 'z');
 263
 264 rmtree( $dir, $dir2,
 265     {
 266         error     => \$error,
 267         result    => \$list,
 268         keep_root => 1,
 269     }
 270 );
 271
 272 # 36
 273 is(scalar(@$error), 0, "no errors unlinking a and z");
 274 # 37
 275 is(scalar(@$list),  4, "list contains 4 elements")
 276     or diag("@$list");
 277 # 38
 278 ok(-d $dir,  "dir a still exists");
 279 # 39
 280 ok(-d $dir2, "dir z still exists");
 281
 282 $dir = catdir($tmp_base,'F');
 283 # mkpath returns unix syntax filespecs on VMS
 284 $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 285
 286 @created = mkpath($dir, undef, 0770);
 287 # 40
 288 is(scalar(@created), 1, "created directory (old style 2 verbose undef)");
 289 # 41
 290 is($created[0], $dir, "created directory (old style 2 verbose undef) cross-check");
 291 # 42
 292 is(rmtree($dir, undef, 0), 1, "removed directory 2 verbose undef");
 293
 294 @created = mkpath($dir, undef);
 295 # 43
 296 is(scalar(@created), 1, "created directory (old style 2a verbose undef)");
 297 # 44
 298 is($created[0], $dir, "created directory (old style 2a verbose undef) cross-check");
 299 # 45
 300 is(rmtree($dir, undef), 1, "removed directory 2a verbose undef");
 301
 302 @created = mkpath($dir, 0, undef);
 303 # 46
 304 is(scalar(@created), 1, "created directory (old style 3 mode undef)");
 305 # 47
 306 is($created[0], $dir, "created directory (old style 3 mode undef) cross-check");
 307 # 48
 308 is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef");
 309
 310 $dir = catdir($tmp_base,'G');
 311 $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 312
 313 @created = mkpath($dir, undef, 0200);
 314 # 49
 315 is(scalar(@created), 1, "created write-only dir");
 316 # 50
 317 is($created[0], $dir, "created write-only directory cross-check");
 318 # 51
 319 is(rmtree($dir), 1, "removed write-only dir");
 320
 321 # borderline new-style heuristics
 322 if (chdir $tmp_base) {
 323     pass("chdir to temp dir");
 324 }
 325 else {
 326     fail("chdir to temp dir: $!");
 327 }
 328
 329 $dir   = catdir('a', 'd1');
 330 $dir2  = catdir('a', 'd2');
 331
 332 @created = make_path( $dir, 0, $dir2 );
 333 # 52
 334 is(scalar @created, 3, 'new-style 3 dirs created');
 335
 336 $count = remove_tree( $dir, 0, $dir2, );
 337 # 53
 338 is($count, 3, 'new-style 3 dirs removed');
 339
 340 @created = make_path( $dir, $dir2, 1 );
 341 # 54
 342 is(scalar @created, 3, 'new-style 3 dirs created (redux)');
 343
 344 $count = remove_tree( $dir, $dir2, 1 );
 345 # 55
 346 is($count, 3, 'new-style 3 dirs removed (redux)');
 347
 348 @created = make_path( $dir, $dir2 );
 349 # 56
 350 is(scalar @created, 2, 'new-style 2 dirs created');
 351
 352 $count = remove_tree( $dir, $dir2 );
 353 # 57
 354 is($count, 2, 'new-style 2 dirs removed');
 355
 356 $dir = catdir("a\nb", 'd1');
 357 $dir2 = catdir("a\nb", 'd2');
 358
 359
 360
 361 SKIP: {
 362   # Better to search for *nix derivatives?
 363   # Not sure what else doesn't support newline in paths
 364   skip "This is a MSWin32 platform", 2
 365     if $^O eq 'MSWin32';
 366
 367   @created = make_path( $dir, $dir2 );
 368 # 58
 369   is(scalar @created, 3, 'new-style 3 dirs created in parent with newline');
 370
 371   $count = remove_tree( $dir, $dir2 );
 372 # 59
 373   is($count, 2, 'new-style 2 dirs removed in parent with newline');
 374 }
 375
 376 if (chdir updir()) {
 377     pass("chdir parent");
 378 }
 379 else {
 380     fail("chdir parent: $!");
 381 }
 382
 383 SKIP: {
 384     skip "This is not a MSWin32 platform", 3
 385         unless $^O eq 'MSWin32';
 386
 387     my $UNC_path = catdir(getcwd(), $tmp_base, 'uncdir');
 388     #dont compute a SMB path with $ENV{COMPUTERNAME}, since SMB may be turned off
 389     #firewalled, disabled, blocked, or no NICs are on and there the PC has no
 390     #working TCPIP stack, \\?\ will always work
 391     $UNC_path = '\\\\?\\'.$UNC_path;
 392 # 60
 393     is(mkpath($UNC_path), 1, 'mkpath on Win32 UNC path returns made 1 dir');
 394 # 61
 395     ok(-d $UNC_path, 'mkpath on Win32 UNC path made dir');
 396
 397     my $removed = rmtree($UNC_path);
 398 # 62
 399     cmp_ok($removed, '>', 0, "removed $removed entries from $UNC_path");
 400 }
 401
 402 SKIP: {
 403     # test bug http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=487319
 404     skip "Don't need Force_Writeable semantics on $^O", 6
 405         if grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
 406     skip "Symlinks not available", 6 unless $Config{d_symlink};
 407     $dir  = 'bug487319';
 408     $dir2 = 'bug487319-symlink';
 409     @created = make_path($dir, {mask => 0700});
 410 # 63
 411     is( scalar @created, 1, 'bug 487319 setup' );
 412     symlink($dir, $dir2);
 413 # 64
 414     ok(-e $dir2, "debian bug 487319 setup symlink") or diag($dir2);
 415
 416     chmod 0500, $dir;
 417     my $mask_initial = (stat $dir)[2];
 418     remove_tree($dir2);
 419
 420     my $mask = (stat $dir)[2];
 421 # 65
 422     is( $mask, $mask_initial, 'mask of symlink target dir unchanged (debian bug 487319)');
 423
 424     # now try a file
 425     #my $file = catfile($dir, 'file');
 426     my $file  = 'bug487319-file';
 427     my $file2 = 'bug487319-file-symlink';
 428     open my $out, '>', $file;
 429     close $out;
 430 # 66
 431     ok(-e $file, 'file exists');
 432
 433     chmod 0500, $file;
 434     $mask_initial = (stat $file)[2];
 435
 436     symlink($file, $file2);
 437 # 67
 438     ok(-e $file2, 'file2 exists');
 439     remove_tree($file2);
 440
 441     $mask = (stat $file)[2];
 442 # 68
 443     is( $mask, $mask_initial, 'mask of symlink target file unchanged (debian bug 487319)');
 444
 445     remove_tree($dir);
 446     remove_tree($file);
 447 }
 448
 449 # see what happens if a file exists where we want a directory
 450 SKIP: {
 451     my $entry = catfile($tmp_base, "file");
 452     skip "VMS can have a file and a directory with the same name.", 4
 453         if $Is_VMS;
 454     skip "Cannot create $entry", 4 unless open OUT, "> $entry";
 455     print OUT "test file, safe to delete\n", scalar(localtime), "\n";
 456     close OUT;
 457     ok(-e $entry, "file exists in place of directory");
 458
 459     mkpath( $entry, {error => \$error} );
 460     is( scalar(@$error), 1, "caught error condition" );
 461     ($file, $message) = each %{$error->[0]};
 462     is( $entry, $file, "and the message is: $message");
 463
 464     eval {@created = mkpath($entry, 0, 0700)};
 465     $error = $@;
 466     chomp $error; # just to remove silly # in TAP output
 467     cmp_ok( $error, 'ne', "", "no directory created (old-style) err=$error" )
 468         or diag(@created);
 469 }
 470
 471 my $extra =  catdir(curdir(), qw(EXTRA 1 a));
 472
 473 SKIP: {
 474     skip "extra scenarios not set up, see eg/setup-extra-tests", 14
 475         unless -e $extra;
 476     skip "Symlinks not available", 14 unless $Config{d_symlink};
 477
 478     my ($list, $err);
 479     $dir = catdir( 'EXTRA', '1' );
 480     rmtree( $dir, {result => \$list, error => \$err} );
 481     is(scalar(@$list), 2, "extra dir $dir removed");
 482     is(scalar(@$err), 1, "one error encountered");
 483
 484     $dir = catdir( 'EXTRA', '3', 'N' );
 485     rmtree( $dir, {result => \$list, error => \$err} );
 486     is( @$list, 1, q{remove a symlinked dir} );
 487     is( @$err,  0, q{with no errors} );
 488
 489     $dir = catdir('EXTRA', '3', 'S');
 490     rmtree($dir, {error => \$error});
 491     is( scalar(@$error), 1, 'one error for an unreadable dir' );
 492     eval { ($file, $message) = each %{$error->[0]}};
 493     is( $file, $dir, 'unreadable dir reported in error' )
 494         or diag($message);
 495
 496     $dir = catdir('EXTRA', '3', 'T');
 497     rmtree($dir, {error => \$error});
 498     is( scalar(@$error), 1, 'one error for an unreadable dir T' );
 499     eval { ($file, $message) = each %{$error->[0]}};
 500     is( $file, $dir, 'unreadable dir reported in error T' );
 501
 502     $dir = catdir( 'EXTRA', '4' );
 503     rmtree($dir,  {result => \$list, error => \$err} );
 504     is( scalar(@$list), 0, q{don't follow a symlinked dir} );
 505     is( scalar(@$err),  2, q{two errors when removing a symlink in r/o dir} );
 506     eval { ($file, $message) = each %{$err->[0]} };
 507     is( $file, $dir, 'symlink reported in error' );
 508
 509     $dir  = catdir('EXTRA', '3', 'U');
 510     $dir2 = catdir('EXTRA', '3', 'V');
 511     rmtree($dir, $dir2, {verbose => 0, error => \$err, result => \$list});
 512     is( scalar(@$list),  1, q{deleted 1 out of 2 directories} );
 513     is( scalar(@$error), 1, q{left behind 1 out of 2 directories} );
 514     eval { ($file, $message) = each %{$err->[0]} };
 515     is( $file, $dir, 'first dir reported in error' );
 516 }
 517
 518 {
 519     $dir = catdir($tmp_base, 'ZZ');
 520     @created = mkpath($dir);
 521     is(scalar(@created), 1, "create a ZZ directory");
 522
 523     local @ARGV = ($dir);
 524     rmtree( [grep -e $_, @ARGV], 0, 0 );
 525     ok(!-e $dir, "blow it away via \@ARGV");
 526 }
 527
 528 SKIP : {
 529     my $skip_count = 19;
 530     #this test will fail on Windows, as per: http://perldoc.perl.org/perlport.html#chmod
 531     skip "Windows chmod test skipped", $skip_count
 532         if $^O eq 'MSWin32';
 533     my $mode;
 534     my $octal_mode;
 535     my @inputs = (
 536       0777, 0700, 0070, 0007,
 537       0333, 0300, 0030, 0003,
 538       0111, 0100, 0010, 0001,
 539       0731, 0713, 0317, 0371, 0173, 0137,
 540       00 );
 541     my $input;
 542     my $octal_input;
 543     $dir = catdir($tmp_base, 'chmod_test');
 544
 545     foreach (@inputs) {
 546         $input = $_;
 547         @created = mkpath($dir, {chmod => $input});
 548         $mode = (stat($dir))[2];
 549         $octal_mode = S_IMODE($mode);
 550         $octal_input = sprintf "%04o", S_IMODE($input);
 551         is($octal_mode,$input, "create a new directory with chmod $input ($octal_input)");
 552         rmtree( $dir );
 553     }
 554 }
 555
 556 SKIP: {
 557     my $skip_count = 8; # DRY
 558     skip "getpwent() not implemented on $^O", $skip_count
 559         unless $Config{d_getpwent};
 560     skip "getgrent() not implemented on $^O", $skip_count
 561         unless $Config{d_getgrent};
 562     skip 'not running as root', $skip_count
 563         unless $< == 0;
 564     skip "darwin's nobody and nogroup are -1", $skip_count
 565         if $^O eq 'darwin';
 566
 567     my $dir_stem = $dir = catdir($tmp_base, 'owned-by');
 568
 569     # find the highest uid ('nobody' or similar)
 570     my $max_uid   = 0;
 571     my $max_user = undef;
 572     while (my @u = getpwent()) {
 573         if ($max_uid < $u[2]) {
 574             $max_uid  = $u[2];
 575             $max_user = $u[0];
 576         }
 577     }
 578     skip 'getpwent() appears to be insane', $skip_count
 579         unless $max_uid > 0;
 580
 581     # find the highest gid ('nogroup' or similar)
 582     my $max_gid   = 0;
 583     my $max_group = undef;
 584     while (my @g = getgrent()) {
 585         if ($max_gid < $g[2]) {
 586             $max_gid = $g[2];
 587             $max_group = $g[0];
 588         }
 589     }
 590     skip 'getgrent() appears to be insane', $skip_count
 591         unless $max_gid > 0;
 592
 593     $dir = catdir($dir_stem, 'aaa');
 594     @created = make_path($dir, {owner => $max_user});
 595     is(scalar(@created), 2, "created a directory owned by $max_user...");
 596     my $dir_uid = (stat $created[0])[4];
 597     is($dir_uid, $max_uid, "... owned by $max_uid");
 598
 599     $dir = catdir($dir_stem, 'aab');
 600     @created = make_path($dir, {group => $max_group});
 601     is(scalar(@created), 1, "created a directory owned by group $max_group...");
 602     my $dir_gid = (stat $created[0])[5];
 603     is($dir_gid, $max_gid, "... owned by group $max_gid");
 604
 605     $dir = catdir($dir_stem, 'aac');
 606     @created = make_path($dir, {user => $max_user, group => $max_group});
 607     is(scalar(@created), 1, "created a directory owned by $max_user:$max_group...");
 608     ($dir_uid, $dir_gid) = (stat $created[0])[4,5];
 609     is($dir_uid, $max_uid, "... owned by $max_uid");
 610     is($dir_gid, $max_gid, "... owned by group $max_gid");
 611
 612     SKIP: {
 613         skip 'Test::Output not available', 1
 614                unless $has_Test_Output;
 615
 616         # invent a user and group that don't exist
 617         do { ++$max_user  } while (getpwnam($max_user));
 618         do { ++$max_group } while (getgrnam($max_group));
 619
 620         $dir = catdir($dir_stem, 'aad');
 621         stderr_like(
 622             sub {make_path($dir, {user => $max_user, group => $max_group})},
 623             qr{\Aunable to map $max_user to a uid, ownership not changed: .* at \S+ line \d+
 624 unable to map $max_group to a gid, group ownership not changed: .* at \S+ line \d+\b},
 625             "created a directory not owned by $max_user:$max_group..."
 626         );
 627     }
 628 }
 629
 630 SKIP: {
 631     skip 'Test::Output not available', 18
 632         unless $has_Test_Output;
 633
 634     SKIP: {
 635         $dir = catdir('EXTRA', '3');
 636         skip "extra scenarios not set up, see eg/setup-extra-tests", 3
 637             unless -e $dir;
 638
 639         $dir = catdir('EXTRA', '3', 'U');
 640         stderr_like(
 641             sub {rmtree($dir, {verbose => 0})},
 642             qr{\Acannot make child directory read-write-exec for [^:]+: .* at \S+ line \d+},
 643             q(rmtree can't chdir into root dir)
 644         );
 645
 646         $dir = catdir('EXTRA', '3');
 647         stderr_like(
 648             sub {rmtree($dir, {})},
 649             qr{\Acannot make child directory read-write-exec for [^:]+: .* at (\S+) line (\d+)
 650 cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
 651 cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
 652 cannot remove directory for [^:]+: .* at \1 line \2},
 653             'rmtree with file owned by root'
 654         );
 655
 656         stderr_like(
 657             sub {rmtree('EXTRA', {})},
 658             qr{\Acannot remove directory for [^:]+: .* at (\S+) line (\d+)
 659 cannot remove directory for [^:]+: .* at \1 line \2
 660 cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
 661 cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
 662 cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
 663 cannot remove directory for [^:]+: .* at \1 line \2
 664 cannot unlink file for [^:]+: .* at \1 line \2
 665 cannot restore permissions to \d+ for [^:]+: .* at \1 line \2
 666 cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
 667 cannot remove directory for [^:]+: .* at \1 line \2},
 668             'rmtree with insufficient privileges'
 669         );
 670     }
 671
 672     my $base = catdir($tmp_base,'output');
 673     $dir  = catdir($base,'A');
 674     $dir2 = catdir($base,'B');
 675
 676     stderr_like(
 677         sub { rmtree( undef, 1 ) },
 678         qr/\ANo root path\(s\) specified\b/,
 679         "rmtree of nothing carps sensibly"
 680     );
 681
 682     stderr_like(
 683         sub { rmtree( '', 1 ) },
 684         qr/\ANo root path\(s\) specified\b/,
 685         "rmtree of empty dir carps sensibly"
 686     );
 687
 688     stderr_is( sub { make_path() }, '', "make_path no args does not carp" );
 689     stderr_is( sub { remove_tree() }, '', "remove_tree no args does not carp" );
 690     stderr_is( sub { mkpath() }, '', "mkpath no args does not carp" );
 691
 692     stdout_is(
 693         sub {@created = mkpath($dir, 1)},
 694         "mkdir $base\nmkdir $dir\n",
 695         'mkpath verbose (old style 1)'
 696     );
 697
 698     stdout_is(
 699         sub {@created = mkpath([$dir2], 1)},
 700         "mkdir $dir2\n",
 701         'mkpath verbose (old style 2)'
 702     );
 703
 704     stdout_is(
 705         sub {$count = rmtree([$dir, $dir2], 1, 1)},
 706         "rmdir $dir\nrmdir $dir2\n",
 707         'rmtree verbose (old style)'
 708     );
 709
 710     stdout_is(
 711         sub {@created = mkpath($dir, {verbose => 1, mask => 0750})},
 712         "mkdir $dir\n",
 713         'mkpath verbose (new style 1)'
 714     );
 715
 716     stdout_is(
 717         sub {@created = mkpath($dir2, 1, 0771)},
 718         "mkdir $dir2\n",
 719         'mkpath verbose (new style 2)'
 720     );
 721
 722     stdout_is(
 723         sub {$count = rmtree([$dir, $dir2], 1, 1)},
 724         "rmdir $dir\nrmdir $dir2\n",
 725         'again: rmtree verbose (old style)'
 726     );
 727
 728     stdout_is(
 729         sub {
 730             @created = make_path(
 731                 $dir,
 732                 $dir2,
 733                 { verbose => 1, mode => 0711 }
 734             );
 735         },
 736         "mkdir $dir\nmkdir $dir2\n",
 737         'make_path verbose with final hashref'
 738     );
 739
 740     # {
 741     #     local $@;
 742     #     eval {
 743     #         @created = make_path(
 744     #             $dir,
 745     #             $dir2,
 746     #             { verbose => 1, mode => 0711, foo => 1, bar => 1 }
 747     #         );
 748     #     };
 749     #     like($@,
 750     #         qr/Unrecognized option\(s\) passed to make_path\(\):.*?bar.*?foo/,
 751     #         'make_path with final hashref failed due to unrecognized options'
 752     #     );
 753     # }
 754     #
 755     # {
 756     #     local $@;
 757     #     eval {
 758     #         @created = remove_tree(
 759     #             $dir,
 760     #             $dir2,
 761     #             { verbose => 1, foo => 1, bar => 1 }
 762     #         );
 763     #     };
 764     #     like($@,
 765     #         qr/Unrecognized option\(s\) passed to remove_tree\(\):.*?bar.*?foo/,
 766     #         'remove_tree with final hashref failed due to unrecognized options'
 767     #     );
 768     # }
 769
 770     stdout_is(
 771         sub {
 772             @created = remove_tree(
 773                 $dir,
 774                 $dir2,
 775                 { verbose => 1 }
 776             );
 777         },
 778         "rmdir $dir\nrmdir $dir2\n",
 779         'remove_tree verbose with final hashref'
 780     );
 781
 782     SKIP: {
 783         $file = catdir($dir2, "file");
 784         skip "Cannot create $file", 2 unless open OUT, "> $file";
 785         print OUT "test file, safe to delete\n", scalar(localtime), "\n";
 786         close OUT;
 787
 788         ok(-e $file, "file created in directory");
 789
 790         stdout_is(
 791             sub {$count = rmtree($dir, $dir2, {verbose => 1, safe => 1})},
 792             "rmdir $dir\nunlink $file\nrmdir $dir2\n",
 793             'rmtree safe verbose (new style)'
 794         );
 795     }
 796 }
 797
 798 SKIP: {
 799     skip "extra scenarios not set up, see eg/setup-extra-tests", 11
 800         unless -d catdir(qw(EXTRA 1));
 801
 802     rmtree 'EXTRA', {safe => 0, error => \$error};
 803     is( scalar(@$error), 10, 'seven deadly sins' ); # well there used to be 7
 804
 805     rmtree 'EXTRA', {safe => 1, error => \$error};
 806     is( scalar(@$error), 9, 'safe is better' );
 807     for (@$error) {
 808         ($file, $message) = each %$_;
 809         if ($file =~  /[123]\z/) {
 810             is(index($message, 'cannot remove directory: '), 0, "failed to remove $file with rmdir")
 811                 or diag($message);
 812         }
 813         else {
 814             like($message, qr(\Acannot (?:restore permissions to \d+|chdir to child|unlink file): ), "failed to remove $file with unlink")
 815                 or diag($message)
 816         }
 817     }
 818 }
 819
 820 SKIP: {
 821     my $nr_tests = 6;
 822     my $cwd = getcwd() or skip "failed to getcwd: $!", $nr_tests;
 823     rmtree($tmp_base, {result => \$list} );
 824     is(ref($list), 'ARRAY', "received a final list of results");
 825     ok( !(-d $tmp_base), "test base directory gone" );
 826
 827     my $p = getcwd();
 828     my $x = "x$$";
 829     my $xx = $x . "x";
 830
 831     # setup
 832     ok(mkpath($xx), "make $xx");
 833     ok(chdir($xx), "... and chdir $xx");
 834     END {
 835          ok(chdir($p), "... now chdir $p");
 836          ok(rmtree($xx), "... and finally rmtree $xx");
 837     }
 838
 839     # create and delete directory
 840     my $px = catdir($p, $x);
 841     ok(mkpath($px), 'create and delete directory 2.07');
 842     ok(rmtree($px), '.. rmtree fails in File-Path-2.07');
 843 }
 844
 845 my $windows_dir = 'C:\Path\To\Dir';
 846 my $expect = 'c:/path/to/dir';
 847 is(
 848     File::Path::_slash_lc($windows_dir),
 849     $expect,
 850     "Windows path unixified as expected"
 851 );