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
CommitLineData
139271cd 1#! /usr/bin/env perl
12c2e016 2# Path.t -- tests for module File::Path
1a3850a5 3
037c8c09
CS
4use strict;
5
07e6e035 6use Test::More tests => 165;
30cf951a 7use Config;
139271cd 8use Fcntl ':mode';
cc744934
CBW
9use lib './t';
10use 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);
18use Errno qw(:POSIX);
19use Carp;
1a3850a5 20
12c2e016 21BEGIN {
3f083399
NC
22 use_ok('Cwd');
23 use_ok('File::Path', qw(rmtree mkpath make_path remove_tree));
12c2e016
DL
24 use_ok('File::Spec::Functions');
25}
26
30cf951a 27my $Is_VMS = $^O eq 'VMS';
5808899a 28
cc744934
CBW
29my $fchmod_supported = 0;
30if (open my $fh, curdir()) {
31 my ($perm) = (stat($fh))[2];
32 $perm &= 07777;
33 eval { $fchmod_supported = chmod( $perm, $fh); };
34}
35
037c8c09
CS
36# first check for stupid permissions second for full, so we clean up
37# behind ourselves
38for my $perm (0111,0777) {
e7780b56 39 my $path = catdir(curdir(), "mhx", "bar");
d5201bd2 40 mkpath($path);
e7780b56 41 chmod $perm, "mhx", $path;
1a3850a5 42
12c2e016 43 my $oct = sprintf('0%o', $perm);
bfcc9519 44
12c2e016
DL
45 ok(-d "mhx", "mkdir parent dir $oct");
46 ok(-d $path, "mkdir child dir $oct");
1a3850a5 47
e7780b56 48 rmtree("mhx");
bfcc9519 49
12c2e016
DL
50 ok(! -e "mhx", "mhx does not exist $oct");
51}
52
53# find a place to work
54my ($error, $list, $file, $message);
55my $tmp_base = catdir(
56 curdir(),
57 sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
58);
59
60# invent some names
61my @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
3f083399 69my @created = mkpath([@dir]);
12c2e016
DL
70
71is(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]);
75is(scalar(@created), 0, "skipped making existing directory")
76 or diag("unexpectedly recreated @created");
77
351a5cfe
DL
78# create a file
79my $file_name = catfile( $tmp_base, 'a', 'delete.me' );
80my $file_count = 0;
81if (open OUT, "> $file_name") {
82 print OUT "this file may be deleted\n";
83 close OUT;
84 ++$file_count;
85}
86else {
87 diag( "Failed to create file $file_name: $!" );
88}
89
90SKIP: {
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
12c2e016
DL
97@created = mkpath('');
98is(scalar(@created), 0, "Can't create a directory named ''");
99
100my $dir;
101my $dir2;
102
3f083399
NC
103sub 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
110sub 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';
30cf951a
NC
120 open my $f, '>', 'foo.dat';
121 close $f;
3f083399
NC
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);
bfcc9519 130
3f083399
NC
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';
30cf951a
NC
140 open my $f, '>', 'foo.dat';
141 close $f;
3f083399 142 my $before = count(curdir());
bfcc9519 143
3f083399
NC
144 cmp_ok($before, '>', 0, "ARGV $before");
145 {
146 local @ARGV = (1);
147 mkpath('3rd', !shift, 0755);
148 }
bfcc9519 149
3f083399
NC
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 }
bfcc9519 157
3f083399
NC
158 is(count(curdir()), $before + 1, "fourth after $before");
159
160 chdir updir();
161 rmtree 'solo';
162}
163
c42ebacb
CB
164SKIP: {
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;
bfcc9519 178
c42ebacb
CB
179 is($nr_err, 1, "ancestor error");
180
181 if ($nr_err) {
182 my ($file, $message) = each %{$error->[0]};
bfcc9519 183
c42ebacb
CB
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;
bfcc9519 188
c42ebacb 189 is($message, "cannot remove path when cwd is $ortho_dir", "ancestor reason");
bfcc9519 190
c42ebacb 191 ok(-d $dir2, "child not removed");
bfcc9519 192
c42ebacb
CB
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);
bfcc9519 203
c42ebacb
CB
204 ok(!(-d $dir), "ancestor now removed");
205};
206
12c2e016 207my $count = rmtree({error => \$error});
bfcc9519 208
12c2e016 209is( $count, 0, 'rmtree of nothing, count of zero' );
bfcc9519 210
3376a30f 211is( scalar(@$error), 0, 'no diagnostic captured' );
12c2e016
DL
212
213@created = mkpath($tmp_base, 0);
bfcc9519 214
12c2e016
DL
215is(scalar(@created), 0, "skipped making existing directories (old style 1)")
216 or diag("unexpectedly recreated @created");
217
218$dir = catdir($tmp_base,'C');
fa06c9c1 219# mkpath returns unix syntax filespecs on VMS
5808899a 220$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
3f083399 221@created = make_path($tmp_base, $dir);
bfcc9519 222
12c2e016 223is(scalar(@created), 1, "created directory (new style 1)");
bfcc9519 224
12c2e016
DL
225is($created[0], $dir, "created directory (new style 1) cross-check");
226
227@created = mkpath($tmp_base, 0, 0700);
bfcc9519 228
12c2e016
DL
229is(scalar(@created), 0, "skipped making existing directories (old style 2)")
230 or diag("unexpectedly recreated @created");
231
232$dir2 = catdir($tmp_base,'D');
fa06c9c1 233# mkpath returns unix syntax filespecs on VMS
5808899a 234$dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS;
3f083399 235@created = make_path($tmp_base, $dir, $dir2);
bfcc9519 236
12c2e016 237is(scalar(@created), 1, "created directory (new style 2)");
bfcc9519 238
12c2e016
DL
239is($created[0], $dir2, "created directory (new style 2) cross-check");
240
241$count = rmtree($dir, 0);
bfcc9519 242
5808899a 243is($count, 1, "removed directory unsafe mode");
12c2e016 244
bfcc9519
SH
245my $expected_count = _cannot_delete_safe_mode($dir2) ? 0 : 1;
246
12c2e016 247$count = rmtree($dir2, 0, 1);
bfcc9519
SH
248
249is($count, $expected_count, "removed directory safe mode");
12c2e016
DL
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);
bfcc9519 256
12c2e016 257cmp_ok(scalar(@created), '>=', 1, "made one or more dirs because of ..");
bfcc9519 258
12c2e016 259cmp_ok(scalar(@created), '<=', 2, "made less than two dirs because of ..");
bfcc9519 260
12c2e016
DL
261ok( -d catdir($tmp_base, 'Y'), "directory after parent" );
262
3f083399 263@created = make_path(catdir(curdir(), $tmp_base));
bfcc9519 264
12c2e016
DL
265is(scalar(@created), 0, "nothing created")
266 or diag(@created);
267
268$dir = catdir($tmp_base, 'a');
269$dir2 = catdir($tmp_base, 'z');
270
271rmtree( $dir, $dir2,
272 {
273 error => \$error,
274 result => \$list,
275 keep_root => 1,
276 }
277);
278
bfcc9519 279
12c2e016 280is(scalar(@$error), 0, "no errors unlinking a and z");
bfcc9519 281
12c2e016
DL
282is(scalar(@$list), 4, "list contains 4 elements")
283 or diag("@$list");
bfcc9519 284
12c2e016 285ok(-d $dir, "dir a still exists");
bfcc9519 286
12c2e016
DL
287ok(-d $dir2, "dir z still exists");
288
cd117d8b 289$dir = catdir($tmp_base,'F');
181b7e95 290# mkpath returns unix syntax filespecs on VMS
5808899a 291$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
cd117d8b
DL
292
293@created = mkpath($dir, undef, 0770);
bfcc9519 294
cd117d8b 295is(scalar(@created), 1, "created directory (old style 2 verbose undef)");
bfcc9519 296
cd117d8b 297is($created[0], $dir, "created directory (old style 2 verbose undef) cross-check");
bfcc9519 298
cd117d8b
DL
299is(rmtree($dir, undef, 0), 1, "removed directory 2 verbose undef");
300
301@created = mkpath($dir, undef);
bfcc9519 302
cd117d8b 303is(scalar(@created), 1, "created directory (old style 2a verbose undef)");
bfcc9519 304
cd117d8b 305is($created[0], $dir, "created directory (old style 2a verbose undef) cross-check");
bfcc9519 306
cd117d8b
DL
307is(rmtree($dir, undef), 1, "removed directory 2a verbose undef");
308
309@created = mkpath($dir, 0, undef);
bfcc9519 310
cd117d8b 311is(scalar(@created), 1, "created directory (old style 3 mode undef)");
bfcc9519 312
cd117d8b 313is($created[0], $dir, "created directory (old style 3 mode undef) cross-check");
bfcc9519 314
cd117d8b
DL
315is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef");
316
cc744934
CBW
317SKIP: {
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;
0b3d36bd 321
cc744934 322 @created = mkpath($dir, undef, 0400);
bfcc9519 323
cc744934 324 is(scalar(@created), 1, "created read-only dir");
bfcc9519 325
cc744934 326 is($created[0], $dir, "created read-only directory cross-check");
bfcc9519 327
cc744934
CBW
328 is(rmtree($dir), 1, "removed read-only dir");
329}
0b3d36bd 330
12c2e016
DL
331# borderline new-style heuristics
332if (chdir $tmp_base) {
333 pass("chdir to temp dir");
334}
335else {
336 fail("chdir to temp dir: $!");
037c8c09 337}
12c2e016
DL
338
339$dir = catdir('a', 'd1');
340$dir2 = catdir('a', 'd2');
341
3f083399 342@created = make_path( $dir, 0, $dir2 );
bfcc9519 343
12c2e016
DL
344is(scalar @created, 3, 'new-style 3 dirs created');
345
3f083399 346$count = remove_tree( $dir, 0, $dir2, );
bfcc9519 347
12c2e016
DL
348is($count, 3, 'new-style 3 dirs removed');
349
3f083399 350@created = make_path( $dir, $dir2, 1 );
bfcc9519 351
12c2e016
DL
352is(scalar @created, 3, 'new-style 3 dirs created (redux)');
353
3f083399 354$count = remove_tree( $dir, $dir2, 1 );
bfcc9519 355
12c2e016
DL
356is($count, 3, 'new-style 3 dirs removed (redux)');
357
3f083399 358@created = make_path( $dir, $dir2 );
bfcc9519 359
12c2e016
DL
360is(scalar @created, 2, 'new-style 2 dirs created');
361
3f083399 362$count = remove_tree( $dir, $dir2 );
bfcc9519 363
12c2e016
DL
364is($count, 2, 'new-style 2 dirs removed');
365
139271cd
CBW
366$dir = catdir("a\nb", 'd1');
367$dir2 = catdir("a\nb", 'd2');
368
139271cd
CBW
369SKIP: {
370 # Better to search for *nix derivatives?
371 # Not sure what else doesn't support newline in paths
bfcc9519
SH
372 skip "$^O doesn't allow newline in paths", 2
373 if $^O =~ m/^(MSWin32|VMS)$/;
139271cd
CBW
374
375 @created = make_path( $dir, $dir2 );
bfcc9519 376
139271cd
CBW
377 is(scalar @created, 3, 'new-style 3 dirs created in parent with newline');
378
379 $count = remove_tree( $dir, $dir2 );
bfcc9519 380
139271cd
CBW
381 is($count, 2, 'new-style 2 dirs removed in parent with newline');
382}
383
12c2e016
DL
384if (chdir updir()) {
385 pass("chdir parent");
386}
387else {
388 fail("chdir parent: $!");
389}
390
3f083399
NC
391SKIP: {
392 # test bug http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=487319
139271cd 393 skip "Don't need Force_Writeable semantics on $^O", 6
3f083399 394 if grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
139271cd 395 skip "Symlinks not available", 6 unless $Config{d_symlink};
3f083399
NC
396 $dir = 'bug487319';
397 $dir2 = 'bug487319-symlink';
398 @created = make_path($dir, {mask => 0700});
bfcc9519 399
139271cd 400 is( scalar @created, 1, 'bug 487319 setup' );
3f083399 401 symlink($dir, $dir2);
bfcc9519 402
3f083399
NC
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];
bfcc9519 410
3f083399
NC
411 is( $mask, $mask_initial, 'mask of symlink target dir unchanged (debian bug 487319)');
412
413 # now try a file
139271cd
CBW
414 #my $file = catfile($dir, 'file');
415 my $file = 'bug487319-file';
416 my $file2 = 'bug487319-file-symlink';
3f083399
NC
417 open my $out, '>', $file;
418 close $out;
bfcc9519 419
139271cd 420 ok(-e $file, 'file exists');
3f083399
NC
421
422 chmod 0500, $file;
423 $mask_initial = (stat $file)[2];
424
3f083399 425 symlink($file, $file2);
bfcc9519 426
139271cd 427 ok(-e $file2, 'file2 exists');
3f083399
NC
428 remove_tree($file2);
429
430 $mask = (stat $file)[2];
bfcc9519 431
3f083399
NC
432 is( $mask, $mask_initial, 'mask of symlink target file unchanged (debian bug 487319)');
433
434 remove_tree($dir);
139271cd 435 remove_tree($file);
3f083399
NC
436}
437
12c2e016
DL
438# see what happens if a file exists where we want a directory
439SKIP: {
139271cd
CBW
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;
12c2e016
DL
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
3376a30f 460{
d2f50e7f 461 $dir = catdir($tmp_base, 'ZZ');
3376a30f 462 @created = mkpath($dir);
d2f50e7f 463 is(scalar(@created), 1, "create a ZZ directory");
3376a30f
DL
464
465 local @ARGV = ($dir);
466 rmtree( [grep -e $_, @ARGV], 0, 0 );
467 ok(!-e $dir, "blow it away via \@ARGV");
468}
469
139271cd 470SKIP : {
cc744934 471 my $skip_count = 18;
bfcc9519
SH
472 # this test will fail on Windows, as per:
473 # http://perldoc.perl.org/perlport.html#chmod
474
139271cd
CBW
475 skip "Windows chmod test skipped", $skip_count
476 if $^O eq 'MSWin32';
cc744934
CBW
477 skip "fchmod() on directories is not supported on this platform", $skip_count
478 unless $fchmod_supported;
139271cd
CBW
479 my $mode;
480 my $octal_mode;
481 my @inputs = (
cc744934
CBW
482 0777, 0700, 0470, 0407,
483 0433, 0400, 0430, 0403,
484 0111, 0100, 0110, 0101,
485 0731, 0713, 0317, 0371,
486 0173, 0137);
139271cd
CBW
487 my $input;
488 my $octal_input;
139271cd
CBW
489
490 foreach (@inputs) {
491 $input = $_;
cc744934 492 $dir = catdir($tmp_base, sprintf("chmod_test%04o", $input));
bfcc9519
SH
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);
139271cd
CBW
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);
cc744934
CBW
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 }
139271cd
CBW
505 rmtree( $dir );
506 }
507}
508
bfcc9519
SH
509my $dir_base = catdir($tmp_base,'output');
510my $dir_a = catdir($dir_base, 'A');
511my $dir_b = catdir($dir_base, 'B');
30eb83e1 512
bfcc9519
SH
513is(_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);
cd117d8b 518
bfcc9519
SH
519is(_run_for_verbose(sub {@created = mkpath([$dir_b], 1)}),
520 _verbose_expected('mkpath', $dir_b, 0),
521 'mkpath verbose (old style 2)'
522);
12c2e016 523
bfcc9519 524my $verbose_expected;
12c2e016 525
bfcc9519
SH
526# Must determine expectations while directories still exist.
527$verbose_expected = _verbose_expected('rmtree', $dir_a, 1)
528 . _verbose_expected('rmtree', $dir_b, 1);
12c2e016 529
bfcc9519
SH
530is(_run_for_verbose(sub {$count = rmtree([$dir_a, $dir_b], 1, 1)}),
531 $verbose_expected,
532 'rmtree verbose (old style)'
533);
12c2e016 534
bfcc9519
SH
535# In case we didn't delete them in safe mode.
536rmtree($dir_a) if -d $dir_a;
537rmtree($dir_b) if -d $dir_b;
cd117d8b 538
bfcc9519
SH
539is(_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);
cd117d8b 544
bfcc9519
SH
545is(_run_for_verbose(sub {@created = mkpath($dir_b, 1, 0771)}),
546 _verbose_expected('mkpath', $dir_b, 0),
547 'mkpath verbose (new style 2)'
548);
12c2e016 549
bfcc9519
SH
550$verbose_expected = _verbose_expected('rmtree', $dir_a, 1)
551 . _verbose_expected('rmtree', $dir_b, 1);
12c2e016 552
bfcc9519
SH
553is(_run_for_verbose(sub {$count = rmtree([$dir_a, $dir_b], 1, 1)}),
554 $verbose_expected,
555 'again: rmtree verbose (old style)'
556);
12c2e016 557
bfcc9519
SH
558rmtree($dir_a) if -d $dir_a;
559rmtree($dir_b) if -d $dir_b;
12c2e016 560
bfcc9519
SH
561is(_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);
12c2e016 567
bfcc9519
SH
568$verbose_expected = _verbose_expected('remove_tree', $dir_a, 0)
569 . _verbose_expected('remove_tree', $dir_b, 0);
139271cd 570
bfcc9519
SH
571is(_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
577rmtree($dir_a) if -d $dir_a;
578rmtree($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);
586is(@created, 2, "2 directories created");
587
588SKIP: {
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");
139271cd 599
bfcc9519
SH
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)'
139271cd 604 );
bfcc9519
SH
605 rmtree($dir_a) if -d $dir_a;
606 rmtree($dir_b) if -d $dir_b;
607}
139271cd 608
bfcc9519
SH
609{
610 my $base = catdir( $tmp_base, 'output2');
611 my $dir = catdir( $base, 'A');
612 my $dir2 = catdir( $base, 'B');
12c2e016 613
bfcc9519 614 {
cc744934
CBW
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 } );
bfcc9519 622 like($warn,
cc744934 623 qr/Unrecognized option\(s\) passed to mkpath\(\) or make_path\(\):.*?bar.*?foo/,
bfcc9519 624 'make_path with final hashref warned due to unrecognized options'
12c2e016
DL
625 );
626 }
12c2e016 627
bfcc9519 628 {
cc744934
CBW
629 my $warn = _run_for_warning( sub {
630 my @created = remove_tree(
631 $dir,
632 $dir2,
633 { foo => 1, bar => 1 }
634 );
635 } );
bfcc9519
SH
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 );
12c2e016
DL
640 }
641}
642
0e5b5e32
MHM
643SKIP: {
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" );
139271cd 649
0e5b5e32
MHM
650 my $p = getcwd();
651 my $x = "x$$";
652 my $xx = $x . "x";
139271cd 653
0e5b5e32 654 # setup
30eb83e1
RGS
655 ok(mkpath($xx), "make $xx");
656 ok(chdir($xx), "... and chdir $xx");
0e5b5e32 657 END {
bfcc9519
SH
658# ok(chdir($p), "... now chdir $p");
659# ok(rmtree($xx), "... and finally rmtree $xx");
660 chdir($p);
661 rmtree($xx);
0e5b5e32 662 }
139271cd 663
0e5b5e32
MHM
664 # create and delete directory
665 my $px = catdir($p, $x);
30eb83e1
RGS
666 ok(mkpath($px), 'create and delete directory 2.07');
667 ok(rmtree($px), '.. rmtree fails in File-Path-2.07');
bfcc9519 668 chdir updir();
0e5b5e32 669}
139271cd
CBW
670
671my $windows_dir = 'C:\Path\To\Dir';
672my $expect = 'c:/path/to/dir';
673is(
674 File::Path::_slash_lc($windows_dir),
675 $expect,
676 "Windows path unixified as expected"
677);
bfcc9519
SH
678
679{
680 my ($x, $message, $object, $expect, $rv, $arg, $error);
681 my ($k, $v, $second_error, $third_error);
cc744934 682 local $! = ENOENT;
bfcc9519
SH
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}
cc744934
CBW
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
818SKIP: {
07e6e035 819 my $skip_count = 3;
cc744934
CBW
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 });
07e6e035
CBW
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# }
cc744934
CBW
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
854SKIP: {
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
870SKIP: {
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 });
07e6e035
CBW
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# }
cc744934
CBW
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
906SKIP: {
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
922SKIP: {
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}