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
CommitLineData
139271cd 1#! /usr/bin/env perl
12c2e016 2# Path.t -- tests for module File::Path
1a3850a5 3
037c8c09
CS
4use strict;
5
139271cd 6use Test::More tests => 159;
30cf951a 7use Config;
139271cd 8use Fcntl ':mode';
1a3850a5 9
12c2e016 10BEGIN {
139271cd 11 # 1
3f083399 12 use_ok('Cwd');
139271cd 13 # 2
3f083399 14 use_ok('File::Path', qw(rmtree mkpath make_path remove_tree));
139271cd 15 # 3
12c2e016
DL
16 use_ok('File::Spec::Functions');
17}
18
19eval "use Test::Output";
20my $has_Test_Output = $@ ? 0 : 1;
1a3850a5 21
30cf951a 22my $Is_VMS = $^O eq 'VMS';
5808899a 23
037c8c09
CS
24# first check for stupid permissions second for full, so we clean up
25# behind ourselves
26for my $perm (0111,0777) {
e7780b56 27 my $path = catdir(curdir(), "mhx", "bar");
d5201bd2 28 mkpath($path);
e7780b56 29 chmod $perm, "mhx", $path;
1a3850a5 30
12c2e016 31 my $oct = sprintf('0%o', $perm);
139271cd 32 # 4
12c2e016 33 ok(-d "mhx", "mkdir parent dir $oct");
139271cd 34 # 5
12c2e016 35 ok(-d $path, "mkdir child dir $oct");
1a3850a5 36
e7780b56 37 rmtree("mhx");
139271cd 38 # 6
12c2e016
DL
39 ok(! -e "mhx", "mhx does not exist $oct");
40}
41
42# find a place to work
43my ($error, $list, $file, $message);
44my $tmp_base = catdir(
45 curdir(),
46 sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
47);
48
49# invent some names
50my @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
3f083399 58my @created = mkpath([@dir]);
12c2e016 59
139271cd 60# 7
12c2e016
DL
61is(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]);
65is(scalar(@created), 0, "skipped making existing directory")
66 or diag("unexpectedly recreated @created");
67
351a5cfe
DL
68# create a file
69my $file_name = catfile( $tmp_base, 'a', 'delete.me' );
70my $file_count = 0;
71if (open OUT, "> $file_name") {
72 print OUT "this file may be deleted\n";
73 close OUT;
74 ++$file_count;
75}
76else {
77 diag( "Failed to create file $file_name: $!" );
78}
79
80SKIP: {
81 skip "cannot remove a file we failed to create", 1
82 unless $file_count == 1;
83 my $count = rmtree($file_name);
139271cd 84# 8
351a5cfe
DL
85 is($count, 1, "rmtree'ed a file");
86}
87
12c2e016 88@created = mkpath('');
139271cd 89# 9
12c2e016
DL
90is(scalar(@created), 0, "Can't create a directory named ''");
91
92my $dir;
93my $dir2;
94
3f083399
NC
95sub 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
102sub 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';
30cf951a
NC
112 open my $f, '>', 'foo.dat';
113 close $f;
3f083399 114 my $before = count(curdir());
139271cd 115# 10
3f083399
NC
116 cmp_ok($before, '>', 0, "baseline $before");
117
118 gisle('1st', 1);
139271cd 119# 11
3f083399
NC
120 is(count(curdir()), $before + 1, "first after $before");
121
122 $before = count(curdir());
123 gisle('2nd', 1);
139271cd 124# 12
3f083399
NC
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';
30cf951a
NC
134 open my $f, '>', 'foo.dat';
135 close $f;
3f083399 136 my $before = count(curdir());
139271cd 137# 13
3f083399
NC
138 cmp_ok($before, '>', 0, "ARGV $before");
139 {
140 local @ARGV = (1);
141 mkpath('3rd', !shift, 0755);
142 }
139271cd 143# 14
3f083399
NC
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 }
139271cd 151# 15
3f083399
NC
152 is(count(curdir()), $before + 1, "fourth after $before");
153
154 chdir updir();
155 rmtree 'solo';
156}
157
c42ebacb
CB
158SKIP: {
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;
139271cd 172# 16
c42ebacb
CB
173 is($nr_err, 1, "ancestor error");
174
175 if ($nr_err) {
176 my ($file, $message) = each %{$error->[0]};
139271cd 177# 17
c42ebacb
CB
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;
139271cd 182# 18
c42ebacb 183 is($message, "cannot remove path when cwd is $ortho_dir", "ancestor reason");
139271cd 184# 19
c42ebacb 185 ok(-d $dir2, "child not removed");
139271cd 186# 20
c42ebacb
CB
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);
139271cd 197# 21
c42ebacb
CB
198 ok(!(-d $dir), "ancestor now removed");
199};
200
12c2e016 201my $count = rmtree({error => \$error});
139271cd 202# 22
12c2e016 203is( $count, 0, 'rmtree of nothing, count of zero' );
139271cd 204# 23
3376a30f 205is( scalar(@$error), 0, 'no diagnostic captured' );
12c2e016
DL
206
207@created = mkpath($tmp_base, 0);
139271cd 208# 24
12c2e016
DL
209is(scalar(@created), 0, "skipped making existing directories (old style 1)")
210 or diag("unexpectedly recreated @created");
211
212$dir = catdir($tmp_base,'C');
fa06c9c1 213# mkpath returns unix syntax filespecs on VMS
5808899a 214$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
3f083399 215@created = make_path($tmp_base, $dir);
139271cd 216# 25
12c2e016 217is(scalar(@created), 1, "created directory (new style 1)");
139271cd 218# 26
12c2e016
DL
219is($created[0], $dir, "created directory (new style 1) cross-check");
220
221@created = mkpath($tmp_base, 0, 0700);
139271cd 222# 27
12c2e016
DL
223is(scalar(@created), 0, "skipped making existing directories (old style 2)")
224 or diag("unexpectedly recreated @created");
225
226$dir2 = catdir($tmp_base,'D');
fa06c9c1 227# mkpath returns unix syntax filespecs on VMS
5808899a 228$dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS;
3f083399 229@created = make_path($tmp_base, $dir, $dir2);
139271cd 230# 28
12c2e016 231is(scalar(@created), 1, "created directory (new style 2)");
139271cd 232# 29
12c2e016
DL
233is($created[0], $dir2, "created directory (new style 2) cross-check");
234
235$count = rmtree($dir, 0);
139271cd 236# 30
5808899a 237is($count, 1, "removed directory unsafe mode");
12c2e016
DL
238
239$count = rmtree($dir2, 0, 1);
33839f2f 240my $removed = $Is_VMS ? 0 : 1;
139271cd 241# 31
33839f2f 242is($count, $removed, "removed directory safe mode");
12c2e016
DL
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);
139271cd 249# 32
12c2e016 250cmp_ok(scalar(@created), '>=', 1, "made one or more dirs because of ..");
139271cd 251# 33
12c2e016 252cmp_ok(scalar(@created), '<=', 2, "made less than two dirs because of ..");
139271cd 253# 34
12c2e016
DL
254ok( -d catdir($tmp_base, 'Y'), "directory after parent" );
255
3f083399 256@created = make_path(catdir(curdir(), $tmp_base));
139271cd 257# 35
12c2e016
DL
258is(scalar(@created), 0, "nothing created")
259 or diag(@created);
260
261$dir = catdir($tmp_base, 'a');
262$dir2 = catdir($tmp_base, 'z');
263
264rmtree( $dir, $dir2,
265 {
266 error => \$error,
267 result => \$list,
268 keep_root => 1,
269 }
270);
271
139271cd 272# 36
12c2e016 273is(scalar(@$error), 0, "no errors unlinking a and z");
139271cd 274# 37
12c2e016
DL
275is(scalar(@$list), 4, "list contains 4 elements")
276 or diag("@$list");
139271cd 277# 38
12c2e016 278ok(-d $dir, "dir a still exists");
139271cd 279# 39
12c2e016
DL
280ok(-d $dir2, "dir z still exists");
281
cd117d8b 282$dir = catdir($tmp_base,'F');
181b7e95 283# mkpath returns unix syntax filespecs on VMS
5808899a 284$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
cd117d8b
DL
285
286@created = mkpath($dir, undef, 0770);
139271cd 287# 40
cd117d8b 288is(scalar(@created), 1, "created directory (old style 2 verbose undef)");
139271cd 289# 41
cd117d8b 290is($created[0], $dir, "created directory (old style 2 verbose undef) cross-check");
139271cd 291# 42
cd117d8b
DL
292is(rmtree($dir, undef, 0), 1, "removed directory 2 verbose undef");
293
294@created = mkpath($dir, undef);
139271cd 295# 43
cd117d8b 296is(scalar(@created), 1, "created directory (old style 2a verbose undef)");
139271cd 297# 44
cd117d8b 298is($created[0], $dir, "created directory (old style 2a verbose undef) cross-check");
139271cd 299# 45
cd117d8b
DL
300is(rmtree($dir, undef), 1, "removed directory 2a verbose undef");
301
302@created = mkpath($dir, 0, undef);
139271cd 303# 46
cd117d8b 304is(scalar(@created), 1, "created directory (old style 3 mode undef)");
139271cd 305# 47
cd117d8b 306is($created[0], $dir, "created directory (old style 3 mode undef) cross-check");
139271cd 307# 48
cd117d8b
DL
308is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef");
309
0b3d36bd 310$dir = catdir($tmp_base,'G');
5808899a 311$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
0b3d36bd
DL
312
313@created = mkpath($dir, undef, 0200);
139271cd 314# 49
0b3d36bd 315is(scalar(@created), 1, "created write-only dir");
139271cd 316# 50
0b3d36bd 317is($created[0], $dir, "created write-only directory cross-check");
139271cd 318# 51
0b3d36bd
DL
319is(rmtree($dir), 1, "removed write-only dir");
320
12c2e016
DL
321# borderline new-style heuristics
322if (chdir $tmp_base) {
323 pass("chdir to temp dir");
324}
325else {
326 fail("chdir to temp dir: $!");
037c8c09 327}
12c2e016
DL
328
329$dir = catdir('a', 'd1');
330$dir2 = catdir('a', 'd2');
331
3f083399 332@created = make_path( $dir, 0, $dir2 );
139271cd 333# 52
12c2e016
DL
334is(scalar @created, 3, 'new-style 3 dirs created');
335
3f083399 336$count = remove_tree( $dir, 0, $dir2, );
139271cd 337# 53
12c2e016
DL
338is($count, 3, 'new-style 3 dirs removed');
339
3f083399 340@created = make_path( $dir, $dir2, 1 );
139271cd 341# 54
12c2e016
DL
342is(scalar @created, 3, 'new-style 3 dirs created (redux)');
343
3f083399 344$count = remove_tree( $dir, $dir2, 1 );
139271cd 345# 55
12c2e016
DL
346is($count, 3, 'new-style 3 dirs removed (redux)');
347
3f083399 348@created = make_path( $dir, $dir2 );
139271cd 349# 56
12c2e016
DL
350is(scalar @created, 2, 'new-style 2 dirs created');
351
3f083399 352$count = remove_tree( $dir, $dir2 );
139271cd 353# 57
12c2e016
DL
354is($count, 2, 'new-style 2 dirs removed');
355
139271cd
CBW
356$dir = catdir("a\nb", 'd1');
357$dir2 = catdir("a\nb", 'd2');
358
359
360
361SKIP: {
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
12c2e016
DL
376if (chdir updir()) {
377 pass("chdir parent");
378}
379else {
380 fail("chdir parent: $!");
381}
382
3f083399 383SKIP: {
139271cd 384 skip "This is not a MSWin32 platform", 3
839bc55a
NC
385 unless $^O eq 'MSWin32';
386
139271cd
CBW
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');
839bc55a 396
839bc55a 397 my $removed = rmtree($UNC_path);
139271cd 398# 62
839bc55a
NC
399 cmp_ok($removed, '>', 0, "removed $removed entries from $UNC_path");
400}
401
402SKIP: {
3f083399 403 # test bug http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=487319
139271cd 404 skip "Don't need Force_Writeable semantics on $^O", 6
3f083399 405 if grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
139271cd 406 skip "Symlinks not available", 6 unless $Config{d_symlink};
3f083399
NC
407 $dir = 'bug487319';
408 $dir2 = 'bug487319-symlink';
409 @created = make_path($dir, {mask => 0700});
139271cd
CBW
410# 63
411 is( scalar @created, 1, 'bug 487319 setup' );
3f083399 412 symlink($dir, $dir2);
139271cd 413# 64
3f083399
NC
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];
139271cd 421# 65
3f083399
NC
422 is( $mask, $mask_initial, 'mask of symlink target dir unchanged (debian bug 487319)');
423
424 # now try a file
139271cd
CBW
425 #my $file = catfile($dir, 'file');
426 my $file = 'bug487319-file';
427 my $file2 = 'bug487319-file-symlink';
3f083399
NC
428 open my $out, '>', $file;
429 close $out;
139271cd
CBW
430# 66
431 ok(-e $file, 'file exists');
3f083399
NC
432
433 chmod 0500, $file;
434 $mask_initial = (stat $file)[2];
435
3f083399 436 symlink($file, $file2);
139271cd
CBW
437# 67
438 ok(-e $file2, 'file2 exists');
3f083399
NC
439 remove_tree($file2);
440
441 $mask = (stat $file)[2];
139271cd 442# 68
3f083399
NC
443 is( $mask, $mask_initial, 'mask of symlink target file unchanged (debian bug 487319)');
444
445 remove_tree($dir);
139271cd 446 remove_tree($file);
3f083399
NC
447}
448
12c2e016
DL
449# see what happens if a file exists where we want a directory
450SKIP: {
139271cd
CBW
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;
12c2e016
DL
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
471my $extra = catdir(curdir(), qw(EXTRA 1 a));
472
473SKIP: {
37b1cd44 474 skip "extra scenarios not set up, see eg/setup-extra-tests", 14
12c2e016 475 unless -e $extra;
30eb83e1 476 skip "Symlinks not available", 14 unless $Config{d_symlink};
12c2e016
DL
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});
0b3d36bd 491 is( scalar(@$error), 1, 'one error for an unreadable dir' );
37b1cd44
DL
492 eval { ($file, $message) = each %{$error->[0]}};
493 is( $file, $dir, 'unreadable dir reported in error' )
494 or diag($message);
12c2e016 495
cd117d8b
DL
496 $dir = catdir('EXTRA', '3', 'T');
497 rmtree($dir, {error => \$error});
37b1cd44
DL
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' );
cd117d8b 501
12c2e016
DL
502 $dir = catdir( 'EXTRA', '4' );
503 rmtree($dir, {result => \$list, error => \$err} );
37b1cd44
DL
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} );
12c2e016
DL
506 eval { ($file, $message) = each %{$err->[0]} };
507 is( $file, $dir, 'symlink reported in error' );
37b1cd44
DL
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' );
12c2e016
DL
516}
517
3376a30f 518{
d2f50e7f 519 $dir = catdir($tmp_base, 'ZZ');
3376a30f 520 @created = mkpath($dir);
d2f50e7f 521 is(scalar(@created), 1, "create a ZZ directory");
3376a30f
DL
522
523 local @ARGV = ($dir);
524 rmtree( [grep -e $_, @ARGV], 0, 0 );
525 ok(!-e $dir, "blow it away via \@ARGV");
526}
527
139271cd
CBW
528SKIP : {
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
12c2e016 556SKIP: {
30eb83e1
RGS
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;
c2c33583
JJ
564 skip "darwin's nobody and nogroup are -1", $skip_count
565 if $^O eq 'darwin';
30eb83e1
RGS
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+
624unable 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
630SKIP: {
139271cd 631 skip 'Test::Output not available', 18
12c2e016
DL
632 unless $has_Test_Output;
633
634 SKIP: {
635 $dir = catdir('EXTRA', '3');
538f81fb 636 skip "extra scenarios not set up, see eg/setup-extra-tests", 3
12c2e016
DL
637 unless -e $dir;
638
cd117d8b 639 $dir = catdir('EXTRA', '3', 'U');
139271cd 640 stderr_like(
cd117d8b 641 sub {rmtree($dir, {verbose => 0})},
0b3d36bd
DL
642 qr{\Acannot make child directory read-write-exec for [^:]+: .* at \S+ line \d+},
643 q(rmtree can't chdir into root dir)
cd117d8b
DL
644 );
645
646 $dir = catdir('EXTRA', '3');
139271cd 647 stderr_like(
12c2e016 648 sub {rmtree($dir, {})},
0b3d36bd
DL
649 qr{\Acannot make child directory read-write-exec for [^:]+: .* at (\S+) line (\d+)
650cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
651cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
652cannot remove directory for [^:]+: .* at \1 line \2},
12c2e016
DL
653 'rmtree with file owned by root'
654 );
655
139271cd 656 stderr_like(
12c2e016 657 sub {rmtree('EXTRA', {})},
0b3d36bd
DL
658 qr{\Acannot remove directory for [^:]+: .* at (\S+) line (\d+)
659cannot remove directory for [^:]+: .* at \1 line \2
660cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
661cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
662cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
663cannot remove directory for [^:]+: .* at \1 line \2
664cannot unlink file for [^:]+: .* at \1 line \2
665cannot restore permissions to \d+ for [^:]+: .* at \1 line \2
666cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
839bc55a 667cannot remove directory for [^:]+: .* at \1 line \2},
12c2e016
DL
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(
3376a30f 677 sub { rmtree( undef, 1 ) },
12c2e016
DL
678 qr/\ANo root path\(s\) specified\b/,
679 "rmtree of nothing carps sensibly"
680 );
681
cd117d8b
DL
682 stderr_like(
683 sub { rmtree( '', 1 ) },
684 qr/\ANo root path\(s\) specified\b/,
685 "rmtree of empty dir carps sensibly"
686 );
687
3f083399
NC
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" );
139271cd 690 stderr_is( sub { mkpath() }, '', "mkpath no args does not carp" );
cd117d8b 691
12c2e016
DL
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
139271cd
CBW
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
12c2e016
DL
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
798SKIP: {
0b3d36bd 799 skip "extra scenarios not set up, see eg/setup-extra-tests", 11
12c2e016
DL
800 unless -d catdir(qw(EXTRA 1));
801
802 rmtree 'EXTRA', {safe => 0, error => \$error};
839bc55a 803 is( scalar(@$error), 10, 'seven deadly sins' ); # well there used to be 7
12c2e016
DL
804
805 rmtree 'EXTRA', {safe => 1, error => \$error};
0b3d36bd 806 is( scalar(@$error), 9, 'safe is better' );
12c2e016
DL
807 for (@$error) {
808 ($file, $message) = each %$_;
809 if ($file =~ /[123]\z/) {
0b3d36bd 810 is(index($message, 'cannot remove directory: '), 0, "failed to remove $file with rmdir")
12c2e016
DL
811 or diag($message);
812 }
813 else {
0b3d36bd
DL
814 like($message, qr(\Acannot (?:restore permissions to \d+|chdir to child|unlink file): ), "failed to remove $file with unlink")
815 or diag($message)
12c2e016
DL
816 }
817 }
818}
819
0e5b5e32
MHM
820SKIP: {
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" );
139271cd 826
0e5b5e32
MHM
827 my $p = getcwd();
828 my $x = "x$$";
829 my $xx = $x . "x";
139271cd 830
0e5b5e32 831 # setup
30eb83e1
RGS
832 ok(mkpath($xx), "make $xx");
833 ok(chdir($xx), "... and chdir $xx");
0e5b5e32 834 END {
30eb83e1
RGS
835 ok(chdir($p), "... now chdir $p");
836 ok(rmtree($xx), "... and finally rmtree $xx");
0e5b5e32 837 }
139271cd 838
0e5b5e32
MHM
839 # create and delete directory
840 my $px = catdir($p, $x);
30eb83e1
RGS
841 ok(mkpath($px), 'create and delete directory 2.07');
842 ok(rmtree($px), '.. rmtree fails in File-Path-2.07');
0e5b5e32 843}
139271cd
CBW
844
845my $windows_dir = 'C:\Path\To\Dir';
846my $expect = 'c:/path/to/dir';
847is(
848 File::Path::_slash_lc($windows_dir),
849 $expect,
850 "Windows path unixified as expected"
851);