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.11
[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 => 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 );