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