Commit | Line | Data |
12c2e016 |
1 | # Path.t -- tests for module File::Path |
1a3850a5 |
2 | |
037c8c09 |
3 | use strict; |
4 | |
839bc55a |
5 | use Test::More tests => 121; |
30cf951a |
6 | use Config; |
1a3850a5 |
7 | |
12c2e016 |
8 | BEGIN { |
3f083399 |
9 | use_ok('Cwd'); |
10 | use_ok('File::Path', qw(rmtree mkpath make_path remove_tree)); |
12c2e016 |
11 | use_ok('File::Spec::Functions'); |
12 | } |
13 | |
14 | eval "use Test::Output"; |
15 | my $has_Test_Output = $@ ? 0 : 1; |
1a3850a5 |
16 | |
30cf951a |
17 | my $Is_VMS = $^O eq 'VMS'; |
5808899a |
18 | |
037c8c09 |
19 | # first check for stupid permissions second for full, so we clean up |
20 | # behind ourselves |
21 | for my $perm (0111,0777) { |
e7780b56 |
22 | my $path = catdir(curdir(), "mhx", "bar"); |
d5201bd2 |
23 | mkpath($path); |
e7780b56 |
24 | chmod $perm, "mhx", $path; |
1a3850a5 |
25 | |
12c2e016 |
26 | my $oct = sprintf('0%o', $perm); |
27 | ok(-d "mhx", "mkdir parent dir $oct"); |
28 | ok(-d $path, "mkdir child dir $oct"); |
1a3850a5 |
29 | |
e7780b56 |
30 | rmtree("mhx"); |
12c2e016 |
31 | ok(! -e "mhx", "mhx does not exist $oct"); |
32 | } |
33 | |
34 | # find a place to work |
35 | my ($error, $list, $file, $message); |
36 | my $tmp_base = catdir( |
37 | curdir(), |
38 | sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ), |
39 | ); |
40 | |
41 | # invent some names |
42 | my @dir = ( |
43 | catdir($tmp_base, qw(a b)), |
44 | catdir($tmp_base, qw(a c)), |
45 | catdir($tmp_base, qw(z b)), |
46 | catdir($tmp_base, qw(z c)), |
47 | ); |
48 | |
49 | # create them |
3f083399 |
50 | my @created = mkpath([@dir]); |
12c2e016 |
51 | |
52 | is(scalar(@created), 7, "created list of directories"); |
53 | |
54 | # pray for no race conditions blowing them out from under us |
55 | @created = mkpath([$tmp_base]); |
56 | is(scalar(@created), 0, "skipped making existing directory") |
57 | or diag("unexpectedly recreated @created"); |
58 | |
351a5cfe |
59 | # create a file |
60 | my $file_name = catfile( $tmp_base, 'a', 'delete.me' ); |
61 | my $file_count = 0; |
62 | if (open OUT, "> $file_name") { |
63 | print OUT "this file may be deleted\n"; |
64 | close OUT; |
65 | ++$file_count; |
66 | } |
67 | else { |
68 | diag( "Failed to create file $file_name: $!" ); |
69 | } |
70 | |
71 | SKIP: { |
72 | skip "cannot remove a file we failed to create", 1 |
73 | unless $file_count == 1; |
74 | my $count = rmtree($file_name); |
75 | is($count, 1, "rmtree'ed a file"); |
76 | } |
77 | |
12c2e016 |
78 | @created = mkpath(''); |
79 | is(scalar(@created), 0, "Can't create a directory named ''"); |
80 | |
81 | my $dir; |
82 | my $dir2; |
83 | |
3f083399 |
84 | sub gisle { |
85 | # background info: @_ = 1; !shift # gives '' not 0 |
86 | # Message-Id: <3C820CE6-4400-4E91-AF43-A3D19B356E68@activestate.com> |
87 | # http://www.nntp.perl.org/group/perl.perl5.porters/2008/05/msg136625.html |
88 | mkpath(shift, !shift, 0755); |
89 | } |
90 | |
91 | sub count { |
92 | opendir D, shift or return -1; |
93 | my $count = () = readdir D; |
94 | closedir D or return -1; |
95 | return $count; |
96 | } |
97 | |
98 | { |
99 | mkdir 'solo', 0755; |
100 | chdir 'solo'; |
30cf951a |
101 | open my $f, '>', 'foo.dat'; |
102 | close $f; |
3f083399 |
103 | my $before = count(curdir()); |
104 | cmp_ok($before, '>', 0, "baseline $before"); |
105 | |
106 | gisle('1st', 1); |
107 | is(count(curdir()), $before + 1, "first after $before"); |
108 | |
109 | $before = count(curdir()); |
110 | gisle('2nd', 1); |
111 | is(count(curdir()), $before + 1, "second after $before"); |
112 | |
113 | chdir updir(); |
114 | rmtree 'solo'; |
115 | } |
116 | |
117 | { |
118 | mkdir 'solo', 0755; |
119 | chdir 'solo'; |
30cf951a |
120 | open my $f, '>', 'foo.dat'; |
121 | close $f; |
3f083399 |
122 | my $before = count(curdir()); |
123 | cmp_ok($before, '>', 0, "ARGV $before"); |
124 | { |
125 | local @ARGV = (1); |
126 | mkpath('3rd', !shift, 0755); |
127 | } |
128 | is(count(curdir()), $before + 1, "third after $before"); |
129 | |
130 | $before = count(curdir()); |
131 | { |
132 | local @ARGV = (1); |
133 | mkpath('4th', !shift, 0755); |
134 | } |
135 | is(count(curdir()), $before + 1, "fourth after $before"); |
136 | |
137 | chdir updir(); |
138 | rmtree 'solo'; |
139 | } |
140 | |
c42ebacb |
141 | SKIP: { |
142 | # tests for rmtree() of ancestor directory |
143 | my $nr_tests = 6; |
144 | my $cwd = getcwd() or skip "failed to getcwd: $!", $nr_tests; |
145 | my $dir = catdir($cwd, 'remove'); |
146 | my $dir2 = catdir($cwd, 'remove', 'this', 'dir'); |
147 | |
148 | skip "failed to mkpath '$dir2': $!", $nr_tests |
149 | unless mkpath($dir2, {verbose => 0}); |
150 | skip "failed to chdir dir '$dir2': $!", $nr_tests |
151 | unless chdir($dir2); |
152 | |
153 | rmtree($dir, {error => \$error}); |
154 | my $nr_err = @$error; |
155 | is($nr_err, 1, "ancestor error"); |
156 | |
157 | if ($nr_err) { |
158 | my ($file, $message) = each %{$error->[0]}; |
159 | is($file, $dir, "ancestor named"); |
160 | my $ortho_dir = $^O eq 'MSWin32' ? File::Path::_slash_lc($dir2) : $dir2; |
161 | $^O eq 'MSWin32' and $message |
162 | =~ s/\A(cannot remove path when cwd is )(.*)\Z/$1 . File::Path::_slash_lc($2)/e; |
163 | is($message, "cannot remove path when cwd is $ortho_dir", "ancestor reason"); |
164 | ok(-d $dir2, "child not removed"); |
165 | ok(-d $dir, "ancestor not removed"); |
166 | } |
167 | else { |
168 | fail( "ancestor 1"); |
169 | fail( "ancestor 2"); |
170 | fail( "ancestor 3"); |
171 | fail( "ancestor 4"); |
172 | } |
173 | chdir $cwd; |
174 | rmtree($dir); |
175 | ok(!(-d $dir), "ancestor now removed"); |
176 | }; |
177 | |
12c2e016 |
178 | my $count = rmtree({error => \$error}); |
179 | is( $count, 0, 'rmtree of nothing, count of zero' ); |
3376a30f |
180 | is( scalar(@$error), 0, 'no diagnostic captured' ); |
12c2e016 |
181 | |
182 | @created = mkpath($tmp_base, 0); |
183 | is(scalar(@created), 0, "skipped making existing directories (old style 1)") |
184 | or diag("unexpectedly recreated @created"); |
185 | |
186 | $dir = catdir($tmp_base,'C'); |
fa06c9c1 |
187 | # mkpath returns unix syntax filespecs on VMS |
5808899a |
188 | $dir = VMS::Filespec::unixify($dir) if $Is_VMS; |
3f083399 |
189 | @created = make_path($tmp_base, $dir); |
12c2e016 |
190 | is(scalar(@created), 1, "created directory (new style 1)"); |
191 | is($created[0], $dir, "created directory (new style 1) cross-check"); |
192 | |
193 | @created = mkpath($tmp_base, 0, 0700); |
194 | is(scalar(@created), 0, "skipped making existing directories (old style 2)") |
195 | or diag("unexpectedly recreated @created"); |
196 | |
197 | $dir2 = catdir($tmp_base,'D'); |
fa06c9c1 |
198 | # mkpath returns unix syntax filespecs on VMS |
5808899a |
199 | $dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS; |
3f083399 |
200 | @created = make_path($tmp_base, $dir, $dir2); |
12c2e016 |
201 | is(scalar(@created), 1, "created directory (new style 2)"); |
202 | is($created[0], $dir2, "created directory (new style 2) cross-check"); |
203 | |
204 | $count = rmtree($dir, 0); |
5808899a |
205 | is($count, 1, "removed directory unsafe mode"); |
12c2e016 |
206 | |
207 | $count = rmtree($dir2, 0, 1); |
33839f2f |
208 | my $removed = $Is_VMS ? 0 : 1; |
209 | is($count, $removed, "removed directory safe mode"); |
12c2e016 |
210 | |
211 | # mkdir foo ./E/../Y |
212 | # Y should exist |
213 | # existence of E is neither here nor there |
214 | $dir = catdir($tmp_base, 'E', updir(), 'Y'); |
215 | @created =mkpath($dir); |
216 | cmp_ok(scalar(@created), '>=', 1, "made one or more dirs because of .."); |
217 | cmp_ok(scalar(@created), '<=', 2, "made less than two dirs because of .."); |
218 | ok( -d catdir($tmp_base, 'Y'), "directory after parent" ); |
219 | |
3f083399 |
220 | @created = make_path(catdir(curdir(), $tmp_base)); |
12c2e016 |
221 | is(scalar(@created), 0, "nothing created") |
222 | or diag(@created); |
223 | |
224 | $dir = catdir($tmp_base, 'a'); |
225 | $dir2 = catdir($tmp_base, 'z'); |
226 | |
227 | rmtree( $dir, $dir2, |
228 | { |
229 | error => \$error, |
230 | result => \$list, |
231 | keep_root => 1, |
232 | } |
233 | ); |
234 | |
235 | is(scalar(@$error), 0, "no errors unlinking a and z"); |
236 | is(scalar(@$list), 4, "list contains 4 elements") |
237 | or diag("@$list"); |
238 | |
239 | ok(-d $dir, "dir a still exists"); |
240 | ok(-d $dir2, "dir z still exists"); |
241 | |
cd117d8b |
242 | $dir = catdir($tmp_base,'F'); |
181b7e95 |
243 | # mkpath returns unix syntax filespecs on VMS |
5808899a |
244 | $dir = VMS::Filespec::unixify($dir) if $Is_VMS; |
cd117d8b |
245 | |
246 | @created = mkpath($dir, undef, 0770); |
247 | is(scalar(@created), 1, "created directory (old style 2 verbose undef)"); |
248 | is($created[0], $dir, "created directory (old style 2 verbose undef) cross-check"); |
249 | is(rmtree($dir, undef, 0), 1, "removed directory 2 verbose undef"); |
250 | |
251 | @created = mkpath($dir, undef); |
252 | is(scalar(@created), 1, "created directory (old style 2a verbose undef)"); |
253 | is($created[0], $dir, "created directory (old style 2a verbose undef) cross-check"); |
254 | is(rmtree($dir, undef), 1, "removed directory 2a verbose undef"); |
255 | |
256 | @created = mkpath($dir, 0, undef); |
257 | is(scalar(@created), 1, "created directory (old style 3 mode undef)"); |
258 | is($created[0], $dir, "created directory (old style 3 mode undef) cross-check"); |
259 | is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef"); |
260 | |
0b3d36bd |
261 | $dir = catdir($tmp_base,'G'); |
5808899a |
262 | $dir = VMS::Filespec::unixify($dir) if $Is_VMS; |
0b3d36bd |
263 | |
264 | @created = mkpath($dir, undef, 0200); |
265 | is(scalar(@created), 1, "created write-only dir"); |
266 | is($created[0], $dir, "created write-only directory cross-check"); |
267 | is(rmtree($dir), 1, "removed write-only dir"); |
268 | |
12c2e016 |
269 | # borderline new-style heuristics |
270 | if (chdir $tmp_base) { |
271 | pass("chdir to temp dir"); |
272 | } |
273 | else { |
274 | fail("chdir to temp dir: $!"); |
037c8c09 |
275 | } |
12c2e016 |
276 | |
277 | $dir = catdir('a', 'd1'); |
278 | $dir2 = catdir('a', 'd2'); |
279 | |
3f083399 |
280 | @created = make_path( $dir, 0, $dir2 ); |
12c2e016 |
281 | is(scalar @created, 3, 'new-style 3 dirs created'); |
282 | |
3f083399 |
283 | $count = remove_tree( $dir, 0, $dir2, ); |
12c2e016 |
284 | is($count, 3, 'new-style 3 dirs removed'); |
285 | |
3f083399 |
286 | @created = make_path( $dir, $dir2, 1 ); |
12c2e016 |
287 | is(scalar @created, 3, 'new-style 3 dirs created (redux)'); |
288 | |
3f083399 |
289 | $count = remove_tree( $dir, $dir2, 1 ); |
12c2e016 |
290 | is($count, 3, 'new-style 3 dirs removed (redux)'); |
291 | |
3f083399 |
292 | @created = make_path( $dir, $dir2 ); |
12c2e016 |
293 | is(scalar @created, 2, 'new-style 2 dirs created'); |
294 | |
3f083399 |
295 | $count = remove_tree( $dir, $dir2 ); |
12c2e016 |
296 | is($count, 2, 'new-style 2 dirs removed'); |
297 | |
298 | if (chdir updir()) { |
299 | pass("chdir parent"); |
300 | } |
301 | else { |
302 | fail("chdir parent: $!"); |
303 | } |
304 | |
3f083399 |
305 | SKIP: { |
839bc55a |
306 | skip "This is not a MSWin32 platform", 1 |
307 | unless $^O eq 'MSWin32'; |
308 | |
309 | my $UNC_path_taint = $ENV{PERL_FILE_PATH_UNC_TESTDIR}; |
310 | skip "PERL_FILE_PATH_UNC_TESTDIR environment variable not set", 1 |
311 | unless defined($UNC_path_taint); |
312 | |
313 | my ($UNC_path) = ($UNC_path_taint =~ m{^([/\\]{2}\w+[/\\]\w+[/\\]\w+)$}); |
314 | |
315 | skip "PERL_FILE_PATH_UNC_TESTDIR environment variable does not point to a directory", 1 |
316 | unless -d $UNC_path; |
317 | |
318 | my $removed = rmtree($UNC_path); |
319 | cmp_ok($removed, '>', 0, "removed $removed entries from $UNC_path"); |
320 | } |
321 | |
322 | SKIP: { |
3f083399 |
323 | # test bug http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=487319 |
324 | skip "Don't need Force_Writeable semantics on $^O", 4 |
325 | if grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2); |
30cf951a |
326 | skip "Symlinks not available", 4 unless $Config{'d_symlink'}; |
3f083399 |
327 | $dir = 'bug487319'; |
328 | $dir2 = 'bug487319-symlink'; |
329 | @created = make_path($dir, {mask => 0700}); |
330 | is(scalar @created, 1, 'bug 487319 setup'); |
331 | symlink($dir, $dir2); |
332 | ok(-e $dir2, "debian bug 487319 setup symlink") or diag($dir2); |
333 | |
334 | chmod 0500, $dir; |
335 | my $mask_initial = (stat $dir)[2]; |
336 | remove_tree($dir2); |
337 | |
338 | my $mask = (stat $dir)[2]; |
339 | is( $mask, $mask_initial, 'mask of symlink target dir unchanged (debian bug 487319)'); |
340 | |
341 | # now try a file |
342 | my $file = catfile($dir, 'file'); |
343 | open my $out, '>', $file; |
344 | close $out; |
345 | |
346 | chmod 0500, $file; |
347 | $mask_initial = (stat $file)[2]; |
348 | |
349 | my $file2 = catfile($dir, 'symlink'); |
350 | symlink($file, $file2); |
351 | remove_tree($file2); |
352 | |
353 | $mask = (stat $file)[2]; |
354 | is( $mask, $mask_initial, 'mask of symlink target file unchanged (debian bug 487319)'); |
355 | |
356 | remove_tree($dir); |
357 | } |
358 | |
12c2e016 |
359 | # see what happens if a file exists where we want a directory |
360 | SKIP: { |
361 | my $entry = catdir($tmp_base, "file"); |
362 | skip "Cannot create $entry", 4 unless open OUT, "> $entry"; |
363 | print OUT "test file, safe to delete\n", scalar(localtime), "\n"; |
364 | close OUT; |
365 | ok(-e $entry, "file exists in place of directory"); |
366 | |
367 | mkpath( $entry, {error => \$error} ); |
368 | is( scalar(@$error), 1, "caught error condition" ); |
369 | ($file, $message) = each %{$error->[0]}; |
370 | is( $entry, $file, "and the message is: $message"); |
371 | |
372 | eval {@created = mkpath($entry, 0, 0700)}; |
373 | $error = $@; |
374 | chomp $error; # just to remove silly # in TAP output |
375 | cmp_ok( $error, 'ne', "", "no directory created (old-style) err=$error" ) |
376 | or diag(@created); |
377 | } |
378 | |
379 | my $extra = catdir(curdir(), qw(EXTRA 1 a)); |
380 | |
381 | SKIP: { |
37b1cd44 |
382 | skip "extra scenarios not set up, see eg/setup-extra-tests", 14 |
12c2e016 |
383 | unless -e $extra; |
30cf951a |
384 | skip "Symlinks not available", 14 unless $Config{'d_symlink'}; |
12c2e016 |
385 | |
386 | my ($list, $err); |
387 | $dir = catdir( 'EXTRA', '1' ); |
388 | rmtree( $dir, {result => \$list, error => \$err} ); |
389 | is(scalar(@$list), 2, "extra dir $dir removed"); |
390 | is(scalar(@$err), 1, "one error encountered"); |
391 | |
392 | $dir = catdir( 'EXTRA', '3', 'N' ); |
393 | rmtree( $dir, {result => \$list, error => \$err} ); |
394 | is( @$list, 1, q{remove a symlinked dir} ); |
395 | is( @$err, 0, q{with no errors} ); |
396 | |
397 | $dir = catdir('EXTRA', '3', 'S'); |
398 | rmtree($dir, {error => \$error}); |
0b3d36bd |
399 | is( scalar(@$error), 1, 'one error for an unreadable dir' ); |
37b1cd44 |
400 | eval { ($file, $message) = each %{$error->[0]}}; |
401 | is( $file, $dir, 'unreadable dir reported in error' ) |
402 | or diag($message); |
12c2e016 |
403 | |
cd117d8b |
404 | $dir = catdir('EXTRA', '3', 'T'); |
405 | rmtree($dir, {error => \$error}); |
37b1cd44 |
406 | is( scalar(@$error), 1, 'one error for an unreadable dir T' ); |
407 | eval { ($file, $message) = each %{$error->[0]}}; |
408 | is( $file, $dir, 'unreadable dir reported in error T' ); |
cd117d8b |
409 | |
12c2e016 |
410 | $dir = catdir( 'EXTRA', '4' ); |
411 | rmtree($dir, {result => \$list, error => \$err} ); |
37b1cd44 |
412 | is( scalar(@$list), 0, q{don't follow a symlinked dir} ); |
413 | is( scalar(@$err), 2, q{two errors when removing a symlink in r/o dir} ); |
12c2e016 |
414 | eval { ($file, $message) = each %{$err->[0]} }; |
415 | is( $file, $dir, 'symlink reported in error' ); |
37b1cd44 |
416 | |
417 | $dir = catdir('EXTRA', '3', 'U'); |
418 | $dir2 = catdir('EXTRA', '3', 'V'); |
419 | rmtree($dir, $dir2, {verbose => 0, error => \$err, result => \$list}); |
420 | is( scalar(@$list), 1, q{deleted 1 out of 2 directories} ); |
421 | is( scalar(@$error), 1, q{left behind 1 out of 2 directories} ); |
422 | eval { ($file, $message) = each %{$err->[0]} }; |
423 | is( $file, $dir, 'first dir reported in error' ); |
12c2e016 |
424 | } |
425 | |
3376a30f |
426 | { |
d2f50e7f |
427 | $dir = catdir($tmp_base, 'ZZ'); |
3376a30f |
428 | @created = mkpath($dir); |
d2f50e7f |
429 | is(scalar(@created), 1, "create a ZZ directory"); |
3376a30f |
430 | |
431 | local @ARGV = ($dir); |
432 | rmtree( [grep -e $_, @ARGV], 0, 0 ); |
433 | ok(!-e $dir, "blow it away via \@ARGV"); |
434 | } |
435 | |
12c2e016 |
436 | SKIP: { |
cd117d8b |
437 | skip 'Test::Output not available', 14 |
12c2e016 |
438 | unless $has_Test_Output; |
439 | |
440 | SKIP: { |
441 | $dir = catdir('EXTRA', '3'); |
538f81fb |
442 | skip "extra scenarios not set up, see eg/setup-extra-tests", 3 |
12c2e016 |
443 | unless -e $dir; |
444 | |
cd117d8b |
445 | $dir = catdir('EXTRA', '3', 'U'); |
446 | stderr_like( |
447 | sub {rmtree($dir, {verbose => 0})}, |
0b3d36bd |
448 | qr{\Acannot make child directory read-write-exec for [^:]+: .* at \S+ line \d+}, |
449 | q(rmtree can't chdir into root dir) |
cd117d8b |
450 | ); |
451 | |
452 | $dir = catdir('EXTRA', '3'); |
12c2e016 |
453 | stderr_like( |
454 | sub {rmtree($dir, {})}, |
0b3d36bd |
455 | qr{\Acannot make child directory read-write-exec for [^:]+: .* at (\S+) line (\d+) |
456 | cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 |
457 | cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 |
458 | cannot remove directory for [^:]+: .* at \1 line \2}, |
12c2e016 |
459 | 'rmtree with file owned by root' |
460 | ); |
461 | |
462 | stderr_like( |
463 | sub {rmtree('EXTRA', {})}, |
0b3d36bd |
464 | qr{\Acannot remove directory for [^:]+: .* at (\S+) line (\d+) |
465 | cannot remove directory for [^:]+: .* at \1 line \2 |
466 | cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 |
467 | cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 |
468 | cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 |
469 | cannot remove directory for [^:]+: .* at \1 line \2 |
470 | cannot unlink file for [^:]+: .* at \1 line \2 |
471 | cannot restore permissions to \d+ for [^:]+: .* at \1 line \2 |
472 | cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 |
839bc55a |
473 | cannot remove directory for [^:]+: .* at \1 line \2}, |
12c2e016 |
474 | 'rmtree with insufficient privileges' |
475 | ); |
476 | } |
477 | |
478 | my $base = catdir($tmp_base,'output'); |
479 | $dir = catdir($base,'A'); |
480 | $dir2 = catdir($base,'B'); |
481 | |
482 | stderr_like( |
3376a30f |
483 | sub { rmtree( undef, 1 ) }, |
12c2e016 |
484 | qr/\ANo root path\(s\) specified\b/, |
485 | "rmtree of nothing carps sensibly" |
486 | ); |
487 | |
cd117d8b |
488 | stderr_like( |
489 | sub { rmtree( '', 1 ) }, |
490 | qr/\ANo root path\(s\) specified\b/, |
491 | "rmtree of empty dir carps sensibly" |
492 | ); |
493 | |
3f083399 |
494 | stderr_is( sub { make_path() }, '', "make_path no args does not carp" ); |
495 | stderr_is( sub { remove_tree() }, '', "remove_tree no args does not carp" ); |
cd117d8b |
496 | |
12c2e016 |
497 | stdout_is( |
498 | sub {@created = mkpath($dir, 1)}, |
499 | "mkdir $base\nmkdir $dir\n", |
500 | 'mkpath verbose (old style 1)' |
501 | ); |
502 | |
503 | stdout_is( |
504 | sub {@created = mkpath([$dir2], 1)}, |
505 | "mkdir $dir2\n", |
506 | 'mkpath verbose (old style 2)' |
507 | ); |
508 | |
509 | stdout_is( |
510 | sub {$count = rmtree([$dir, $dir2], 1, 1)}, |
511 | "rmdir $dir\nrmdir $dir2\n", |
512 | 'rmtree verbose (old style)' |
513 | ); |
514 | |
515 | stdout_is( |
516 | sub {@created = mkpath($dir, {verbose => 1, mask => 0750})}, |
517 | "mkdir $dir\n", |
518 | 'mkpath verbose (new style 1)' |
519 | ); |
520 | |
521 | stdout_is( |
522 | sub {@created = mkpath($dir2, 1, 0771)}, |
523 | "mkdir $dir2\n", |
524 | 'mkpath verbose (new style 2)' |
525 | ); |
526 | |
527 | SKIP: { |
528 | $file = catdir($dir2, "file"); |
529 | skip "Cannot create $file", 2 unless open OUT, "> $file"; |
530 | print OUT "test file, safe to delete\n", scalar(localtime), "\n"; |
531 | close OUT; |
532 | |
533 | ok(-e $file, "file created in directory"); |
534 | |
535 | stdout_is( |
536 | sub {$count = rmtree($dir, $dir2, {verbose => 1, safe => 1})}, |
537 | "rmdir $dir\nunlink $file\nrmdir $dir2\n", |
538 | 'rmtree safe verbose (new style)' |
539 | ); |
540 | } |
541 | } |
542 | |
543 | SKIP: { |
0b3d36bd |
544 | skip "extra scenarios not set up, see eg/setup-extra-tests", 11 |
12c2e016 |
545 | unless -d catdir(qw(EXTRA 1)); |
546 | |
547 | rmtree 'EXTRA', {safe => 0, error => \$error}; |
839bc55a |
548 | is( scalar(@$error), 10, 'seven deadly sins' ); # well there used to be 7 |
12c2e016 |
549 | |
550 | rmtree 'EXTRA', {safe => 1, error => \$error}; |
0b3d36bd |
551 | is( scalar(@$error), 9, 'safe is better' ); |
12c2e016 |
552 | for (@$error) { |
553 | ($file, $message) = each %$_; |
554 | if ($file =~ /[123]\z/) { |
0b3d36bd |
555 | is(index($message, 'cannot remove directory: '), 0, "failed to remove $file with rmdir") |
12c2e016 |
556 | or diag($message); |
557 | } |
558 | else { |
0b3d36bd |
559 | like($message, qr(\Acannot (?:restore permissions to \d+|chdir to child|unlink file): ), "failed to remove $file with unlink") |
560 | or diag($message) |
12c2e016 |
561 | } |
562 | } |
563 | } |
564 | |
0e5b5e32 |
565 | SKIP: { |
566 | my $nr_tests = 6; |
567 | my $cwd = getcwd() or skip "failed to getcwd: $!", $nr_tests; |
568 | rmtree($tmp_base, {result => \$list} ); |
569 | is(ref($list), 'ARRAY', "received a final list of results"); |
570 | ok( !(-d $tmp_base), "test base directory gone" ); |
571 | |
572 | my $p = getcwd(); |
573 | my $x = "x$$"; |
574 | my $xx = $x . "x"; |
575 | |
576 | # setup |
577 | ok(mkpath($xx)); |
578 | ok(chdir($xx)); |
579 | END { |
580 | ok(chdir($p)); |
581 | ok(rmtree($xx)); |
582 | } |
583 | |
584 | # create and delete directory |
585 | my $px = catdir($p, $x); |
586 | ok(mkpath($px)); |
587 | ok(rmtree($px), "rmtree"); # fails in File-Path-2.07 |
588 | } |