Commit | Line | Data |
12c2e016 |
1 | # Path.t -- tests for module File::Path |
1a3850a5 |
2 | |
037c8c09 |
3 | use strict; |
4 | |
351a5cfe |
5 | use Test::More tests => 99; |
1a3850a5 |
6 | |
12c2e016 |
7 | BEGIN { |
8 | use_ok('File::Path'); |
9 | use_ok('File::Spec::Functions'); |
10 | } |
11 | |
12 | eval "use Test::Output"; |
13 | my $has_Test_Output = $@ ? 0 : 1; |
1a3850a5 |
14 | |
5808899a |
15 | my $Is_VMS = $^O eq 'VMS'; |
16 | |
037c8c09 |
17 | # first check for stupid permissions second for full, so we clean up |
18 | # behind ourselves |
19 | for my $perm (0111,0777) { |
e7780b56 |
20 | my $path = catdir(curdir(), "mhx", "bar"); |
d5201bd2 |
21 | mkpath($path); |
e7780b56 |
22 | chmod $perm, "mhx", $path; |
1a3850a5 |
23 | |
12c2e016 |
24 | my $oct = sprintf('0%o', $perm); |
25 | ok(-d "mhx", "mkdir parent dir $oct"); |
26 | ok(-d $path, "mkdir child dir $oct"); |
1a3850a5 |
27 | |
e7780b56 |
28 | rmtree("mhx"); |
12c2e016 |
29 | ok(! -e "mhx", "mhx does not exist $oct"); |
30 | } |
31 | |
32 | # find a place to work |
33 | my ($error, $list, $file, $message); |
34 | my $tmp_base = catdir( |
35 | curdir(), |
36 | sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ), |
37 | ); |
38 | |
39 | # invent some names |
40 | my @dir = ( |
41 | catdir($tmp_base, qw(a b)), |
42 | catdir($tmp_base, qw(a c)), |
43 | catdir($tmp_base, qw(z b)), |
44 | catdir($tmp_base, qw(z c)), |
45 | ); |
46 | |
47 | # create them |
48 | my @created = mkpath(@dir); |
49 | |
50 | is(scalar(@created), 7, "created list of directories"); |
51 | |
52 | # pray for no race conditions blowing them out from under us |
53 | @created = mkpath([$tmp_base]); |
54 | is(scalar(@created), 0, "skipped making existing directory") |
55 | or diag("unexpectedly recreated @created"); |
56 | |
351a5cfe |
57 | # create a file |
58 | my $file_name = catfile( $tmp_base, 'a', 'delete.me' ); |
59 | my $file_count = 0; |
60 | if (open OUT, "> $file_name") { |
61 | print OUT "this file may be deleted\n"; |
62 | close OUT; |
63 | ++$file_count; |
64 | } |
65 | else { |
66 | diag( "Failed to create file $file_name: $!" ); |
67 | } |
68 | |
69 | SKIP: { |
70 | skip "cannot remove a file we failed to create", 1 |
71 | unless $file_count == 1; |
72 | my $count = rmtree($file_name); |
73 | is($count, 1, "rmtree'ed a file"); |
74 | } |
75 | |
12c2e016 |
76 | @created = mkpath(''); |
77 | is(scalar(@created), 0, "Can't create a directory named ''"); |
78 | |
79 | my $dir; |
80 | my $dir2; |
81 | |
82 | SKIP: { |
83 | $dir = catdir($tmp_base, 'B'); |
84 | $dir2 = catdir($dir, updir()); |
85 | # IOW: File::Spec->catdir( qw(foo bar), File::Spec->updir ) eq 'foo' |
86 | # rather than foo/bar/.. |
87 | skip "updir() canonicalises path on this platform", 2 |
91c4f65e |
88 | if $dir2 eq $tmp_base |
89 | or $^O eq 'cygwin'; |
12c2e016 |
90 | |
91 | @created = mkpath($dir2, {mask => 0700}); |
92 | is(scalar(@created), 1, "make directory with trailing parent segment"); |
93 | is($created[0], $dir, "made parent"); |
94 | }; |
95 | |
96 | my $count = rmtree({error => \$error}); |
97 | is( $count, 0, 'rmtree of nothing, count of zero' ); |
3376a30f |
98 | is( scalar(@$error), 0, 'no diagnostic captured' ); |
12c2e016 |
99 | |
100 | @created = mkpath($tmp_base, 0); |
101 | is(scalar(@created), 0, "skipped making existing directories (old style 1)") |
102 | or diag("unexpectedly recreated @created"); |
103 | |
104 | $dir = catdir($tmp_base,'C'); |
fa06c9c1 |
105 | # mkpath returns unix syntax filespecs on VMS |
5808899a |
106 | $dir = VMS::Filespec::unixify($dir) if $Is_VMS; |
12c2e016 |
107 | @created = mkpath($tmp_base, $dir); |
108 | is(scalar(@created), 1, "created directory (new style 1)"); |
109 | is($created[0], $dir, "created directory (new style 1) cross-check"); |
110 | |
111 | @created = mkpath($tmp_base, 0, 0700); |
112 | is(scalar(@created), 0, "skipped making existing directories (old style 2)") |
113 | or diag("unexpectedly recreated @created"); |
114 | |
115 | $dir2 = catdir($tmp_base,'D'); |
fa06c9c1 |
116 | # mkpath returns unix syntax filespecs on VMS |
5808899a |
117 | $dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS; |
12c2e016 |
118 | @created = mkpath($tmp_base, $dir, $dir2); |
119 | is(scalar(@created), 1, "created directory (new style 2)"); |
120 | is($created[0], $dir2, "created directory (new style 2) cross-check"); |
121 | |
122 | $count = rmtree($dir, 0); |
5808899a |
123 | is($count, 1, "removed directory unsafe mode"); |
12c2e016 |
124 | |
125 | $count = rmtree($dir2, 0, 1); |
5808899a |
126 | my $removed = $Is_VMS ? 0 : 1; |
127 | is($count, $removed, "removed directory safe mode"); |
12c2e016 |
128 | |
129 | # mkdir foo ./E/../Y |
130 | # Y should exist |
131 | # existence of E is neither here nor there |
132 | $dir = catdir($tmp_base, 'E', updir(), 'Y'); |
133 | @created =mkpath($dir); |
134 | cmp_ok(scalar(@created), '>=', 1, "made one or more dirs because of .."); |
135 | cmp_ok(scalar(@created), '<=', 2, "made less than two dirs because of .."); |
136 | ok( -d catdir($tmp_base, 'Y'), "directory after parent" ); |
137 | |
138 | @created = mkpath(catdir(curdir(), $tmp_base)); |
139 | is(scalar(@created), 0, "nothing created") |
140 | or diag(@created); |
141 | |
142 | $dir = catdir($tmp_base, 'a'); |
143 | $dir2 = catdir($tmp_base, 'z'); |
144 | |
145 | rmtree( $dir, $dir2, |
146 | { |
147 | error => \$error, |
148 | result => \$list, |
149 | keep_root => 1, |
150 | } |
151 | ); |
152 | |
153 | is(scalar(@$error), 0, "no errors unlinking a and z"); |
154 | is(scalar(@$list), 4, "list contains 4 elements") |
155 | or diag("@$list"); |
156 | |
157 | ok(-d $dir, "dir a still exists"); |
158 | ok(-d $dir2, "dir z still exists"); |
159 | |
cd117d8b |
160 | $dir = catdir($tmp_base,'F'); |
181b7e95 |
161 | # mkpath returns unix syntax filespecs on VMS |
5808899a |
162 | $dir = VMS::Filespec::unixify($dir) if $Is_VMS; |
cd117d8b |
163 | |
164 | @created = mkpath($dir, undef, 0770); |
165 | is(scalar(@created), 1, "created directory (old style 2 verbose undef)"); |
166 | is($created[0], $dir, "created directory (old style 2 verbose undef) cross-check"); |
167 | is(rmtree($dir, undef, 0), 1, "removed directory 2 verbose undef"); |
168 | |
169 | @created = mkpath($dir, undef); |
170 | is(scalar(@created), 1, "created directory (old style 2a verbose undef)"); |
171 | is($created[0], $dir, "created directory (old style 2a verbose undef) cross-check"); |
172 | is(rmtree($dir, undef), 1, "removed directory 2a verbose undef"); |
173 | |
174 | @created = mkpath($dir, 0, undef); |
175 | is(scalar(@created), 1, "created directory (old style 3 mode undef)"); |
176 | is($created[0], $dir, "created directory (old style 3 mode undef) cross-check"); |
177 | is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef"); |
178 | |
0b3d36bd |
179 | $dir = catdir($tmp_base,'G'); |
5808899a |
180 | $dir = VMS::Filespec::unixify($dir) if $Is_VMS; |
0b3d36bd |
181 | |
182 | @created = mkpath($dir, undef, 0200); |
183 | is(scalar(@created), 1, "created write-only dir"); |
184 | is($created[0], $dir, "created write-only directory cross-check"); |
185 | is(rmtree($dir), 1, "removed write-only dir"); |
186 | |
12c2e016 |
187 | # borderline new-style heuristics |
188 | if (chdir $tmp_base) { |
189 | pass("chdir to temp dir"); |
190 | } |
191 | else { |
192 | fail("chdir to temp dir: $!"); |
037c8c09 |
193 | } |
12c2e016 |
194 | |
195 | $dir = catdir('a', 'd1'); |
196 | $dir2 = catdir('a', 'd2'); |
197 | |
198 | @created = mkpath( $dir, 0, $dir2 ); |
199 | is(scalar @created, 3, 'new-style 3 dirs created'); |
200 | |
201 | $count = rmtree( $dir, 0, $dir2, ); |
202 | is($count, 3, 'new-style 3 dirs removed'); |
203 | |
204 | @created = mkpath( $dir, $dir2, 1 ); |
205 | is(scalar @created, 3, 'new-style 3 dirs created (redux)'); |
206 | |
207 | $count = rmtree( $dir, $dir2, 1 ); |
208 | is($count, 3, 'new-style 3 dirs removed (redux)'); |
209 | |
210 | @created = mkpath( $dir, $dir2 ); |
211 | is(scalar @created, 2, 'new-style 2 dirs created'); |
212 | |
213 | $count = rmtree( $dir, $dir2 ); |
214 | is($count, 2, 'new-style 2 dirs removed'); |
215 | |
216 | if (chdir updir()) { |
217 | pass("chdir parent"); |
218 | } |
219 | else { |
220 | fail("chdir parent: $!"); |
221 | } |
222 | |
223 | # see what happens if a file exists where we want a directory |
224 | SKIP: { |
225 | my $entry = catdir($tmp_base, "file"); |
226 | skip "Cannot create $entry", 4 unless open OUT, "> $entry"; |
227 | print OUT "test file, safe to delete\n", scalar(localtime), "\n"; |
228 | close OUT; |
229 | ok(-e $entry, "file exists in place of directory"); |
230 | |
231 | mkpath( $entry, {error => \$error} ); |
232 | is( scalar(@$error), 1, "caught error condition" ); |
233 | ($file, $message) = each %{$error->[0]}; |
234 | is( $entry, $file, "and the message is: $message"); |
235 | |
236 | eval {@created = mkpath($entry, 0, 0700)}; |
237 | $error = $@; |
238 | chomp $error; # just to remove silly # in TAP output |
239 | cmp_ok( $error, 'ne', "", "no directory created (old-style) err=$error" ) |
240 | or diag(@created); |
241 | } |
242 | |
243 | my $extra = catdir(curdir(), qw(EXTRA 1 a)); |
244 | |
245 | SKIP: { |
37b1cd44 |
246 | skip "extra scenarios not set up, see eg/setup-extra-tests", 14 |
12c2e016 |
247 | unless -e $extra; |
248 | |
249 | my ($list, $err); |
250 | $dir = catdir( 'EXTRA', '1' ); |
251 | rmtree( $dir, {result => \$list, error => \$err} ); |
252 | is(scalar(@$list), 2, "extra dir $dir removed"); |
253 | is(scalar(@$err), 1, "one error encountered"); |
254 | |
255 | $dir = catdir( 'EXTRA', '3', 'N' ); |
256 | rmtree( $dir, {result => \$list, error => \$err} ); |
257 | is( @$list, 1, q{remove a symlinked dir} ); |
258 | is( @$err, 0, q{with no errors} ); |
259 | |
260 | $dir = catdir('EXTRA', '3', 'S'); |
261 | rmtree($dir, {error => \$error}); |
0b3d36bd |
262 | is( scalar(@$error), 1, 'one error for an unreadable dir' ); |
37b1cd44 |
263 | eval { ($file, $message) = each %{$error->[0]}}; |
264 | is( $file, $dir, 'unreadable dir reported in error' ) |
265 | or diag($message); |
12c2e016 |
266 | |
cd117d8b |
267 | $dir = catdir('EXTRA', '3', 'T'); |
268 | rmtree($dir, {error => \$error}); |
37b1cd44 |
269 | is( scalar(@$error), 1, 'one error for an unreadable dir T' ); |
270 | eval { ($file, $message) = each %{$error->[0]}}; |
271 | is( $file, $dir, 'unreadable dir reported in error T' ); |
cd117d8b |
272 | |
12c2e016 |
273 | $dir = catdir( 'EXTRA', '4' ); |
274 | rmtree($dir, {result => \$list, error => \$err} ); |
37b1cd44 |
275 | is( scalar(@$list), 0, q{don't follow a symlinked dir} ); |
276 | is( scalar(@$err), 2, q{two errors when removing a symlink in r/o dir} ); |
12c2e016 |
277 | eval { ($file, $message) = each %{$err->[0]} }; |
278 | is( $file, $dir, 'symlink reported in error' ); |
37b1cd44 |
279 | |
280 | $dir = catdir('EXTRA', '3', 'U'); |
281 | $dir2 = catdir('EXTRA', '3', 'V'); |
282 | rmtree($dir, $dir2, {verbose => 0, error => \$err, result => \$list}); |
283 | is( scalar(@$list), 1, q{deleted 1 out of 2 directories} ); |
284 | is( scalar(@$error), 1, q{left behind 1 out of 2 directories} ); |
285 | eval { ($file, $message) = each %{$err->[0]} }; |
286 | is( $file, $dir, 'first dir reported in error' ); |
12c2e016 |
287 | } |
288 | |
3376a30f |
289 | { |
d2f50e7f |
290 | $dir = catdir($tmp_base, 'ZZ'); |
3376a30f |
291 | @created = mkpath($dir); |
d2f50e7f |
292 | is(scalar(@created), 1, "create a ZZ directory"); |
3376a30f |
293 | |
294 | local @ARGV = ($dir); |
295 | rmtree( [grep -e $_, @ARGV], 0, 0 ); |
296 | ok(!-e $dir, "blow it away via \@ARGV"); |
297 | } |
298 | |
12c2e016 |
299 | SKIP: { |
cd117d8b |
300 | skip 'Test::Output not available', 14 |
12c2e016 |
301 | unless $has_Test_Output; |
302 | |
303 | SKIP: { |
304 | $dir = catdir('EXTRA', '3'); |
538f81fb |
305 | skip "extra scenarios not set up, see eg/setup-extra-tests", 3 |
12c2e016 |
306 | unless -e $dir; |
307 | |
cd117d8b |
308 | $dir = catdir('EXTRA', '3', 'U'); |
309 | stderr_like( |
310 | sub {rmtree($dir, {verbose => 0})}, |
0b3d36bd |
311 | qr{\Acannot make child directory read-write-exec for [^:]+: .* at \S+ line \d+}, |
312 | q(rmtree can't chdir into root dir) |
cd117d8b |
313 | ); |
314 | |
315 | $dir = catdir('EXTRA', '3'); |
12c2e016 |
316 | stderr_like( |
317 | sub {rmtree($dir, {})}, |
0b3d36bd |
318 | qr{\Acannot make child directory read-write-exec for [^:]+: .* at (\S+) line (\d+) |
319 | cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 |
320 | cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 |
321 | cannot remove directory for [^:]+: .* at \1 line \2}, |
12c2e016 |
322 | 'rmtree with file owned by root' |
323 | ); |
324 | |
325 | stderr_like( |
326 | sub {rmtree('EXTRA', {})}, |
0b3d36bd |
327 | qr{\Acannot remove directory for [^:]+: .* at (\S+) line (\d+) |
328 | cannot remove directory for [^:]+: .* at \1 line \2 |
329 | cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 |
330 | cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 |
331 | cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 |
332 | cannot remove directory for [^:]+: .* at \1 line \2 |
333 | cannot unlink file for [^:]+: .* at \1 line \2 |
334 | cannot restore permissions to \d+ for [^:]+: .* at \1 line \2 |
335 | cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 |
336 | cannot remove directory for [^:]+: .* at \1 line \2 |
337 | cannot restore permissions to \d+ for [^:]+: .* at \1 line \2}, |
12c2e016 |
338 | 'rmtree with insufficient privileges' |
339 | ); |
340 | } |
341 | |
342 | my $base = catdir($tmp_base,'output'); |
343 | $dir = catdir($base,'A'); |
344 | $dir2 = catdir($base,'B'); |
345 | |
346 | stderr_like( |
3376a30f |
347 | sub { rmtree( undef, 1 ) }, |
12c2e016 |
348 | qr/\ANo root path\(s\) specified\b/, |
349 | "rmtree of nothing carps sensibly" |
350 | ); |
351 | |
cd117d8b |
352 | stderr_like( |
353 | sub { rmtree( '', 1 ) }, |
354 | qr/\ANo root path\(s\) specified\b/, |
355 | "rmtree of empty dir carps sensibly" |
356 | ); |
357 | |
358 | stderr_is( sub { mkpath() }, '', "mkpath no args does not carp" ); |
359 | stderr_is( sub { rmtree() }, '', "rmtree no args does not carp" ); |
360 | |
12c2e016 |
361 | stdout_is( |
362 | sub {@created = mkpath($dir, 1)}, |
363 | "mkdir $base\nmkdir $dir\n", |
364 | 'mkpath verbose (old style 1)' |
365 | ); |
366 | |
367 | stdout_is( |
368 | sub {@created = mkpath([$dir2], 1)}, |
369 | "mkdir $dir2\n", |
370 | 'mkpath verbose (old style 2)' |
371 | ); |
372 | |
373 | stdout_is( |
374 | sub {$count = rmtree([$dir, $dir2], 1, 1)}, |
375 | "rmdir $dir\nrmdir $dir2\n", |
376 | 'rmtree verbose (old style)' |
377 | ); |
378 | |
379 | stdout_is( |
380 | sub {@created = mkpath($dir, {verbose => 1, mask => 0750})}, |
381 | "mkdir $dir\n", |
382 | 'mkpath verbose (new style 1)' |
383 | ); |
384 | |
385 | stdout_is( |
386 | sub {@created = mkpath($dir2, 1, 0771)}, |
387 | "mkdir $dir2\n", |
388 | 'mkpath verbose (new style 2)' |
389 | ); |
390 | |
391 | SKIP: { |
392 | $file = catdir($dir2, "file"); |
393 | skip "Cannot create $file", 2 unless open OUT, "> $file"; |
394 | print OUT "test file, safe to delete\n", scalar(localtime), "\n"; |
395 | close OUT; |
396 | |
397 | ok(-e $file, "file created in directory"); |
398 | |
399 | stdout_is( |
400 | sub {$count = rmtree($dir, $dir2, {verbose => 1, safe => 1})}, |
401 | "rmdir $dir\nunlink $file\nrmdir $dir2\n", |
402 | 'rmtree safe verbose (new style)' |
403 | ); |
404 | } |
405 | } |
406 | |
407 | SKIP: { |
0b3d36bd |
408 | skip "extra scenarios not set up, see eg/setup-extra-tests", 11 |
12c2e016 |
409 | unless -d catdir(qw(EXTRA 1)); |
410 | |
411 | rmtree 'EXTRA', {safe => 0, error => \$error}; |
0b3d36bd |
412 | is( scalar(@$error), 11, 'seven deadly sins' ); # well there used to be 7 |
12c2e016 |
413 | |
414 | rmtree 'EXTRA', {safe => 1, error => \$error}; |
0b3d36bd |
415 | is( scalar(@$error), 9, 'safe is better' ); |
12c2e016 |
416 | for (@$error) { |
417 | ($file, $message) = each %$_; |
418 | if ($file =~ /[123]\z/) { |
0b3d36bd |
419 | is(index($message, 'cannot remove directory: '), 0, "failed to remove $file with rmdir") |
12c2e016 |
420 | or diag($message); |
421 | } |
422 | else { |
0b3d36bd |
423 | like($message, qr(\Acannot (?:restore permissions to \d+|chdir to child|unlink file): ), "failed to remove $file with unlink") |
424 | or diag($message) |
12c2e016 |
425 | } |
426 | } |
427 | } |
428 | |
429 | rmtree($tmp_base, {result => \$list} ); |
430 | is(ref($list), 'ARRAY', "received a final list of results"); |
431 | ok( !(-d $tmp_base), "test base directory gone" ); |