This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update File-Path to CPAN version 2.15
[perl5.git] / 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 => 165;
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 = 3;
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 }