Commit | Line | Data |
---|---|---|
1fc4cb55 | 1 | package File::Path; |
fed7345c AD |
2 | |
3 | =head1 NAME | |
4 | ||
12c2e016 DL |
5 | File::Path - Create or remove directory trees |
6 | ||
7 | =head1 VERSION | |
8 | ||
37b1cd44 DL |
9 | This document describes version 2.00_12 of File::Path, released |
10 | 2007-09-17. | |
fed7345c AD |
11 | |
12 | =head1 SYNOPSIS | |
13 | ||
8b87c192 | 14 | use File::Path; |
fed7345c | 15 | |
12c2e016 DL |
16 | # modern |
17 | mkpath( 'foo/bar/baz', '/zug/zwang', {verbose => 1} ); | |
18 | ||
19 | rmtree( | |
20 | 'foo/bar/baz', '/zug/zwang', | |
91c4f65e | 21 | { verbose => 1, error => \my $err_list } |
12c2e016 DL |
22 | ); |
23 | ||
24 | # traditional | |
8b87c192 GS |
25 | mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); |
26 | rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1); | |
fed7345c AD |
27 | |
28 | =head1 DESCRIPTION | |
29 | ||
0b3d36bd DL |
30 | The C<mkpath> function provides a convenient way to create directories |
31 | of arbitrary depth. Similarly, the C<rmtree> function provides a | |
32 | convenient way to delete an entire directory subtree from the | |
33 | filesystem, much like the Unix command C<rm -r>. | |
12c2e016 DL |
34 | |
35 | Both functions may be called in one of two ways, the traditional, | |
36 | compatible with code written since the dawn of time, and modern, | |
37 | that offers a more flexible and readable idiom. New code should use | |
38 | the modern interface. | |
39 | ||
40 | =head2 FUNCTIONS | |
41 | ||
0b3d36bd DL |
42 | The modern way of calling C<mkpath> and C<rmtree> is with a list |
43 | of directories to create, or remove, respectively, followed by an | |
44 | optional hash reference containing keys to control the | |
45 | function's behaviour. | |
12c2e016 DL |
46 | |
47 | =head3 C<mkpath> | |
48 | ||
0b3d36bd DL |
49 | The following keys are recognised as parameters to C<mkpath>. |
50 | The function returns the list of files actually created during the | |
51 | call. | |
12c2e016 DL |
52 | |
53 | my @created = mkpath( | |
54 | qw(/tmp /flub /home/nobody), | |
55 | {verbose => 1, mode => 0750}, | |
56 | ); | |
57 | print "created $_\n" for @created; | |
58 | ||
59 | =over 4 | |
60 | ||
61 | =item mode | |
62 | ||
0b3d36bd DL |
63 | The numeric permissions mode to apply to each created directory |
64 | (defaults to 0777), to be modified by the current C<umask>. If the | |
65 | directory already exists (and thus does not need to be created), | |
66 | the permissions will not be modified. | |
67 | ||
68 | C<mask> is recognised as an alias for this parameter. | |
12c2e016 DL |
69 | |
70 | =item verbose | |
71 | ||
72 | If present, will cause C<mkpath> to print the name of each directory | |
73 | as it is created. By default nothing is printed. | |
74 | ||
75 | =item error | |
76 | ||
77 | If present, will be interpreted as a reference to a list, and will | |
78 | be used to store any errors that are encountered. See the ERROR | |
0b3d36bd | 79 | HANDLING section for more information. |
12c2e016 | 80 | |
0b3d36bd DL |
81 | If this parameter is not used, certain error conditions may raise |
82 | a fatal error that will cause the program will halt, unless trapped | |
83 | in an C<eval> block. | |
12c2e016 DL |
84 | |
85 | =back | |
86 | ||
87 | =head3 C<rmtree> | |
88 | ||
89 | =over 4 | |
90 | ||
91 | =item verbose | |
92 | ||
93 | If present, will cause C<rmtree> to print the name of each file as | |
94 | it is unlinked. By default nothing is printed. | |
95 | ||
96 | =item skip_others | |
97 | ||
0b3d36bd DL |
98 | When set to a true value, will cause C<rmtree> to skip the files |
99 | for which the process lacks the required privileges needed to delete | |
100 | files, such as delete privileges on VMS. | |
12c2e016 DL |
101 | |
102 | =item keep_root | |
103 | ||
0b3d36bd DL |
104 | When set to a true value, will cause all files and subdirectories |
105 | to be removed, except the initially specified directories. This comes | |
106 | in handy when cleaning out an application's scratch directory. | |
12c2e016 DL |
107 | |
108 | rmtree( '/tmp', {keep_root => 1} ); | |
109 | ||
110 | =item result | |
111 | ||
112 | If present, will be interpreted as a reference to a list, and will | |
113 | be used to store the list of all files and directories unlinked | |
114 | during the call. If nothing is unlinked, a reference to an empty | |
115 | list is returned (rather than C<undef>). | |
116 | ||
117 | rmtree( '/tmp', {result => \my $list} ); | |
118 | print "unlinked $_\n" for @$list; | |
119 | ||
0b3d36bd DL |
120 | This is a useful alternative to the C<verbose> key. |
121 | ||
12c2e016 DL |
122 | =item error |
123 | ||
124 | If present, will be interpreted as a reference to a list, | |
125 | and will be used to store any errors that are encountered. | |
0b3d36bd | 126 | See the ERROR HANDLING section for more information. |
12c2e016 | 127 | |
0b3d36bd DL |
128 | Removing things is a much more dangerous proposition than |
129 | creating things. As such, there are certain conditions that | |
130 | C<rmtree> may encounter that are so dangerous that the only | |
131 | sane action left is to kill the program. | |
132 | ||
133 | Use C<error> to trap all that is reasonable (problems with | |
134 | permissions and the like), and let it die if things get out | |
135 | of hand. This is the safest course of action. | |
12c2e016 DL |
136 | |
137 | =back | |
138 | ||
139 | =head2 TRADITIONAL INTERFACE | |
140 | ||
0b3d36bd DL |
141 | The old interfaces of C<mkpath> and C<rmtree> take a reference to |
142 | a list of directories (to create or remove), followed by a series | |
143 | of positional, numeric, modal parameters that control their behaviour. | |
144 | ||
145 | This design made it difficult to add additional functionality, as | |
146 | well as posed the problem of what to do when the calling code only | |
147 | needs to set the last parameter. Even though the code doesn't care | |
148 | how the initial positional parameters are set, the programmer is | |
149 | forced to learn what the defaults are, and specify them. | |
12c2e016 | 150 | |
0b3d36bd DL |
151 | Worse, if it turns out in the future that it would make more sense |
152 | to change the default behaviour of the first parameter (for example, | |
153 | to avoid a security vulnerability), all existing code will remain | |
154 | hard-wired to the wrong defaults. | |
12c2e016 | 155 | |
0b3d36bd DL |
156 | Finally, a series of numeric parameters are much less self-documenting |
157 | in terms of communicating to the reader what the code is doing. Named | |
158 | parameters do not have this problem. | |
159 | ||
160 | In the traditional API, C<mkpath> takes three arguments: | |
fed7345c AD |
161 | |
162 | =over 4 | |
163 | ||
164 | =item * | |
165 | ||
0b3d36bd DL |
166 | The name of the path to create, or a reference to a list of paths |
167 | to create, | |
fed7345c AD |
168 | |
169 | =item * | |
170 | ||
0b3d36bd DL |
171 | a boolean value, which if TRUE will cause C<mkpath> to print the |
172 | name of each directory as it is created (defaults to FALSE), and | |
fed7345c AD |
173 | |
174 | =item * | |
175 | ||
0b3d36bd DL |
176 | the numeric mode to use when creating the directories (defaults to |
177 | 0777), to be modified by the current umask. | |
fed7345c AD |
178 | |
179 | =back | |
180 | ||
037c8c09 | 181 | It returns a list of all directories (including intermediates, determined |
cc61921f GA |
182 | using the Unix '/' separator) created. In scalar context it returns |
183 | the number of directories created. | |
fed7345c | 184 | |
070ed461 | 185 | If a system error prevents a directory from being created, then the |
99c4c5e8 AMS |
186 | C<mkpath> function throws a fatal error with C<Carp::croak>. This error |
187 | can be trapped with an C<eval> block: | |
070ed461 CM |
188 | |
189 | eval { mkpath($dir) }; | |
190 | if ($@) { | |
191 | print "Couldn't create $dir: $@"; | |
192 | } | |
193 | ||
0b3d36bd | 194 | In the traditional API, C<rmtree> takes three arguments: |
fed7345c AD |
195 | |
196 | =over 4 | |
197 | ||
198 | =item * | |
199 | ||
0b3d36bd DL |
200 | the root of the subtree to delete, or a reference to a list of |
201 | roots. All of the files and directories below each root, as well | |
202 | as the roots themselves, will be deleted. If you want to keep | |
203 | the roots themselves, you must use the modern API. | |
fed7345c AD |
204 | |
205 | =item * | |
206 | ||
0b3d36bd DL |
207 | a boolean value, which if TRUE will cause C<rmtree> to print a |
208 | message each time it examines a file, giving the name of the file, | |
209 | and indicating whether it's using C<rmdir> or C<unlink> to remove | |
210 | it, or that it's skipping it. (defaults to FALSE) | |
fed7345c AD |
211 | |
212 | =item * | |
213 | ||
0b3d36bd DL |
214 | a boolean value, which if TRUE will cause C<rmtree> to skip any |
215 | files to which you do not have delete access (if running under VMS) | |
216 | or write access (if running under another OS). This will change | |
217 | in the future when a criterion for 'delete permission' under OSs | |
218 | other than VMS is settled. (defaults to FALSE) | |
fed7345c AD |
219 | |
220 | =back | |
221 | ||
cc61921f GA |
222 | It returns the number of files, directories and symlinks successfully |
223 | deleted. Symlinks are simply deleted and not followed. | |
fed7345c | 224 | |
12c2e016 DL |
225 | Note also that the occurrence of errors in C<rmtree> using the |
226 | traditional interface can be determined I<only> by trapping diagnostic | |
227 | messages using C<$SIG{__WARN__}>; it is not apparent from the return | |
228 | value. (The modern interface may use the C<error> parameter to | |
0b3d36bd | 229 | record any problems encountered). |
12c2e016 DL |
230 | |
231 | =head2 ERROR HANDLING | |
232 | ||
233 | If C<mkpath> or C<rmtree> encounter an error, a diagnostic message | |
234 | will be printed to C<STDERR> via C<carp> (for non-fatal errors), | |
235 | or via C<croak> (for fatal errors). | |
236 | ||
237 | If this behaviour is not desirable, the C<error> attribute may be | |
238 | used to hold a reference to a variable, which will be used to store | |
239 | the diagnostics. The result is a reference to a list of hash | |
240 | references. For each hash reference, the key is the name of the | |
241 | file, and the value is the error message (usually the contents of | |
242 | C<$!>). An example usage looks like: | |
243 | ||
244 | rmpath( 'foo/bar', 'bar/rat', {error => \my $err} ); | |
245 | for my $diag (@$err) { | |
246 | my ($file, $message) = each %$diag; | |
247 | print "problem unlinking $file: $message\n"; | |
248 | } | |
249 | ||
250 | If no errors are encountered, C<$err> will point to an empty list | |
251 | (thus there is no need to test for C<undef>). If a general error | |
252 | is encountered (for instance, C<rmtree> attempts to remove a directory | |
253 | tree that does not exist), the diagnostic key will be empty, only | |
254 | the value will be set: | |
255 | ||
256 | rmpath( '/no/such/path', {error => \my $err} ); | |
257 | for my $diag (@$err) { | |
258 | my ($file, $message) = each %$diag; | |
259 | if ($file eq '') { | |
260 | print "general error: $message\n"; | |
261 | } | |
262 | } | |
263 | ||
264 | =head2 NOTES | |
265 | ||
0b3d36bd DL |
266 | C<File::Path> blindly exports C<mkpath> and C<rmtree> into the |
267 | current namespace. These days, this is considered bad style, but | |
268 | to change it now would break too much code. Nonetheless, you are | |
269 | invited to specify what it is you are expecting to use: | |
270 | ||
271 | use File::Path 'rmtree'; | |
272 | ||
12c2e016 DL |
273 | =head3 HEURISTICS |
274 | ||
275 | The functions detect (as far as possible) which way they are being | |
276 | called and will act appropriately. It is important to remember that | |
277 | the heuristic for detecting the old style is either the presence | |
278 | of an array reference, or two or three parameters total and second | |
279 | and third parameters are numeric. Hence... | |
280 | ||
0b3d36bd | 281 | mkpath 486, 487, 488; |
12c2e016 DL |
282 | |
283 | ... will not assume the modern style and create three directories, rather | |
284 | it will create one directory verbosely, setting the permission to | |
285 | 0750 (488 being the decimal equivalent of octal 750). Here, old | |
286 | style trumps new. It must, for backwards compatibility reasons. | |
e2ba98a1 | 287 | |
12c2e016 DL |
288 | If you want to ensure there is absolutely no ambiguity about which |
289 | way the function will behave, make sure the first parameter is a | |
290 | reference to a one-element list, to force the old style interpretation: | |
e2ba98a1 | 291 | |
0b3d36bd | 292 | mkpath [486], 487, 488; |
12c2e016 DL |
293 | |
294 | and get only one directory created. Or add a reference to an empty | |
295 | parameter hash, to force the new style: | |
296 | ||
0b3d36bd | 297 | mkpath 486, 487, 488, {}; |
12c2e016 DL |
298 | |
299 | ... and hence create the three directories. If the empty hash | |
300 | reference seems a little strange to your eyes, or you suspect a | |
301 | subsequent programmer might I<helpfully> optimise it away, you | |
302 | can add a parameter set to a default value: | |
303 | ||
0b3d36bd | 304 | mkpath 486, 487, 488, {verbose => 0}; |
12c2e016 | 305 | |
0b3d36bd | 306 | =head3 SECURITY CONSIDERATIONS |
12c2e016 | 307 | |
0b3d36bd DL |
308 | There were race conditions 1.x implementations of File::Path's |
309 | C<rmtree> function (although sometimes patched depending on the OS | |
310 | distribution or platform). The 2.0 version contains code to avoid the | |
311 | problem mentioned in CVE-2002-0435. | |
12c2e016 | 312 | |
0b3d36bd | 313 | See the following pages for more information: |
12c2e016 | 314 | |
0b3d36bd DL |
315 | http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=286905 |
316 | http://www.nntp.perl.org/group/perl.perl5.porters/2005/01/msg97623.html | |
317 | http://www.debian.org/security/2005/dsa-696 | |
12c2e016 | 318 | |
0b3d36bd | 319 | Additionally, unless the C<skip_others> parameter is set (or the |
37b1cd44 | 320 | third parameter in the traditional interface is TRUE), should a |
0b3d36bd DL |
321 | C<rmtree> be interrupted, files that were originally in read-only |
322 | mode may now have their permissions set to a read-write (or "delete | |
323 | OK") mode. | |
96e4d5b1 | 324 | |
b8d5f521 CW |
325 | =head1 DIAGNOSTICS |
326 | ||
0b3d36bd DL |
327 | FATAL errors will cause the program to halt (C<croak>), since the |
328 | problem is so severe that it would be dangerous to continue. (This | |
329 | can always be trapped with C<eval>, but it's not a good idea. Under | |
330 | the circumstances, dying is the best thing to do). | |
331 | ||
332 | SEVERE errors may be trapped using the modern interface. If the | |
333 | they are not trapped, or the old interface is used, such an error | |
334 | will cause the program will halt. | |
335 | ||
336 | All other errors may be trapped using the modern interface, otherwise | |
337 | they will be C<carp>ed about. Program execution will not be halted. | |
338 | ||
b8d5f521 CW |
339 | =over 4 |
340 | ||
37b1cd44 | 341 | =item mkdir [path]: [errmsg] (SEVERE) |
0b3d36bd DL |
342 | |
343 | C<mkpath> was unable to create the path. Probably some sort of | |
344 | permissions error at the point of departure, or insufficient resources | |
345 | (such as free inodes on Unix). | |
346 | ||
347 | =item No root path(s) specified | |
348 | ||
349 | C<mkpath> was not given any paths to create. This message is only | |
350 | emitted if the routine is called with the traditional interface. | |
351 | The modern interface will remain silent if given nothing to do. | |
352 | ||
353 | =item No such file or directory | |
354 | ||
355 | On Windows, if C<mkpath> gives you this warning, it may mean that | |
356 | you have exceeded your filesystem's maximum path length. | |
357 | ||
358 | =item cannot fetch initial working directory: [errmsg] | |
359 | ||
360 | C<rmtree> attempted to determine the initial directory by calling | |
361 | C<Cwd::getcwd>, but the call failed for some reason. No attempt | |
362 | will be made to delete anything. | |
363 | ||
364 | =item cannot stat initial working directory: [errmsg] | |
365 | ||
366 | C<rmtree> attempted to stat the initial directory (after having | |
367 | successfully obtained its name via C<getcwd>), however, the call | |
368 | failed for some reason. No attempt will be made to delete anything. | |
369 | ||
370 | =item cannot chdir to [dir]: [errmsg] | |
371 | ||
372 | C<rmtree> attempted to set the working directory in order to | |
373 | begin deleting the objects therein, but was unsuccessful. This is | |
374 | usually a permissions issue. The routine will continue to delete | |
375 | other things, but this directory will be left intact. | |
376 | ||
377 | =item directory [dir] changed before chdir, expected dev=[n] inode=[n], actual dev=[n] ino=[n], aborting. (FATAL) | |
378 | ||
379 | C<rmtree> recorded the device and inode of a directory, and then | |
380 | moved into it. It then performed a C<stat> on the current directory | |
381 | and detected that the device and inode were no longer the same. As | |
382 | this is at the heart of the race condition problem, the program | |
383 | will die at this point. | |
384 | ||
385 | =item cannot make directory [dir] read+writeable: [errmsg] | |
386 | ||
387 | C<rmtree> attempted to change the permissions on the current directory | |
388 | to ensure that subsequent unlinkings would not run into problems, | |
389 | but was unable to do so. The permissions remain as they were, and | |
390 | the program will carry on, doing the best it can. | |
391 | ||
392 | =item cannot read [dir]: [errmsg] | |
393 | ||
394 | C<rmtree> tried to read the contents of the directory in order | |
395 | to acquire the names of the directory entries to be unlinked, but | |
396 | was unsuccessful. This is usually a permissions issue. The | |
397 | program will continue, but the files in this directory will remain | |
398 | after the call. | |
399 | ||
400 | =item cannot reset chmod [dir]: [errmsg] | |
401 | ||
402 | C<rmtree>, after having deleted everything in a directory, attempted | |
403 | to restore its permissions to the original state but failed. The | |
404 | directory may wind up being left behind. | |
405 | ||
406 | =item cannot chdir to [parent-dir] from [child-dir]: [errmsg], aborting. (FATAL) | |
407 | ||
408 | C<rmtree>, after having deleted everything and restored the permissions | |
409 | of a directory, was unable to chdir back to the parent. This is usually | |
410 | a sign that something evil this way comes. | |
411 | ||
412 | =item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL) | |
413 | ||
414 | C<rmtree> was unable to stat the parent directory after have returned | |
415 | from the child. Since there is no way of knowing if we returned to | |
416 | where we think we should be (by comparing device and inode) the only | |
417 | way out is to C<croak>. | |
418 | ||
419 | =item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] inode=[n], actual dev=[n] ino=[n], aborting. (FATAL) | |
420 | ||
421 | When C<rmtree> returned from deleting files in a child directory, a | |
422 | check revealed that the parent directory it returned to wasn't the one | |
423 | it started out from. This is considered a sign of malicious activity. | |
424 | ||
425 | =item cannot make directory [dir] writeable: [errmsg] | |
426 | ||
427 | Just before removing a directory (after having successfully removed | |
428 | everything it contained), C<rmtree> attempted to set the permissions | |
429 | on the directory to ensure it could be removed and failed. Program | |
430 | execution continues, but the directory may possibly not be deleted. | |
431 | ||
432 | =item cannot remove directory [dir]: [errmsg] | |
433 | ||
434 | C<rmtree> attempted to remove a directory, but failed. This may because | |
435 | some objects that were unable to be removed remain in the directory, or | |
436 | a permissions issue. The directory will be left behind. | |
437 | ||
438 | =item cannot restore permissions of [dir] to [0nnn]: [errmsg] | |
439 | ||
440 | After having failed to remove a directory, C<rmtree> was unable to | |
441 | restore its permissions from a permissive state back to a possibly | |
442 | more restrictive setting. (Permissions given in octal). | |
443 | ||
444 | =item cannot make file [file] writeable: [errmsg] | |
445 | ||
446 | C<rmtree> attempted to force the permissions of a file to ensure it | |
447 | could be deleted, but failed to do so. It will, however, still attempt | |
448 | to unlink the file. | |
449 | ||
450 | =item cannot unlink file [file]: [errmsg] | |
b8d5f521 | 451 | |
0b3d36bd DL |
452 | C<rmtree> failed to remove a file. Probably a permissions issue. |
453 | ||
454 | =item cannot restore permissions of [file] to [0nnn]: [errmsg] | |
455 | ||
456 | After having failed to remove a file, C<rmtree> was also unable | |
37b1cd44 | 457 | to restore the permissions on the file to a possibly less permissive |
0b3d36bd | 458 | setting. (Permissions given in octal). |
b8d5f521 CW |
459 | |
460 | =back | |
461 | ||
12c2e016 DL |
462 | =head1 SEE ALSO |
463 | ||
464 | =over 4 | |
465 | ||
466 | =item * | |
467 | ||
468 | L<Find::File::Rule> | |
469 | ||
0b3d36bd DL |
470 | When removing directory trees, if you want to examine each file to |
471 | decide whether to delete it (and possibly leaving large swathes | |
472 | alone), F<File::Find::Rule> offers a convenient and flexible approach | |
473 | to examining directory trees. | |
12c2e016 DL |
474 | |
475 | =back | |
476 | ||
477 | =head1 BUGS | |
478 | ||
479 | Please report all bugs on the RT queue: | |
480 | ||
481 | L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path> | |
482 | ||
0b3d36bd | 483 | =head1 ACKNOWLEDGEMENTS |
fed7345c | 484 | |
37b1cd44 | 485 | Paul Szabo identified the race condition originally, and Brendan |
0b3d36bd DL |
486 | O'Dea wrote an implementation for Debian that addressed the problem. |
487 | That code was used as a basis for the current code. Their efforts | |
488 | are greatly appreciated. | |
12c2e016 | 489 | |
0b3d36bd DL |
490 | =head1 AUTHORS |
491 | ||
492 | Tim Bunce <F<Tim.Bunce@ig.co.uk>> and Charles Bailey | |
493 | <F<bailey@newman.upenn.edu>>. Currently maintained by David Landgren | |
494 | <F<david@landgren.net>>. | |
12c2e016 DL |
495 | |
496 | =head1 COPYRIGHT | |
497 | ||
498 | This module is copyright (C) Charles Bailey, Tim Bunce and | |
499 | David Landgren 1995-2007. All rights reserved. | |
500 | ||
501 | =head1 LICENSE | |
502 | ||
503 | This library is free software; you can redistribute it and/or modify | |
504 | it under the same terms as Perl itself. | |
fed7345c | 505 | |
fed7345c AD |
506 | =cut |
507 | ||
12c2e016 | 508 | use 5.005_04; |
037c8c09 | 509 | use strict; |
68dc0745 | 510 | |
0b3d36bd | 511 | use Cwd 'getcwd'; |
12c2e016 DL |
512 | use File::Basename (); |
513 | use File::Spec (); | |
0b3d36bd | 514 | |
12c2e016 | 515 | BEGIN { |
91c4f65e | 516 | if ($] < 5.006) { |
12c2e016 DL |
517 | # can't say 'opendir my $dh, $dirname' |
518 | # need to initialise $dh | |
519 | eval "use Symbol"; | |
520 | } | |
521 | } | |
522 | ||
523 | use Exporter (); | |
524 | use vars qw($VERSION @ISA @EXPORT); | |
37b1cd44 | 525 | $VERSION = '2.00_11'; |
12c2e016 DL |
526 | @ISA = qw(Exporter); |
527 | @EXPORT = qw(mkpath rmtree); | |
fed7345c | 528 | |
68dc0745 | 529 | my $Is_VMS = $^O eq 'VMS'; |
ffb9ee5f | 530 | my $Is_MacOS = $^O eq 'MacOS'; |
037c8c09 CS |
531 | |
532 | # These OSes complain if you want to remove a file that you have no | |
533 | # write permission to: | |
12c2e016 | 534 | my $Force_Writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' || |
fa6a1c44 | 535 | $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc'); |
748a9306 | 536 | |
12c2e016 | 537 | sub _carp { |
8878f897 T |
538 | require Carp; |
539 | goto &Carp::carp; | |
540 | } | |
541 | ||
12c2e016 | 542 | sub _croak { |
8878f897 T |
543 | require Carp; |
544 | goto &Carp::croak; | |
545 | } | |
546 | ||
0b3d36bd DL |
547 | sub _error { |
548 | my $arg = shift; | |
549 | my $message = shift; | |
550 | my $object = shift; | |
551 | ||
552 | if ($arg->{error}) { | |
553 | $object = '' unless defined $object; | |
554 | push @{${$arg->{error}}}, {$object => "$message: $!"}; | |
555 | } | |
556 | else { | |
557 | _carp(defined($object) ? "$message for $object: $!" : "$message: $!"); | |
558 | } | |
559 | } | |
560 | ||
a5f75d66 | 561 | sub mkpath { |
cd117d8b | 562 | my $old_style = ( |
3376a30f | 563 | UNIVERSAL::isa($_[0],'ARRAY') |
b92ffa59 DL |
564 | or (@_ == 2 and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1)) |
565 | or (@_ == 3 | |
566 | and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1) | |
567 | and (defined $_[2] ? $_[2] =~ /\A\d+\z/ : 1) | |
568 | ) | |
cd117d8b | 569 | ) ? 1 : 0; |
12c2e016 DL |
570 | |
571 | my $arg; | |
572 | my $paths; | |
573 | ||
cd117d8b DL |
574 | if ($old_style) { |
575 | my ($verbose, $mode); | |
576 | ($paths, $verbose, $mode) = @_; | |
577 | $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY'); | |
578 | $arg->{verbose} = defined $verbose ? $verbose : 0; | |
579 | $arg->{mode} = defined $mode ? $mode : 0777; | |
580 | } | |
581 | else { | |
3376a30f | 582 | if (@_ > 0 and UNIVERSAL::isa($_[-1], 'HASH')) { |
12c2e016 DL |
583 | $arg = pop @_; |
584 | exists $arg->{mask} and $arg->{mode} = delete $arg->{mask}; | |
585 | $arg->{mode} = 0777 unless exists $arg->{mode}; | |
586 | ${$arg->{error}} = [] if exists $arg->{error}; | |
587 | } | |
588 | else { | |
589 | @{$arg}{qw(verbose mode)} = (0, 0777); | |
590 | } | |
591 | $paths = [@_]; | |
592 | } | |
12c2e016 DL |
593 | return _mkpath($arg, $paths); |
594 | } | |
595 | ||
596 | sub _mkpath { | |
597 | my $arg = shift; | |
598 | my $paths = shift; | |
599 | ||
ffb9ee5f | 600 | local($")=$Is_MacOS ? ":" : "/"; |
037c8c09 | 601 | my(@created,$path); |
68dc0745 | 602 | foreach $path (@$paths) { |
12c2e016 | 603 | next unless length($path); |
1b1e14d3 | 604 | $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT |
037c8c09 | 605 | # Logic wants Unix paths, so go with the flow. |
e3830a4e CB |
606 | if ($Is_VMS) { |
607 | next if $path eq '/'; | |
608 | $path = VMS::Filespec::unixify($path); | |
491527d0 | 609 | } |
e3830a4e CB |
610 | next if -d $path; |
611 | my $parent = File::Basename::dirname($path); | |
612 | unless (-d $parent or $path eq $parent) { | |
12c2e016 DL |
613 | push(@created,_mkpath($arg, [$parent])); |
614 | } | |
615 | print "mkdir $path\n" if $arg->{verbose}; | |
616 | if (mkdir($path,$arg->{mode})) { | |
617 | push(@created, $path); | |
dde45d8e | 618 | } |
12c2e016 DL |
619 | else { |
620 | my $save_bang = $!; | |
621 | my ($e, $e1) = ($save_bang, $^E); | |
dde45d8e | 622 | $e .= "; $e1" if $e ne $e1; |
c3420933 | 623 | # allow for another process to have created it meanwhile |
12c2e016 DL |
624 | if (!-d $path) { |
625 | $! = $save_bang; | |
626 | if ($arg->{error}) { | |
627 | push @{${$arg->{error}}}, {$path => $e}; | |
628 | } | |
629 | else { | |
630 | _croak("mkdir $path: $e"); | |
631 | } | |
67e4c828 | 632 | } |
fed7345c | 633 | } |
12c2e016 DL |
634 | } |
635 | return @created; | |
fed7345c AD |
636 | } |
637 | ||
638 | sub rmtree { | |
cd117d8b | 639 | my $old_style = ( |
3376a30f | 640 | UNIVERSAL::isa($_[0],'ARRAY') |
b92ffa59 DL |
641 | or (@_ == 2 and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1)) |
642 | or (@_ == 3 | |
643 | and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1) | |
644 | and (defined $_[2] ? $_[2] =~ /\A\d+\z/ : 1) | |
645 | ) | |
cd117d8b | 646 | ) ? 1 : 0; |
12c2e016 DL |
647 | |
648 | my $arg; | |
649 | my $paths; | |
650 | ||
cd117d8b | 651 | if ($old_style) { |
12c2e016 DL |
652 | my ($verbose, $safe); |
653 | ($paths, $verbose, $safe) = @_; | |
12c2e016 DL |
654 | $arg->{verbose} = defined $verbose ? $verbose : 0; |
655 | $arg->{safe} = defined $safe ? $safe : 0; | |
fed7345c | 656 | |
3376a30f DL |
657 | if (defined($paths) and length($paths)) { |
658 | $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY'); | |
659 | } | |
660 | else { | |
cd117d8b DL |
661 | _carp ("No root path(s) specified\n"); |
662 | return 0; | |
663 | } | |
ee79a11f PM |
664 | } |
665 | else { | |
cd117d8b DL |
666 | if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH')) { |
667 | $arg = pop @_; | |
668 | ${$arg->{error}} = [] if exists $arg->{error}; | |
669 | ${$arg->{result}} = [] if exists $arg->{result}; | |
12c2e016 | 670 | } |
cd117d8b DL |
671 | else { |
672 | @{$arg}{qw(verbose safe)} = (0, 0); | |
ee79a11f | 673 | } |
cd117d8b | 674 | $paths = [@_]; |
3376a30f | 675 | } |
0b3d36bd DL |
676 | |
677 | $arg->{prefix} = ''; | |
678 | $arg->{depth} = 0; | |
679 | ||
680 | $arg->{cwd} = getcwd() or do { | |
681 | _error($arg, "cannot fetch initial working directory"); | |
682 | return 0; | |
683 | }; | |
684 | for ($arg->{cwd}) { /\A(.*)\Z/; $_ = $1 } # untaint | |
685 | ||
686 | @{$arg}{qw(device inode)} = (stat $arg->{cwd})[0,1] or do { | |
687 | _error($arg, "cannot stat initial working directory", $arg->{cwd}); | |
688 | return 0; | |
689 | }; | |
690 | ||
12c2e016 DL |
691 | return _rmtree($arg, $paths); |
692 | } | |
ee79a11f | 693 | |
12c2e016 DL |
694 | sub _rmtree { |
695 | my $arg = shift; | |
696 | my $paths = shift; | |
0b3d36bd DL |
697 | |
698 | my $count = 0; | |
699 | my $curdir = File::Spec->curdir(); | |
700 | my $updir = File::Spec->updir(); | |
701 | ||
12c2e016 | 702 | my (@files, $root); |
37b1cd44 | 703 | ROOT_DIR: |
cd117d8b | 704 | foreach $root (@$paths) { |
ffb9ee5f | 705 | if ($Is_MacOS) { |
0b3d36bd DL |
706 | $root = ":$root" unless $root =~ /:/; |
707 | $root .= ":" unless $root =~ /:\z/; | |
12c2e016 DL |
708 | } |
709 | else { | |
0b3d36bd | 710 | $root =~ s{/\z}{}; |
ffb9ee5f | 711 | } |
0b3d36bd DL |
712 | |
713 | # since we chdir into each directory, it may not be obvious | |
714 | # to figure out where we are if we generate a message about | |
715 | # a file name. We therefore construct a semi-canonical | |
716 | # filename, anchored from the directory being unlinked (as | |
717 | # opposed to being truly canonical, anchored from the root (/). | |
718 | ||
719 | my $canon = $arg->{prefix} | |
b5400373 | 720 | ? File::Spec->catfile($arg->{prefix}, $root) |
0b3d36bd DL |
721 | : $root |
722 | ; | |
723 | ||
37b1cd44 | 724 | my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next ROOT_DIR; |
b5400373 | 725 | |
7025f710 | 726 | if ( -d _ ) { |
b5400373 | 727 | $root = VMS::Filespec::pathify($root) if $Is_VMS; |
0b3d36bd DL |
728 | if (!chdir($root)) { |
729 | # see if we can escalate privileges to get in | |
730 | # (e.g. funny protection mask such as -w- instead of rwx) | |
731 | $perm &= 07777; | |
732 | my $nperm = $perm | 0700; | |
733 | if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $root))) { | |
734 | _error($arg, "cannot make child directory read-write-exec", $canon); | |
37b1cd44 | 735 | next ROOT_DIR; |
0b3d36bd DL |
736 | } |
737 | elsif (!chdir($root)) { | |
738 | _error($arg, "cannot chdir to child", $canon); | |
37b1cd44 | 739 | next ROOT_DIR; |
0b3d36bd DL |
740 | } |
741 | } | |
742 | ||
743 | my ($device, $inode, $perm) = (stat $curdir)[0,1,2] or do { | |
744 | _error($arg, "cannot stat current working directory", $canon); | |
37b1cd44 | 745 | next ROOT_DIR; |
0b3d36bd DL |
746 | }; |
747 | ||
748 | ($ldev eq $device and $lino eq $inode) | |
749 | or _croak("directory $canon changed before chdir, expected dev=$ldev inode=$lino, actual dev=$device ino=$inode, aborting."); | |
750 | ||
751 | $perm &= 07777; # don't forget setuid, setgid, sticky bits | |
752 | my $nperm = $perm | 0700; | |
753 | ||
e2ba98a1 | 754 | # notabene: 0700 is for making readable in the first place, |
037c8c09 CS |
755 | # it's also intended to change it to writable in case we have |
756 | # to recurse in which case we are better than rm -rf for | |
757 | # subtrees with strange permissions | |
0b3d36bd DL |
758 | |
759 | if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $curdir))) { | |
760 | _error($arg, "cannot make directory read+writeable", $canon); | |
761 | $nperm = $perm; | |
12c2e016 DL |
762 | } |
763 | ||
764 | my $d; | |
765 | $d = gensym() if $] < 5.006; | |
0b3d36bd DL |
766 | if (!opendir $d, $curdir) { |
767 | _error($arg, "cannot opendir", $canon); | |
12c2e016 DL |
768 | @files = (); |
769 | } | |
770 | else { | |
7068481f RGS |
771 | no strict 'refs'; |
772 | if (!defined ${"\cTAINT"} or ${"\cTAINT"}) { | |
12c2e016 DL |
773 | # Blindly untaint dir names if taint mode is |
774 | # active, or any perl < 5.006 | |
775 | @files = map { /\A(.*)\z/s; $1 } readdir $d; | |
776 | } | |
777 | else { | |
7068481f RGS |
778 | @files = readdir $d; |
779 | } | |
ff21075d GS |
780 | closedir $d; |
781 | } | |
037c8c09 | 782 | |
463ea4b9 | 783 | if ($Is_VMS) { |
0b3d36bd DL |
784 | # Deleting large numbers of files from VMS Files-11 |
785 | # filesystems is faster if done in reverse ASCIIbetical order. | |
786 | # include '.' to '.;' from blead patch #31775 | |
787 | @files = map {$_ eq '.' ? '.;' : $_} reverse @files; | |
788 | ($root = VMS::Filespec::unixify($root)) =~ s/\.dir\z//; | |
789 | } | |
790 | @files = grep {$_ ne $updir and $_ ne $curdir} @files; | |
791 | ||
792 | if (@files) { | |
793 | # remove the contained files before the directory itself | |
794 | my $narg = {%$arg}; | |
795 | @{$narg}{qw(device inode cwd prefix depth)} | |
796 | = ($device, $inode, $updir, $canon, $arg->{depth}+1); | |
797 | $count += _rmtree($narg, \@files); | |
798 | } | |
799 | ||
800 | # restore directory permissions of required now (in case the rmdir | |
801 | # below fails), while we are still in the directory and may do so | |
802 | # without a race via '.' | |
803 | if ($nperm != $perm and not chmod($perm, $curdir)) { | |
804 | _error($arg, "cannot reset chmod", $canon); | |
12c2e016 | 805 | } |
0b3d36bd DL |
806 | |
807 | # don't leave the client code in an unexpected directory | |
808 | chdir($arg->{cwd}) | |
809 | or _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting."); | |
810 | ||
811 | # ensure that a chdir upwards didn't take us somewhere other | |
812 | # than we expected (see CVE-2002-0435) | |
813 | ($device, $inode) = (stat $curdir)[0,1] | |
814 | or _croak("cannot stat prior working directory $arg->{cwd}: $!, aborting."); | |
815 | ||
816 | ($arg->{device} eq $device and $arg->{inode} eq $inode) | |
817 | or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev inode=$lino, actual dev=$device ino=$inode, aborting."); | |
818 | ||
12c2e016 DL |
819 | if ($arg->{depth} or !$arg->{keep_root}) { |
820 | if ($arg->{safe} && | |
037c8c09 | 821 | ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { |
12c2e016 | 822 | print "skipped $root\n" if $arg->{verbose}; |
37b1cd44 | 823 | next ROOT_DIR; |
037c8c09 | 824 | } |
0b3d36bd | 825 | if (!chmod $perm | 0700, $root) { |
12c2e016 | 826 | if ($Force_Writeable) { |
0b3d36bd | 827 | _error($arg, "cannot make directory writeable", $canon); |
12c2e016 DL |
828 | } |
829 | } | |
830 | print "rmdir $root\n" if $arg->{verbose}; | |
96e4d5b1 | 831 | if (rmdir $root) { |
12c2e016 | 832 | push @{${$arg->{result}}}, $root if $arg->{result}; |
96e4d5b1 | 833 | ++$count; |
834 | } | |
835 | else { | |
0b3d36bd DL |
836 | _error($arg, "cannot remove directory", $canon); |
837 | if (!chmod($perm, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) | |
12c2e016 | 838 | ) { |
0b3d36bd | 839 | _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon); |
12c2e016 DL |
840 | } |
841 | } | |
842 | } | |
843 | } | |
844 | else { | |
0b3d36bd | 845 | # not a directory |
b5400373 CB |
846 | |
847 | $root = VMS::Filespec::vmsify("./$root") | |
848 | if $Is_VMS && !File::Spec->file_name_is_absolute($root); | |
849 | ||
12c2e016 | 850 | if ($arg->{safe} && |
64f6ddac GS |
851 | ($Is_VMS ? !&VMS::Filespec::candelete($root) |
852 | : !(-l $root || -w $root))) | |
853 | { | |
12c2e016 | 854 | print "skipped $root\n" if $arg->{verbose}; |
37b1cd44 | 855 | next ROOT_DIR; |
037c8c09 | 856 | } |
0b3d36bd DL |
857 | |
858 | my $nperm = $perm & 07777 | 0600; | |
859 | if ($nperm != $perm and not chmod $nperm, $root) { | |
12c2e016 | 860 | if ($Force_Writeable) { |
0b3d36bd | 861 | _error($arg, "cannot make file writeable", $canon); |
12c2e016 DL |
862 | } |
863 | } | |
0b3d36bd | 864 | print "unlink $canon\n" if $arg->{verbose}; |
037c8c09 | 865 | # delete all versions under VMS |
94d4f21c | 866 | for (;;) { |
12c2e016 DL |
867 | if (unlink $root) { |
868 | push @{${$arg->{result}}}, $root if $arg->{result}; | |
869 | } | |
870 | else { | |
0b3d36bd DL |
871 | _error($arg, "cannot unlink file", $canon); |
872 | $Force_Writeable and chmod($perm, $root) or | |
873 | _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon); | |
94d4f21c | 874 | last; |
96e4d5b1 | 875 | } |
94d4f21c CS |
876 | ++$count; |
877 | last unless $Is_VMS && lstat $root; | |
037c8c09 CS |
878 | } |
879 | } | |
fed7345c AD |
880 | } |
881 | ||
12c2e016 | 882 | return $count; |
fed7345c AD |
883 | } |
884 | ||
885 | 1; |