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 => 167;
   7 use Config;
   8 use Fcntl ':mode';
   9 use lib './t';
  10 use FilePathTest qw(
  11     _run_for_warning
  12     _run_for_verbose
  13     _cannot_delete_safe_mode
  14     _verbose_expected
  15     create_3_level_subdirs
  16     cleanup_3_level_subdirs
  17 );
  18 use Errno qw(:POSIX);
  19 use Carp;
  20
  21 BEGIN {
  22     use_ok('Cwd');
  23     use_ok('File::Path', qw(rmtree mkpath make_path remove_tree));
  24     use_ok('File::Spec::Functions');
  25 }
  26
  27 my $Is_VMS = $^O eq 'VMS';
  28
  29 my $fchmod_supported = 0;
  30 if (open my $fh, curdir()) {
  31     my ($perm) = (stat($fh))[2];
  32     $perm &= 07777;
  33     eval { $fchmod_supported = chmod( $perm, $fh); };
  34 }
  35
  36 # first check for stupid permissions second for full, so we clean up
  37 # behind ourselves
  38 for my $perm (0111,0777) {
  39     my $path = catdir(curdir(), "mhx", "bar");
  40     mkpath($path);
  41     chmod $perm, "mhx", $path;
  42
  43     my $oct = sprintf('0%o', $perm);
  44
  45     ok(-d "mhx", "mkdir parent dir $oct");
  46     ok(-d $path, "mkdir child dir $oct");
  47
  48     rmtree("mhx");
  49
  50     ok(! -e "mhx", "mhx does not exist $oct");
  51 }
  52
  53 # find a place to work
  54 my ($error, $list, $file, $message);
  55 my $tmp_base = catdir(
  56     curdir(),
  57     sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
  58 );
  59
  60 # invent some names
  61 my @dir = (
  62     catdir($tmp_base, qw(a b)),
  63     catdir($tmp_base, qw(a c)),
  64     catdir($tmp_base, qw(z b)),
  65     catdir($tmp_base, qw(z c)),
  66 );
  67
  68 # create them
  69 my @created = mkpath([@dir]);
  70
  71 is(scalar(@created), 7, "created list of directories");
  72
  73 # pray for no race conditions blowing them out from under us
  74 @created = mkpath([$tmp_base]);
  75 is(scalar(@created), 0, "skipped making existing directory")
  76     or diag("unexpectedly recreated @created");
  77
  78 # create a file
  79 my $file_name = catfile( $tmp_base, 'a', 'delete.me' );
  80 my $file_count = 0;
  81 if (open OUT, "> $file_name") {
  82     print OUT "this file may be deleted\n";
  83     close OUT;
  84     ++$file_count;
  85 }
  86 else {
  87     diag( "Failed to create file $file_name: $!" );
  88 }
  89
  90 SKIP: {
  91     skip "cannot remove a file we failed to create", 1
  92         unless $file_count == 1;
  93     my $count = rmtree($file_name);
  94     is($count, 1, "rmtree'ed a file");
  95 }
  96
  97 @created = mkpath('');
  98 is(scalar(@created), 0, "Can't create a directory named ''");
  99
 100 my $dir;
 101 my $dir2;
 102
 103 sub gisle {
 104     # background info: @_ = 1; !shift # gives '' not 0
 105     # Message-Id: <3C820CE6-4400-4E91-AF43-A3D19B356E68@activestate.com>
 106     # http://www.nntp.perl.org/group/perl.perl5.porters/2008/05/msg136625.html
 107     mkpath(shift, !shift, 0755);
 108 }
 109
 110 sub count {
 111     opendir D, shift or return -1;
 112     my $count = () = readdir D;
 113     closedir D or return -1;
 114     return $count;
 115 }
 116
 117 {
 118     mkdir 'solo', 0755;
 119     chdir 'solo';
 120     open my $f, '>', 'foo.dat';
 121     close $f;
 122     my $before = count(curdir());
 123     cmp_ok($before, '>', 0, "baseline $before");
 124
 125     gisle('1st', 1);
 126     is(count(curdir()), $before + 1, "first after $before");
 127
 128     $before = count(curdir());
 129     gisle('2nd', 1);
 130
 131     is(count(curdir()), $before + 1, "second after $before");
 132
 133     chdir updir();
 134     rmtree 'solo';
 135 }
 136
 137 {
 138     mkdir 'solo', 0755;
 139     chdir 'solo';
 140     open my $f, '>', 'foo.dat';
 141     close $f;
 142     my $before = count(curdir());
 143
 144     cmp_ok($before, '>', 0, "ARGV $before");
 145     {
 146         local @ARGV = (1);
 147         mkpath('3rd', !shift, 0755);
 148     }
 149
 150     is(count(curdir()), $before + 1, "third after $before");
 151
 152     $before = count(curdir());
 153     {
 154         local @ARGV = (1);
 155         mkpath('4th', !shift, 0755);
 156     }
 157
 158     is(count(curdir()), $before + 1, "fourth after $before");
 159
 160     chdir updir();
 161     rmtree 'solo';
 162 }
 163
 164 SKIP: {
 165     # tests for rmtree() of ancestor directory
 166     my $nr_tests = 6;
 167     my $cwd = getcwd() or skip "failed to getcwd: $!", $nr_tests;
 168     my $dir  = catdir($cwd, 'remove');
 169     my $dir2 = catdir($cwd, 'remove', 'this', 'dir');
 170
 171     skip "failed to mkpath '$dir2': $!", $nr_tests
 172         unless mkpath($dir2, {verbose => 0});
 173     skip "failed to chdir dir '$dir2': $!", $nr_tests
 174         unless chdir($dir2);
 175
 176     rmtree($dir, {error => \$error});
 177     my $nr_err = @$error;
 178
 179     is($nr_err, 1, "ancestor error");
 180
 181     if ($nr_err) {
 182         my ($file, $message) = each %{$error->[0]};
 183
 184         is($file, $dir, "ancestor named");
 185         my $ortho_dir = $^O eq 'MSWin32' ? File::Path::_slash_lc($dir2) : $dir2;
 186         $^O eq 'MSWin32' and $message
 187             =~ s/\A(cannot remove path when cwd is )(.*)\Z/$1 . File::Path::_slash_lc($2)/e;
 188
 189         is($message, "cannot remove path when cwd is $ortho_dir", "ancestor reason");
 190
 191         ok(-d $dir2, "child not removed");
 192
 193         ok(-d $dir, "ancestor not removed");
 194     }
 195     else {
 196         fail( "ancestor 1");
 197         fail( "ancestor 2");
 198         fail( "ancestor 3");
 199         fail( "ancestor 4");
 200     }
 201     chdir $cwd;
 202     rmtree($dir);
 203
 204     ok(!(-d $dir), "ancestor now removed");
 205 };
 206
 207 my $count = rmtree({error => \$error});
 208
 209 is( $count, 0, 'rmtree of nothing, count of zero' );
 210
 211 is( scalar(@$error), 0, 'no diagnostic captured' );
 212
 213 @created = mkpath($tmp_base, 0);
 214
 215 is(scalar(@created), 0, "skipped making existing directories (old style 1)")
 216     or diag("unexpectedly recreated @created");
 217
 218 $dir = catdir($tmp_base,'C');
 219 # mkpath returns unix syntax filespecs on VMS
 220 $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 221 @created = make_path($tmp_base, $dir);
 222
 223 is(scalar(@created), 1, "created directory (new style 1)");
 224
 225 is($created[0], $dir, "created directory (new style 1) cross-check");
 226
 227 @created = mkpath($tmp_base, 0, 0700);
 228
 229 is(scalar(@created), 0, "skipped making existing directories (old style 2)")
 230     or diag("unexpectedly recreated @created");
 231
 232 $dir2 = catdir($tmp_base,'D');
 233 # mkpath returns unix syntax filespecs on VMS
 234 $dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS;
 235 @created = make_path($tmp_base, $dir, $dir2);
 236
 237 is(scalar(@created), 1, "created directory (new style 2)");
 238
 239 is($created[0], $dir2, "created directory (new style 2) cross-check");
 240
 241 $count = rmtree($dir, 0);
 242
 243 is($count, 1, "removed directory unsafe mode");
 244
 245 my $expected_count = _cannot_delete_safe_mode($dir2) ? 0 : 1;
 246
 247 $count = rmtree($dir2, 0, 1);
 248
 249 is($count, $expected_count, "removed directory safe mode");
 250
 251 # mkdir foo ./E/../Y
 252 # Y should exist
 253 # existence of E is neither here nor there
 254 $dir = catdir($tmp_base, 'E', updir(), 'Y');
 255 @created =mkpath($dir);
 256
 257 cmp_ok(scalar(@created), '>=', 1, "made one or more dirs because of ..");
 258
 259 cmp_ok(scalar(@created), '<=', 2, "made less than two dirs because of ..");
 260
 261 ok( -d catdir($tmp_base, 'Y'), "directory after parent" );
 262
 263 @created = make_path(catdir(curdir(), $tmp_base));
 264
 265 is(scalar(@created), 0, "nothing created")
 266     or diag(@created);
 267
 268 $dir  = catdir($tmp_base, 'a');
 269 $dir2 = catdir($tmp_base, 'z');
 270
 271 rmtree( $dir, $dir2,
 272     {
 273         error     => \$error,
 274         result    => \$list,
 275         keep_root => 1,
 276     }
 277 );
 278
 279
 280 is(scalar(@$error), 0, "no errors unlinking a and z");
 281
 282 is(scalar(@$list),  4, "list contains 4 elements")
 283     or diag("@$list");
 284
 285 ok(-d $dir,  "dir a still exists");
 286
 287 ok(-d $dir2, "dir z still exists");
 288
 289 $dir = catdir($tmp_base,'F');
 290 # mkpath returns unix syntax filespecs on VMS
 291 $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 292
 293 @created = mkpath($dir, undef, 0770);
 294
 295 is(scalar(@created), 1, "created directory (old style 2 verbose undef)");
 296
 297 is($created[0], $dir, "created directory (old style 2 verbose undef) cross-check");
 298
 299 is(rmtree($dir, undef, 0), 1, "removed directory 2 verbose undef");
 300
 301 @created = mkpath($dir, undef);
 302
 303 is(scalar(@created), 1, "created directory (old style 2a verbose undef)");
 304
 305 is($created[0], $dir, "created directory (old style 2a verbose undef) cross-check");
 306
 307 is(rmtree($dir, undef), 1, "removed directory 2a verbose undef");
 308
 309 @created = mkpath($dir, 0, undef);
 310
 311 is(scalar(@created), 1, "created directory (old style 3 mode undef)");
 312
 313 is($created[0], $dir, "created directory (old style 3 mode undef) cross-check");
 314
 315 is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef");
 316
 317 SKIP: {
 318     skip "fchmod of directories not supported on this platform", 3 unless $fchmod_supported;
 319     $dir = catdir($tmp_base,'G');
 320     $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 321
 322     @created = mkpath($dir, undef, 0400);
 323
 324     is(scalar(@created), 1, "created read-only dir");
 325
 326     is($created[0], $dir, "created read-only directory cross-check");
 327
 328     is(rmtree($dir), 1, "removed read-only dir");
 329 }
 330
 331 # borderline new-style heuristics
 332 if (chdir $tmp_base) {
 333     pass("chdir to temp dir");
 334 }
 335 else {
 336     fail("chdir to temp dir: $!");
 337 }
 338
 339 $dir   = catdir('a', 'd1');
 340 $dir2  = catdir('a', 'd2');
 341
 342 @created = make_path( $dir, 0, $dir2 );
 343
 344 is(scalar @created, 3, 'new-style 3 dirs created');
 345
 346 $count = remove_tree( $dir, 0, $dir2, );
 347
 348 is($count, 3, 'new-style 3 dirs removed');
 349
 350 @created = make_path( $dir, $dir2, 1 );
 351
 352 is(scalar @created, 3, 'new-style 3 dirs created (redux)');
 353
 354 $count = remove_tree( $dir, $dir2, 1 );
 355
 356 is($count, 3, 'new-style 3 dirs removed (redux)');
 357
 358 @created = make_path( $dir, $dir2 );
 359
 360 is(scalar @created, 2, 'new-style 2 dirs created');
 361
 362 $count = remove_tree( $dir, $dir2 );
 363
 364 is($count, 2, 'new-style 2 dirs removed');
 365
 366 $dir = catdir("a\nb", 'd1');
 367 $dir2 = catdir("a\nb", 'd2');
 368
 369 SKIP: {
 370   # Better to search for *nix derivatives?
 371   # Not sure what else doesn't support newline in paths
 372   skip "$^O doesn't allow newline in paths", 2
 373     if $^O =~ m/^(MSWin32|VMS)$/;
 374
 375   @created = make_path( $dir, $dir2 );
 376
 377   is(scalar @created, 3, 'new-style 3 dirs created in parent with newline');
 378
 379   $count = remove_tree( $dir, $dir2 );
 380
 381   is($count, 2, 'new-style 2 dirs removed in parent with newline');
 382 }
 383
 384 if (chdir updir()) {
 385     pass("chdir parent");
 386 }
 387 else {
 388     fail("chdir parent: $!");
 389 }
 390
 391 SKIP: {
 392     # test bug http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=487319
 393     skip "Don't need Force_Writeable semantics on $^O", 6
 394         if grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
 395     skip "Symlinks not available", 6 unless $Config{d_symlink};
 396     $dir  = 'bug487319';
 397     $dir2 = 'bug487319-symlink';
 398     @created = make_path($dir, {mask => 0700});
 399
 400     is( scalar @created, 1, 'bug 487319 setup' );
 401     symlink($dir, $dir2);
 402
 403     ok(-e $dir2, "debian bug 487319 setup symlink") or diag($dir2);
 404
 405     chmod 0500, $dir;
 406     my $mask_initial = (stat $dir)[2];
 407     remove_tree($dir2);
 408
 409     my $mask = (stat $dir)[2];
 410
 411     is( $mask, $mask_initial, 'mask of symlink target dir unchanged (debian bug 487319)');
 412
 413     # now try a file
 414     #my $file = catfile($dir, 'file');
 415     my $file  = 'bug487319-file';
 416     my $file2 = 'bug487319-file-symlink';
 417     open my $out, '>', $file;
 418     close $out;
 419
 420     ok(-e $file, 'file exists');
 421
 422     chmod 0500, $file;
 423     $mask_initial = (stat $file)[2];
 424
 425     symlink($file, $file2);
 426
 427     ok(-e $file2, 'file2 exists');
 428     remove_tree($file2);
 429
 430     $mask = (stat $file)[2];
 431
 432     is( $mask, $mask_initial, 'mask of symlink target file unchanged (debian bug 487319)');
 433
 434     remove_tree($dir);
 435     remove_tree($file);
 436 }
 437
 438 # see what happens if a file exists where we want a directory
 439 SKIP: {
 440     my $entry = catfile($tmp_base, "file");
 441     skip "VMS can have a file and a directory with the same name.", 4
 442         if $Is_VMS;
 443     skip "Cannot create $entry", 4 unless open OUT, "> $entry";
 444     print OUT "test file, safe to delete\n", scalar(localtime), "\n";
 445     close OUT;
 446     ok(-e $entry, "file exists in place of directory");
 447
 448     mkpath( $entry, {error => \$error} );
 449     is( scalar(@$error), 1, "caught error condition" );
 450     ($file, $message) = each %{$error->[0]};
 451     is( $entry, $file, "and the message is: $message");
 452
 453     eval {@created = mkpath($entry, 0, 0700)};
 454     $error = $@;
 455     chomp $error; # just to remove silly # in TAP output
 456     cmp_ok( $error, 'ne', "", "no directory created (old-style) err=$error" )
 457         or diag(@created);
 458 }
 459
 460 {
 461     $dir = catdir($tmp_base, 'ZZ');
 462     @created = mkpath($dir);
 463     is(scalar(@created), 1, "create a ZZ directory");
 464
 465     local @ARGV = ($dir);
 466     rmtree( [grep -e $_, @ARGV], 0, 0 );
 467     ok(!-e $dir, "blow it away via \@ARGV");
 468 }
 469
 470 SKIP : {
 471     my $skip_count = 18;
 472     # this test will fail on Windows, as per:
 473     #   http://perldoc.perl.org/perlport.html#chmod
 474
 475     skip "Windows chmod test skipped", $skip_count
 476         if $^O eq 'MSWin32';
 477     skip "fchmod() on directories is not supported on this platform", $skip_count
 478         unless $fchmod_supported;
 479     my $mode;
 480     my $octal_mode;
 481     my @inputs = (
 482       0777, 0700, 0470, 0407,
 483       0433, 0400, 0430, 0403,
 484       0111, 0100, 0110, 0101,
 485       0731, 0713, 0317, 0371,
 486       0173, 0137);
 487     my $input;
 488     my $octal_input;
 489
 490     foreach (@inputs) {
 491         $input = $_;
 492         $dir = catdir($tmp_base, sprintf("chmod_test%04o", $input));
 493         # We can skip from here because 0 is last in the list.
 494         skip "Mode of 0 means assume user defaults on VMS", 1
 495           if ($input == 0 && $Is_VMS);
 496         @created = mkpath($dir, {chmod => $input});
 497         $mode = (stat($dir))[2];
 498         $octal_mode = S_IMODE($mode);
 499         $octal_input = sprintf "%04o", S_IMODE($input);
 500         SKIP: {
 501             skip "permissions are not fully supported by the filesystem", 1
 502                 if (($^O eq 'MSWin32' || $^O eq 'cygwin') && ((Win32::FsType())[1] & 8) == 0);
 503             is($octal_mode,$input, "create a new directory with chmod $input ($octal_input)");
 504             }
 505         rmtree( $dir );
 506     }
 507 }
 508
 509 my $dir_base = catdir($tmp_base,'output');
 510 my $dir_a    = catdir($dir_base, 'A');
 511 my $dir_b    = catdir($dir_base, 'B');
 512
 513 is(_run_for_verbose(sub {@created = mkpath($dir_a, 1)}),
 514     _verbose_expected('mkpath', $dir_base, 0, 1)
 515     . _verbose_expected('mkpath', $dir_a, 0),
 516     'mkpath verbose (old style 1)'
 517 );
 518
 519 is(_run_for_verbose(sub {@created = mkpath([$dir_b], 1)}),
 520     _verbose_expected('mkpath', $dir_b, 0),
 521     'mkpath verbose (old style 2)'
 522 );
 523
 524 my $verbose_expected;
 525
 526 # Must determine expectations while directories still exist.
 527 $verbose_expected = _verbose_expected('rmtree', $dir_a, 1)
 528                   . _verbose_expected('rmtree', $dir_b, 1);
 529
 530 is(_run_for_verbose(sub {$count = rmtree([$dir_a, $dir_b], 1, 1)}),
 531     $verbose_expected,
 532     'rmtree verbose (old style)'
 533 );
 534
 535 # In case we didn't delete them in safe mode.
 536 rmtree($dir_a) if -d $dir_a;
 537 rmtree($dir_b) if -d $dir_b;
 538
 539 is(_run_for_verbose(sub {@created = mkpath( $dir_a,
 540                                             {verbose => 1, mask => 0750})}),
 541     _verbose_expected('mkpath', $dir_a, 0),
 542     'mkpath verbose (new style 1)'
 543 );
 544
 545 is(_run_for_verbose(sub {@created = mkpath($dir_b, 1, 0771)}),
 546     _verbose_expected('mkpath', $dir_b, 0),
 547     'mkpath verbose (new style 2)'
 548 );
 549
 550 $verbose_expected = _verbose_expected('rmtree', $dir_a, 1)
 551                   . _verbose_expected('rmtree', $dir_b, 1);
 552
 553 is(_run_for_verbose(sub {$count = rmtree([$dir_a, $dir_b], 1, 1)}),
 554     $verbose_expected,
 555     'again: rmtree verbose (old style)'
 556 );
 557
 558 rmtree($dir_a) if -d $dir_a;
 559 rmtree($dir_b) if -d $dir_b;
 560
 561 is(_run_for_verbose(sub {@created = make_path( $dir_a, $dir_b,
 562                                                {verbose => 1, mode => 0711});}),
 563       _verbose_expected('make_path', $dir_a, 1)
 564     . _verbose_expected('make_path', $dir_b, 1),
 565     'make_path verbose with final hashref'
 566 );
 567
 568 $verbose_expected = _verbose_expected('remove_tree', $dir_a, 0)
 569                   . _verbose_expected('remove_tree', $dir_b, 0);
 570
 571 is(_run_for_verbose(sub {@created = remove_tree( $dir_a, $dir_b,
 572                                                  {verbose => 1});}),
 573     $verbose_expected,
 574     'remove_tree verbose with final hashref'
 575 );
 576
 577 rmtree($dir_a) if -d $dir_a;
 578 rmtree($dir_b) if -d $dir_b;
 579
 580 # Have to re-create these 2 directories so that next block is not skipped.
 581 @created = make_path(
 582     $dir_a,
 583     $dir_b,
 584     { mode => 0711 }
 585 );
 586 is(@created, 2, "2 directories created");
 587
 588 SKIP: {
 589     $file = catfile($dir_b, "file");
 590     skip "Cannot create $file", 2 unless open OUT, "> $file";
 591     print OUT "test file, safe to delete\n", scalar(localtime), "\n";
 592     close OUT;
 593
 594     $verbose_expected = _verbose_expected('rmtree', $dir_a, 1)
 595                       . _verbose_expected('unlink', $file, 0)
 596                       . _verbose_expected('rmtree', $dir_b, 1);
 597
 598     ok(-e $file, "file created in directory");
 599
 600     is(_run_for_verbose(sub {$count = rmtree( $dir_a, $dir_b,
 601                                               {verbose => 1, safe => 1})}),
 602         $verbose_expected,
 603         'rmtree safe verbose (new style)'
 604     );
 605     rmtree($dir_a) if -d $dir_a;
 606     rmtree($dir_b) if -d $dir_b;
 607 }
 608
 609 {
 610     my $base = catdir( $tmp_base, 'output2');
 611     my $dir  = catdir( $base, 'A');
 612     my $dir2 = catdir( $base, 'B');
 613
 614     {
 615         my $warn = _run_for_warning( sub {
 616             my @created = make_path(
 617                 $dir,
 618                 $dir2,
 619                 { mode => 0711, foo => 1, bar => 1 }
 620             );
 621         } );
 622         like($warn,
 623             qr/Unrecognized option\(s\) passed to mkpath\(\) or make_path\(\):.*?bar.*?foo/,
 624             'make_path with final hashref warned due to unrecognized options'
 625         );
 626     }
 627
 628     {
 629         my $warn = _run_for_warning( sub {
 630             my @created = remove_tree(
 631                 $dir,
 632                 $dir2,
 633                 { foo => 1, bar => 1 }
 634             );
 635         } );
 636         like($warn,
 637             qr/Unrecognized option\(s\) passed to remove_tree\(\):.*?bar.*?foo/,
 638             'remove_tree with final hashref failed due to unrecognized options'
 639         );
 640     }
 641 }
 642
 643 SKIP: {
 644     my $nr_tests = 6;
 645     my $cwd = getcwd() or skip "failed to getcwd: $!", $nr_tests;
 646     rmtree($tmp_base, {result => \$list} );
 647     is(ref($list), 'ARRAY', "received a final list of results");
 648     ok( !(-d $tmp_base), "test base directory gone" );
 649
 650     my $p = getcwd();
 651     my $x = "x$$";
 652     my $xx = $x . "x";
 653
 654     # setup
 655     ok(mkpath($xx), "make $xx");
 656     ok(chdir($xx), "... and chdir $xx");
 657     END {
 658 #         ok(chdir($p), "... now chdir $p");
 659 #         ok(rmtree($xx), "... and finally rmtree $xx");
 660        chdir($p);
 661        rmtree($xx);
 662     }
 663
 664     # create and delete directory
 665     my $px = catdir($p, $x);
 666     ok(mkpath($px), 'create and delete directory 2.07');
 667     ok(rmtree($px), '.. rmtree fails in File-Path-2.07');
 668     chdir updir();
 669 }
 670
 671 my $windows_dir = 'C:\Path\To\Dir';
 672 my $expect = 'c:/path/to/dir';
 673 is(
 674     File::Path::_slash_lc($windows_dir),
 675     $expect,
 676     "Windows path unixified as expected"
 677 );
 678
 679 {
 680     my ($x, $message, $object, $expect, $rv, $arg, $error);
 681     my ($k, $v, $second_error, $third_error);
 682     local $! = ENOENT;
 683     $x = $!;
 684
 685     $message = 'message in a bottle';
 686     $object = '/path/to/glory';
 687     $expect = "$message for $object: $x";
 688     $rv = _run_for_warning( sub {
 689         File::Path::_error(
 690             {},
 691             $message,
 692             $object
 693         );
 694     } );
 695     like($rv, qr/^$expect/,
 696         "no \$arg->{error}: defined 2nd and 3rd args: got expected error message");
 697
 698     $object = undef;
 699     $expect = "$message: $x";
 700     $rv = _run_for_warning( sub {
 701         File::Path::_error(
 702             {},
 703             $message,
 704             $object
 705         );
 706     } );
 707     like($rv, qr/^$expect/,
 708         "no \$arg->{error}: defined 2nd arg; undefined 3rd arg: got expected error message");
 709
 710     $message = 'message in a bottle';
 711     $object = undef;
 712     $expect = "$message: $x";
 713     $arg = { error => \$error };
 714     File::Path::_error(
 715         $arg,
 716         $message,
 717         $object
 718     );
 719     is(ref($error->[0]), 'HASH',
 720         "first element of array inside \$error is hashref");
 721     ($k, $v) = %{$error->[0]};
 722     is($k, '', 'key of hash is empty string, since 3rd arg was undef');
 723     is($v, $expect, "value of hash is 2nd arg: $message");
 724
 725     $message = '';
 726     $object = '/path/to/glory';
 727     $expect = "$message: $x";
 728     $arg = { error => \$second_error };
 729     File::Path::_error(
 730         $arg,
 731         $message,
 732         $object
 733     );
 734     is(ref($second_error->[0]), 'HASH',
 735         "first element of array inside \$second_error is hashref");
 736     ($k, $v) = %{$second_error->[0]};
 737     is($k, $object, "key of hash is '$object', since 3rd arg was defined");
 738     is($v, $expect, "value of hash is 2nd arg: $message");
 739
 740     $message = '';
 741     $object = undef;
 742     $expect = "$message: $x";
 743     $arg = { error => \$third_error };
 744     File::Path::_error(
 745         $arg,
 746         $message,
 747         $object
 748     );
 749     is(ref($third_error->[0]), 'HASH',
 750         "first element of array inside \$third_error is hashref");
 751     ($k, $v) = %{$third_error->[0]};
 752     is($k, '', "key of hash is empty string, since 3rd arg was undef");
 753     is($v, $expect, "value of hash is 2nd arg: $message");
 754 }
 755
 756 {
 757     # https://rt.cpan.org/Ticket/Display.html?id=117019
 758     # remove_tree(): Permit re-use of options hash without issuing a warning
 759
 760     my ($least_deep, $next_deepest, $deepest) =
 761         create_3_level_subdirs( qw| ZoYhvc6RmGnl S2CrQ0lju0o7 lvOqVYWpfhcP | );
 762     my @created;
 763     @created = File::Path::make_path($deepest, { mode => 0711 });
 764     is(scalar(@created), 3, "Created 3 subdirectories");
 765
 766     my $x = '';
 767     my $opts = { error => \$x };
 768     File::Path::remove_tree($deepest, $opts);
 769     ok(! -d $deepest, "directory '$deepest' removed, as expected");
 770
 771     my $warn;
 772     $warn = _run_for_warning( sub { File::Path::remove_tree($next_deepest, $opts); } );
 773     ok(! $warn, "CPAN 117019: No warning thrown when re-using \$opts");
 774     ok(! -d $next_deepest, "directory '$next_deepest' removed, as expected");
 775
 776     $warn = _run_for_warning( sub { File::Path::remove_tree($least_deep, $opts); } );
 777     ok(! $warn, "CPAN 117019: No warning thrown when re-using \$opts");
 778     ok(! -d $least_deep, "directory '$least_deep' removed, as expected");
 779 }
 780
 781 {
 782     # Corner cases with respect to arguments provided to functions
 783     my $count;
 784
 785     $count = remove_tree();
 786     is($count, 0,
 787         "If not provided with any paths, remove_tree() will return a count of 0 things deleted");
 788
 789     $count = remove_tree('');
 790     is($count, 0,
 791         "If not provided with any paths, remove_tree() will return a count of 0 things deleted");
 792
 793     my $warn;
 794     $warn = _run_for_warning( sub { $count = rmtree(); } );
 795     like($warn, qr/No root path\(s\) specified/s, "Got expected carp");
 796     is($count, 0,
 797         "If not provided with any paths, remove_tree() will return a count of 0 things deleted");
 798
 799     $warn = _run_for_warning( sub {$count = rmtree(undef); } );
 800     like($warn, qr/No root path\(s\) specified/s, "Got expected carp");
 801     is($count, 0,
 802         "If provided only with an undefined value, remove_tree() will return a count of 0 things deleted");
 803
 804     $warn = _run_for_warning( sub {$count = rmtree(''); } );
 805     like($warn, qr/No root path\(s\) specified/s, "Got expected carp");
 806     is($count, 0,
 807         "If provided with an empty string for a path, remove_tree() will return a count of 0 things deleted");
 808
 809     $count = make_path();
 810     is($count, 0,
 811         "If not provided with any paths, make_path() will return a count of 0 things created");
 812
 813     $count = mkpath();
 814     is($count, 0,
 815         "If not provided with any paths, make_path() will return a count of 0 things created");
 816 }
 817
 818 SKIP: {
 819     my $skip_count = 5;
 820     skip "Windows will not set this error condition", $skip_count
 821         if $^O eq 'MSWin32';
 822
 823     # mkpath() with hashref:  case of phony user
 824     my ($least_deep, $next_deepest, $deepest) =
 825         create_3_level_subdirs( qw| Hhu1KpF4EVAV vUj5k37bih8v Vkdw02POXJxj | );
 826     my (@created, $error);
 827     my $user = join('_' => 'foobar', $$);
 828     @created = mkpath($deepest, { mode => 0711, user => $user, error => \$error });
 829     TODO: {
 830         local $TODO = "Notwithstanding the phony 'user', mkpath will actually create subdirectories; should it?";
 831         is(scalar(@created), 0, "No subdirectories created");
 832     }
 833     is(scalar(@$error), 1, "caught error condition" );
 834     my ($file, $message) = each %{$error->[0]};
 835     like($message,
 836         qr/unable to map $user to a uid, ownership not changed/s,
 837         "Got expected error message for phony user",
 838     );
 839
 840     cleanup_3_level_subdirs($least_deep);
 841 }
 842
 843 {
 844     # mkpath() with hashref:  case of valid uid
 845     my ($least_deep, $next_deepest, $deepest) =
 846         create_3_level_subdirs( qw| b5wj8CJcc7gl XTJe2C3WGLg5 VZ_y2T0XfKu3 | );
 847     my (@created, $error);
 848     @created = mkpath($deepest, { mode => 0711, uid => $>, error => \$error });
 849     is(scalar(@created), 3, "Provide valid 'uid' argument: 3 subdirectories created");
 850
 851     cleanup_3_level_subdirs($least_deep);
 852 }
 853
 854 SKIP: {
 855     my $skip_count = 3;
 856     skip "getpwuid() and getgrgid() not implemented on Windows", $skip_count
 857         if $^O eq 'MSWin32';
 858
 859     # mkpath() with hashref:  case of valid owner
 860     my ($least_deep, $next_deepest, $deepest) =
 861         create_3_level_subdirs( qw| aiJEDKaAEH25 nqhXsBM_7_bv qfRj4cur4Jrs | );
 862     my (@created, $error);
 863     my $name = getpwuid($>);
 864     @created = mkpath($deepest, { mode => 0711, owner => $name, error => \$error });
 865     is(scalar(@created), 3, "Provide valid 'owner' argument: 3 subdirectories created");
 866
 867     cleanup_3_level_subdirs($least_deep);
 868 }
 869
 870 SKIP: {
 871     my $skip_count = 5;
 872     skip "Windows will not set this error condition", $skip_count
 873         if $^O eq 'MSWin32';
 874
 875     # mkpath() with hashref:  case of phony group
 876     my ($least_deep, $next_deepest, $deepest) =
 877         create_3_level_subdirs( qw| nOR4lGRMdLvz NnwkEHEVL5li _3f1Kv6q77yA | );
 878     my (@created, $error);
 879     my $bad_group = join('_' => 'foobarbaz', $$);
 880     @created = mkpath($deepest, { mode => 0711, group => $bad_group, error => \$error });
 881     TODO: {
 882         local $TODO = "Notwithstanding the phony 'group', mkpath will actually create subdirectories; should it?";
 883         is(scalar(@created), 0, "No subdirectories created");
 884     }
 885     is(scalar(@$error), 1, "caught error condition" );
 886     my ($file, $message) = each %{$error->[0]};
 887     like($message,
 888         qr/unable to map $bad_group to a gid, group ownership not changed/s,
 889         "Got expected error message for phony user",
 890     );
 891
 892     cleanup_3_level_subdirs($least_deep);
 893 }
 894
 895 {
 896     # mkpath() with hashref:  case of valid group
 897     my ($least_deep, $next_deepest, $deepest) =
 898         create_3_level_subdirs( qw| BEcigvaBNisY rd4lJ1iZRyeS OyQnDPIBxP2K | );
 899     my (@created, $error);
 900     @created = mkpath($deepest, { mode => 0711, group => $(, error => \$error });
 901     is(scalar(@created), 3, "Provide valid 'group' argument: 3 subdirectories created");
 902
 903     cleanup_3_level_subdirs($least_deep);
 904 }
 905
 906 SKIP: {
 907     my $skip_count = 3;
 908     skip "getpwuid() and getgrgid() not implemented on Windows", $skip_count
 909         if $^O eq 'MSWin32';
 910
 911     # mkpath() with hashref:  case of valid group
 912     my ($least_deep, $next_deepest, $deepest) =
 913         create_3_level_subdirs( qw| IayhWFDvys8X gTd6gaeuFzmV VVI6UWLJCOEC | );
 914     my (@created, $error);
 915     my $group_name = (getgrgid($())[0];
 916     @created = mkpath($deepest, { mode => 0711, group => $group_name, error => \$error });
 917     is(scalar(@created), 3, "Provide valid 'group' argument: 3 subdirectories created");
 918
 919     cleanup_3_level_subdirs($least_deep);
 920 }
 921
 922 SKIP: {
 923     my $skip_count = 3;
 924     skip "getpwuid() and getgrgid() not implemented on Windows", $skip_count
 925         if $^O eq 'MSWin32';
 926
 927     # mkpath() with hashref:  case of valid owner and group
 928     my ($least_deep, $next_deepest, $deepest) =
 929         create_3_level_subdirs( qw| xsmOvlnxOqJc olsGlBSoVUpp tDuRilkD35rd | );
 930     my (@created, $error);
 931     my $name = getpwuid($>);
 932     my $group_name = (getgrgid($())[0];
 933     @created = mkpath($deepest, { mode => 0711, owner => $name, group => $group_name, error => \$error });
 934     is(scalar(@created), 3, "Provide valid 'owner' and 'group' 'group' arguments: 3 subdirectories created");
 935
 936     cleanup_3_level_subdirs($least_deep);
 937 }