Commit | Line | Data |
12c2e016 |
1 | # Path.t -- tests for module File::Path |
1a3850a5 |
2 | |
037c8c09 |
3 | use strict; |
4 | |
12c2e016 |
5 | use Test::More tests => 72; |
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 | |
037c8c09 |
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 |
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 |
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 |
67 | if $dir2 eq $tmp_base |
68 | or $^O eq 'cygwin'; |
12c2e016 |
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' ); |
77 | is( scalar(@$error), 1, 'one diagnostic captureed' ); |
78 | eval { ($file, $message) = each %{$error->[0]} }; # too early to die, just in case |
79 | is( $@, '', 'decoded diagnostic' ); |
80 | is( $file, '', 'general diagnostic' ); |
81 | is( $message, 'No root path(s) specified', 'expected diagnostic received' ); |
82 | |
83 | @created = mkpath($tmp_base, 0); |
84 | is(scalar(@created), 0, "skipped making existing directories (old style 1)") |
85 | or diag("unexpectedly recreated @created"); |
86 | |
87 | $dir = catdir($tmp_base,'C'); |
88 | @created = mkpath($tmp_base, $dir); |
89 | is(scalar(@created), 1, "created directory (new style 1)"); |
90 | is($created[0], $dir, "created directory (new style 1) cross-check"); |
91 | |
92 | @created = mkpath($tmp_base, 0, 0700); |
93 | is(scalar(@created), 0, "skipped making existing directories (old style 2)") |
94 | or diag("unexpectedly recreated @created"); |
95 | |
96 | $dir2 = catdir($tmp_base,'D'); |
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 | |
138 | # borderline new-style heuristics |
139 | if (chdir $tmp_base) { |
140 | pass("chdir to temp dir"); |
141 | } |
142 | else { |
143 | fail("chdir to temp dir: $!"); |
037c8c09 |
144 | } |
12c2e016 |
145 | |
146 | $dir = catdir('a', 'd1'); |
147 | $dir2 = catdir('a', 'd2'); |
148 | |
149 | @created = mkpath( $dir, 0, $dir2 ); |
150 | is(scalar @created, 3, 'new-style 3 dirs created'); |
151 | |
152 | $count = rmtree( $dir, 0, $dir2, ); |
153 | is($count, 3, 'new-style 3 dirs removed'); |
154 | |
155 | @created = mkpath( $dir, $dir2, 1 ); |
156 | is(scalar @created, 3, 'new-style 3 dirs created (redux)'); |
157 | |
158 | $count = rmtree( $dir, $dir2, 1 ); |
159 | is($count, 3, 'new-style 3 dirs removed (redux)'); |
160 | |
161 | @created = mkpath( $dir, $dir2 ); |
162 | is(scalar @created, 2, 'new-style 2 dirs created'); |
163 | |
164 | $count = rmtree( $dir, $dir2 ); |
165 | is($count, 2, 'new-style 2 dirs removed'); |
166 | |
167 | if (chdir updir()) { |
168 | pass("chdir parent"); |
169 | } |
170 | else { |
171 | fail("chdir parent: $!"); |
172 | } |
173 | |
174 | # see what happens if a file exists where we want a directory |
175 | SKIP: { |
176 | my $entry = catdir($tmp_base, "file"); |
177 | skip "Cannot create $entry", 4 unless open OUT, "> $entry"; |
178 | print OUT "test file, safe to delete\n", scalar(localtime), "\n"; |
179 | close OUT; |
180 | ok(-e $entry, "file exists in place of directory"); |
181 | |
182 | mkpath( $entry, {error => \$error} ); |
183 | is( scalar(@$error), 1, "caught error condition" ); |
184 | ($file, $message) = each %{$error->[0]}; |
185 | is( $entry, $file, "and the message is: $message"); |
186 | |
187 | eval {@created = mkpath($entry, 0, 0700)}; |
188 | $error = $@; |
189 | chomp $error; # just to remove silly # in TAP output |
190 | cmp_ok( $error, 'ne', "", "no directory created (old-style) err=$error" ) |
191 | or diag(@created); |
192 | } |
193 | |
194 | my $extra = catdir(curdir(), qw(EXTRA 1 a)); |
195 | |
196 | SKIP: { |
197 | skip "extra scenarios not set up, see eg/setup-extra-tests", 8 |
198 | unless -e $extra; |
199 | |
200 | my ($list, $err); |
201 | $dir = catdir( 'EXTRA', '1' ); |
202 | rmtree( $dir, {result => \$list, error => \$err} ); |
203 | is(scalar(@$list), 2, "extra dir $dir removed"); |
204 | is(scalar(@$err), 1, "one error encountered"); |
205 | |
206 | $dir = catdir( 'EXTRA', '3', 'N' ); |
207 | rmtree( $dir, {result => \$list, error => \$err} ); |
208 | is( @$list, 1, q{remove a symlinked dir} ); |
209 | is( @$err, 0, q{with no errors} ); |
210 | |
211 | $dir = catdir('EXTRA', '3', 'S'); |
212 | rmtree($dir, {error => \$error}); |
213 | is( scalar(@$error), 2, 'two errors for an unreadable dir' ); |
214 | |
215 | $dir = catdir( 'EXTRA', '4' ); |
216 | rmtree($dir, {result => \$list, error => \$err} ); |
217 | is( @$list, 0, q{don't follow a symlinked dir} ); |
218 | is( @$err, 1, q{one error when removing a symlink in r/o dir} ); |
219 | eval { ($file, $message) = each %{$err->[0]} }; |
220 | is( $file, $dir, 'symlink reported in error' ); |
221 | } |
222 | |
223 | SKIP: { |
224 | skip 'Test::Output not available', 10 |
225 | unless $has_Test_Output; |
226 | |
227 | SKIP: { |
228 | $dir = catdir('EXTRA', '3'); |
229 | skip "extra scenarios not set up, see eg/setup-extra-tests", 2 |
230 | unless -e $dir; |
231 | |
232 | stderr_like( |
233 | sub {rmtree($dir, {})}, |
234 | qr{\ACan't remove directory \S+: .*? at \S+ line \d+\n}, |
235 | 'rmtree with file owned by root' |
236 | ); |
237 | |
238 | stderr_like( |
239 | sub {rmtree('EXTRA', {})}, |
240 | qr{\ACan't make directory EXTRA read\+writeable: .*? at \S+ line \d+ |
241 | (?:Can't remove directory EXTRA/\d: .*? at \S+ line \d+ |
242 | )+Can't unlink file [^:]+: .*? at \S+ line \d+ |
243 | Can't remove directory EXTRA: .*? at \S+ line \d+ |
244 | and can't restore permissions to \d+ |
245 | at \S+ line \d+}, |
246 | 'rmtree with insufficient privileges' |
247 | ); |
248 | } |
249 | |
250 | my $base = catdir($tmp_base,'output'); |
251 | $dir = catdir($base,'A'); |
252 | $dir2 = catdir($base,'B'); |
253 | |
254 | stderr_like( |
255 | \&rmtree, |
256 | qr/\ANo root path\(s\) specified\b/, |
257 | "rmtree of nothing carps sensibly" |
258 | ); |
259 | |
260 | stdout_is( |
261 | sub {@created = mkpath($dir, 1)}, |
262 | "mkdir $base\nmkdir $dir\n", |
263 | 'mkpath verbose (old style 1)' |
264 | ); |
265 | |
266 | stdout_is( |
267 | sub {@created = mkpath([$dir2], 1)}, |
268 | "mkdir $dir2\n", |
269 | 'mkpath verbose (old style 2)' |
270 | ); |
271 | |
272 | stdout_is( |
273 | sub {$count = rmtree([$dir, $dir2], 1, 1)}, |
274 | "rmdir $dir\nrmdir $dir2\n", |
275 | 'rmtree verbose (old style)' |
276 | ); |
277 | |
278 | stdout_is( |
279 | sub {@created = mkpath($dir, {verbose => 1, mask => 0750})}, |
280 | "mkdir $dir\n", |
281 | 'mkpath verbose (new style 1)' |
282 | ); |
283 | |
284 | stdout_is( |
285 | sub {@created = mkpath($dir2, 1, 0771)}, |
286 | "mkdir $dir2\n", |
287 | 'mkpath verbose (new style 2)' |
288 | ); |
289 | |
290 | SKIP: { |
291 | $file = catdir($dir2, "file"); |
292 | skip "Cannot create $file", 2 unless open OUT, "> $file"; |
293 | print OUT "test file, safe to delete\n", scalar(localtime), "\n"; |
294 | close OUT; |
295 | |
296 | ok(-e $file, "file created in directory"); |
297 | |
298 | stdout_is( |
299 | sub {$count = rmtree($dir, $dir2, {verbose => 1, safe => 1})}, |
300 | "rmdir $dir\nunlink $file\nrmdir $dir2\n", |
301 | 'rmtree safe verbose (new style)' |
302 | ); |
303 | } |
304 | } |
305 | |
306 | SKIP: { |
307 | skip "extra scenarios not set up, see eg/setup-extra-tests", 6 |
308 | unless -d catdir(qw(EXTRA 1)); |
309 | |
310 | rmtree 'EXTRA', {safe => 0, error => \$error}; |
311 | is( scalar(@$error), 7, 'seven deadly sins' ); |
312 | |
313 | rmtree 'EXTRA', {safe => 1, error => \$error}; |
314 | is( scalar(@$error), 4, 'safe is better' ); |
315 | for (@$error) { |
316 | ($file, $message) = each %$_; |
317 | if ($file =~ /[123]\z/) { |
318 | is(index($message, 'rmdir: '), 0, "failed to remove $file with rmdir") |
319 | or diag($message); |
320 | } |
321 | else { |
322 | is(index($message, 'unlink: '), 0, "failed to remove $file with unlink") |
323 | or diag($message); |
324 | } |
325 | } |
326 | } |
327 | |
328 | rmtree($tmp_base, {result => \$list} ); |
329 | is(ref($list), 'ARRAY', "received a final list of results"); |
330 | ok( !(-d $tmp_base), "test base directory gone" ); |