Commit | Line | Data |
1fc4cb55 |
1 | package File::Path; |
fed7345c |
2 | |
3 | =head1 NAME |
4 | |
12c2e016 |
5 | File::Path - Create or remove directory trees |
6 | |
7 | =head1 VERSION |
8 | |
9 | This document describes version 2.00 of File::Path, released |
10 | 2007-xx-xx. |
fed7345c |
11 | |
12 | =head1 SYNOPSIS |
13 | |
8b87c192 |
14 | use File::Path; |
fed7345c |
15 | |
12c2e016 |
16 | # modern |
17 | mkpath( 'foo/bar/baz', '/zug/zwang', {verbose => 1} ); |
18 | |
19 | rmtree( |
20 | 'foo/bar/baz', '/zug/zwang', |
21 | { verbose => 1, errors => \my $err_list } |
22 | ); |
23 | |
24 | # traditional |
8b87c192 |
25 | mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); |
26 | rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1); |
fed7345c |
27 | |
28 | =head1 DESCRIPTION |
29 | |
12c2e016 |
30 | The C<mkpath> function provides a convenient way to create directories, |
31 | even if your C<mkdir> kernel call won't create more than one level |
32 | of directory at a time. Similarly, the C<rmtree> function provides |
33 | a convenient way to delete a subtree from the directory structure, |
34 | much like the Unix command C<rm -r>. |
35 | |
36 | Both functions may be called in one of two ways, the traditional, |
37 | compatible with code written since the dawn of time, and modern, |
38 | that offers a more flexible and readable idiom. New code should use |
39 | the modern interface. |
40 | |
41 | =head2 FUNCTIONS |
42 | |
43 | The modern way of calling C<mkpath> and C<rmtree> is with an optional |
44 | hash reference at the end of the parameter list that holds various |
45 | keys that can be used to control the function's behaviour, following |
46 | a plain list of directories upon which to operate. |
47 | |
48 | =head3 C<mkpath> |
49 | |
50 | The following keys are recognised as as parameters to C<mkpath>. |
51 | It returns the list of files actually created during the call. |
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 | |
63 | The numeric mode to use when creating the directories (defaults |
64 | to 07777), to be modified by the current C<umask>. (C<mask> is |
65 | recognised as an alias for this parameter). |
66 | |
67 | =item verbose |
68 | |
69 | If present, will cause C<mkpath> to print the name of each directory |
70 | as it is created. By default nothing is printed. |
71 | |
72 | =item error |
73 | |
74 | If present, will be interpreted as a reference to a list, and will |
75 | be used to store any errors that are encountered. See the ERROR |
76 | HANDLING section below to find out more. |
77 | |
78 | If this parameter is not used, any errors encountered will raise a |
79 | fatal error that need to be trapped in an C<eval> block, or the |
80 | program will halt. |
81 | |
82 | =back |
83 | |
84 | =head3 C<rmtree> |
85 | |
86 | =over 4 |
87 | |
88 | =item verbose |
89 | |
90 | If present, will cause C<rmtree> to print the name of each file as |
91 | it is unlinked. By default nothing is printed. |
92 | |
93 | =item skip_others |
94 | |
95 | When set to a true value, will cause C<rmtree> to skip any files |
96 | to which you do not have delete access (if running under VMS) or |
97 | write access (if running under another OS). This will change in |
98 | the future when a criterion for 'delete permission' under OSs other |
99 | than VMS is settled. |
100 | |
101 | =item keep_root |
102 | |
103 | When set to a true value, will cause everything except the specified |
104 | base directories to be unlinked. This comes in handy when cleaning |
105 | out an application's scratch directory. |
106 | |
107 | rmtree( '/tmp', {keep_root => 1} ); |
108 | |
109 | =item result |
110 | |
111 | If present, will be interpreted as a reference to a list, and will |
112 | be used to store the list of all files and directories unlinked |
113 | during the call. If nothing is unlinked, a reference to an empty |
114 | list is returned (rather than C<undef>). |
115 | |
116 | rmtree( '/tmp', {result => \my $list} ); |
117 | print "unlinked $_\n" for @$list; |
118 | |
119 | =item error |
120 | |
121 | If present, will be interpreted as a reference to a list, |
122 | and will be used to store any errors that are encountered. |
123 | See the ERROR HANDLING section below to find out more. |
124 | |
125 | If this parameter is not used, any errors encountered will |
126 | raise a fatal error that need to be trapped in an C<eval> |
127 | block, or the program will halt. |
128 | |
129 | =back |
130 | |
131 | =head2 TRADITIONAL INTERFACE |
132 | |
133 | The old interface for C<mkpath> and C<rmtree> take a |
134 | reference to a list of directories (to create or remove), |
135 | followed by a series of positional numeric modal parameters that |
136 | control their behaviour. |
137 | |
138 | This design made it difficult to add |
139 | additional functionality, as well as posed the problem |
140 | of what to do when you don't care how the initial |
141 | positional parameters are specified but only the last |
142 | one needs to be specified. The calls themselves are also |
143 | less self-documenting. |
144 | |
145 | C<mkpath> takes three arguments: |
fed7345c |
146 | |
147 | =over 4 |
148 | |
149 | =item * |
150 | |
12c2e016 |
151 | The name of the path to create, or a reference |
fed7345c |
152 | to a list of paths to create, |
153 | |
154 | =item * |
155 | |
156 | a boolean value, which if TRUE will cause C<mkpath> |
157 | to print the name of each directory as it is created |
158 | (defaults to FALSE), and |
159 | |
160 | =item * |
161 | |
162 | the numeric mode to use when creating the directories |
e2ba98a1 |
163 | (defaults to 0777), to be modified by the current umask. |
fed7345c |
164 | |
165 | =back |
166 | |
037c8c09 |
167 | It returns a list of all directories (including intermediates, determined |
cc61921f |
168 | using the Unix '/' separator) created. In scalar context it returns |
169 | the number of directories created. |
fed7345c |
170 | |
070ed461 |
171 | If a system error prevents a directory from being created, then the |
99c4c5e8 |
172 | C<mkpath> function throws a fatal error with C<Carp::croak>. This error |
173 | can be trapped with an C<eval> block: |
070ed461 |
174 | |
175 | eval { mkpath($dir) }; |
176 | if ($@) { |
177 | print "Couldn't create $dir: $@"; |
178 | } |
179 | |
12c2e016 |
180 | In the traditional form, C<rmtree> takes three arguments: |
fed7345c |
181 | |
182 | =over 4 |
183 | |
184 | =item * |
185 | |
186 | the root of the subtree to delete, or a reference to |
187 | a list of roots. All of the files and directories |
188 | below each root, as well as the roots themselves, |
567d72c2 |
189 | will be deleted. |
fed7345c |
190 | |
191 | =item * |
192 | |
193 | a boolean value, which if TRUE will cause C<rmtree> to |
748a9306 |
194 | print a message each time it examines a file, giving the |
195 | name of the file, and indicating whether it's using C<rmdir> |
196 | or C<unlink> to remove it, or that it's skipping it. |
fed7345c |
197 | (defaults to FALSE) |
198 | |
199 | =item * |
200 | |
201 | a boolean value, which if TRUE will cause C<rmtree> to |
748a9306 |
202 | skip any files to which you do not have delete access |
203 | (if running under VMS) or write access (if running |
204 | under another OS). This will change in the future when |
205 | a criterion for 'delete permission' under OSs other |
96e4d5b1 |
206 | than VMS is settled. (defaults to FALSE) |
fed7345c |
207 | |
208 | =back |
209 | |
cc61921f |
210 | It returns the number of files, directories and symlinks successfully |
211 | deleted. Symlinks are simply deleted and not followed. |
fed7345c |
212 | |
12c2e016 |
213 | Note also that the occurrence of errors in C<rmtree> using the |
214 | traditional interface can be determined I<only> by trapping diagnostic |
215 | messages using C<$SIG{__WARN__}>; it is not apparent from the return |
216 | value. (The modern interface may use the C<error> parameter to |
217 | record any problems encountered. |
218 | |
219 | =head2 ERROR HANDLING |
220 | |
221 | If C<mkpath> or C<rmtree> encounter an error, a diagnostic message |
222 | will be printed to C<STDERR> via C<carp> (for non-fatal errors), |
223 | or via C<croak> (for fatal errors). |
224 | |
225 | If this behaviour is not desirable, the C<error> attribute may be |
226 | used to hold a reference to a variable, which will be used to store |
227 | the diagnostics. The result is a reference to a list of hash |
228 | references. For each hash reference, the key is the name of the |
229 | file, and the value is the error message (usually the contents of |
230 | C<$!>). An example usage looks like: |
231 | |
232 | rmpath( 'foo/bar', 'bar/rat', {error => \my $err} ); |
233 | for my $diag (@$err) { |
234 | my ($file, $message) = each %$diag; |
235 | print "problem unlinking $file: $message\n"; |
236 | } |
237 | |
238 | If no errors are encountered, C<$err> will point to an empty list |
239 | (thus there is no need to test for C<undef>). If a general error |
240 | is encountered (for instance, C<rmtree> attempts to remove a directory |
241 | tree that does not exist), the diagnostic key will be empty, only |
242 | the value will be set: |
243 | |
244 | rmpath( '/no/such/path', {error => \my $err} ); |
245 | for my $diag (@$err) { |
246 | my ($file, $message) = each %$diag; |
247 | if ($file eq '') { |
248 | print "general error: $message\n"; |
249 | } |
250 | } |
251 | |
252 | =head2 NOTES |
253 | |
254 | =head3 HEURISTICS |
255 | |
256 | The functions detect (as far as possible) which way they are being |
257 | called and will act appropriately. It is important to remember that |
258 | the heuristic for detecting the old style is either the presence |
259 | of an array reference, or two or three parameters total and second |
260 | and third parameters are numeric. Hence... |
261 | |
262 | mkpath '486', '487', '488'; |
263 | |
264 | ... will not assume the modern style and create three directories, rather |
265 | it will create one directory verbosely, setting the permission to |
266 | 0750 (488 being the decimal equivalent of octal 750). Here, old |
267 | style trumps new. It must, for backwards compatibility reasons. |
e2ba98a1 |
268 | |
12c2e016 |
269 | If you want to ensure there is absolutely no ambiguity about which |
270 | way the function will behave, make sure the first parameter is a |
271 | reference to a one-element list, to force the old style interpretation: |
e2ba98a1 |
272 | |
12c2e016 |
273 | mkpath ['486'], '487', '488'; |
274 | |
275 | and get only one directory created. Or add a reference to an empty |
276 | parameter hash, to force the new style: |
277 | |
278 | mkpath '486', '487', '488', {}; |
279 | |
280 | ... and hence create the three directories. If the empty hash |
281 | reference seems a little strange to your eyes, or you suspect a |
282 | subsequent programmer might I<helpfully> optimise it away, you |
283 | can add a parameter set to a default value: |
284 | |
285 | mkpath '486', '487', '488', {verbose => 0}; |
286 | |
287 | =head3 RACE CONDITIONS |
288 | |
289 | There are race conditions internal to the implementation of C<rmtree> |
290 | making it unsafe to use on directory trees which may be altered or |
291 | moved while C<rmtree> is running, and in particular on any directory |
292 | trees with any path components or subdirectories potentially writable |
293 | by untrusted users. |
294 | |
295 | Additionally, if the C<skip_others> parareter is not set (or the |
296 | third parameter in the traditional inferface is not TRUE) and |
297 | C<rmtree> is interrupted, it may leave files and directories with |
298 | permissions altered to allow deletion. |
299 | |
300 | C<File::Path> blindly exports C<mkpath> and C<rmtree> into the |
301 | current namespace. These days, this is considered bad style, but |
302 | to change it now would break too much code. Nonetheless, you are |
303 | invited to specify what it is you are expecting to use: |
304 | |
305 | use File::Path 'rmtree'; |
96e4d5b1 |
306 | |
b8d5f521 |
307 | =head1 DIAGNOSTICS |
308 | |
309 | =over 4 |
310 | |
311 | =item * |
312 | |
313 | On Windows, if C<mkpath> gives you the warning: B<No such file or |
314 | directory>, this may mean that you've exceeded your filesystem's |
315 | maximum path length. |
316 | |
317 | =back |
318 | |
12c2e016 |
319 | =head1 SEE ALSO |
320 | |
321 | =over 4 |
322 | |
323 | =item * |
324 | |
325 | L<Find::File::Rule> |
326 | |
327 | When removing directory trees, if you want to examine each file |
328 | before deciding whether to deleting it (and possibly leaving large |
329 | swathes alone), F<File::Find::Rule> offers a convenient and flexible |
330 | approach. |
331 | |
332 | =back |
333 | |
334 | =head1 BUGS |
335 | |
336 | Please report all bugs on the RT queue: |
337 | |
338 | L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path> |
339 | |
fed7345c |
340 | =head1 AUTHORS |
341 | |
96e4d5b1 |
342 | Tim Bunce <F<Tim.Bunce@ig.co.uk>> and |
12c2e016 |
343 | Charles Bailey <F<bailey@newman.upenn.edu>>. |
344 | |
345 | Currently maintained by David Landgren <F<david@landgren.net>>. |
346 | |
347 | =head1 COPYRIGHT |
348 | |
349 | This module is copyright (C) Charles Bailey, Tim Bunce and |
350 | David Landgren 1995-2007. All rights reserved. |
351 | |
352 | =head1 LICENSE |
353 | |
354 | This library is free software; you can redistribute it and/or modify |
355 | it under the same terms as Perl itself. |
fed7345c |
356 | |
fed7345c |
357 | =cut |
358 | |
12c2e016 |
359 | use 5.005_04; |
037c8c09 |
360 | use strict; |
68dc0745 |
361 | |
12c2e016 |
362 | use File::Basename (); |
363 | use File::Spec (); |
364 | BEGIN { |
365 | if ($] >= 5.006) { |
366 | eval "use warnings"; |
367 | } |
368 | else { |
369 | # can't say 'opendir my $dh, $dirname' |
370 | # need to initialise $dh |
371 | eval "use Symbol"; |
372 | } |
373 | } |
374 | |
375 | use Exporter (); |
376 | use vars qw($VERSION @ISA @EXPORT); |
377 | $VERSION = '2.00'; |
378 | @ISA = qw(Exporter); |
379 | @EXPORT = qw(mkpath rmtree); |
fed7345c |
380 | |
68dc0745 |
381 | my $Is_VMS = $^O eq 'VMS'; |
ffb9ee5f |
382 | my $Is_MacOS = $^O eq 'MacOS'; |
037c8c09 |
383 | |
384 | # These OSes complain if you want to remove a file that you have no |
385 | # write permission to: |
12c2e016 |
386 | my $Force_Writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' || |
fa6a1c44 |
387 | $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc'); |
748a9306 |
388 | |
12c2e016 |
389 | sub _carp { |
8878f897 |
390 | require Carp; |
391 | goto &Carp::carp; |
392 | } |
393 | |
12c2e016 |
394 | sub _croak { |
8878f897 |
395 | require Carp; |
396 | goto &Carp::croak; |
397 | } |
398 | |
a5f75d66 |
399 | sub mkpath { |
12c2e016 |
400 | my $new_style = ( |
401 | ref($_[0]) eq 'ARRAY' |
402 | or (@_ == 2 and $_[1] =~ /\A\d+\z/) |
403 | or (@_ == 3 and $_[1] =~ /\A\d+\z/ and $_[2] =~ /\A\d+\z/) |
404 | ) ? 0 : 1; |
405 | |
406 | my $arg; |
407 | my $paths; |
408 | |
409 | if ($new_style) { |
410 | if (ref $_[-1] eq 'HASH') { |
411 | $arg = pop @_; |
412 | exists $arg->{mask} and $arg->{mode} = delete $arg->{mask}; |
413 | $arg->{mode} = 0777 unless exists $arg->{mode}; |
414 | ${$arg->{error}} = [] if exists $arg->{error}; |
415 | } |
416 | else { |
417 | @{$arg}{qw(verbose mode)} = (0, 0777); |
418 | } |
419 | $paths = [@_]; |
420 | } |
421 | else { |
422 | my ($verbose, $mode); |
423 | ($paths, $verbose, $mode) = @_; |
424 | $paths = [$paths] unless ref($paths) eq 'ARRAY'; |
425 | $arg->{verbose} = defined $verbose ? $verbose : 0; |
426 | $arg->{mode} = defined $mode ? $mode : 0777; |
427 | } |
428 | return _mkpath($arg, $paths); |
429 | } |
430 | |
431 | sub _mkpath { |
432 | my $arg = shift; |
433 | my $paths = shift; |
434 | |
ffb9ee5f |
435 | local($")=$Is_MacOS ? ":" : "/"; |
037c8c09 |
436 | my(@created,$path); |
68dc0745 |
437 | foreach $path (@$paths) { |
12c2e016 |
438 | next unless length($path); |
1b1e14d3 |
439 | $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT |
037c8c09 |
440 | # Logic wants Unix paths, so go with the flow. |
e3830a4e |
441 | if ($Is_VMS) { |
442 | next if $path eq '/'; |
443 | $path = VMS::Filespec::unixify($path); |
491527d0 |
444 | } |
e3830a4e |
445 | next if -d $path; |
446 | my $parent = File::Basename::dirname($path); |
447 | unless (-d $parent or $path eq $parent) { |
12c2e016 |
448 | push(@created,_mkpath($arg, [$parent])); |
449 | } |
450 | print "mkdir $path\n" if $arg->{verbose}; |
451 | if (mkdir($path,$arg->{mode})) { |
452 | push(@created, $path); |
dde45d8e |
453 | } |
12c2e016 |
454 | else { |
455 | my $save_bang = $!; |
456 | my ($e, $e1) = ($save_bang, $^E); |
dde45d8e |
457 | $e .= "; $e1" if $e ne $e1; |
c3420933 |
458 | # allow for another process to have created it meanwhile |
12c2e016 |
459 | if (!-d $path) { |
460 | $! = $save_bang; |
461 | if ($arg->{error}) { |
462 | push @{${$arg->{error}}}, {$path => $e}; |
463 | } |
464 | else { |
465 | _croak("mkdir $path: $e"); |
466 | } |
67e4c828 |
467 | } |
fed7345c |
468 | } |
12c2e016 |
469 | } |
470 | return @created; |
fed7345c |
471 | } |
472 | |
473 | sub rmtree { |
12c2e016 |
474 | my $new_style = ( |
475 | ref($_[0]) eq 'ARRAY' |
476 | or (@_ == 2 and $_[1] =~ /\A\d+\z/) |
477 | or (@_ == 3 and $_[1] =~ /\A\d+\z/ and $_[2] =~ /\A\d+\z/) |
478 | ) ? 0 : 1; |
479 | |
480 | my $arg; |
481 | my $paths; |
482 | |
483 | if ($new_style) { |
484 | if (ref $_[-1] eq 'HASH') { |
485 | $arg = pop @_; |
486 | ${$arg->{error}} = [] if exists $arg->{error}; |
487 | ${$arg->{result}} = [] if exists $arg->{result}; |
488 | } |
489 | else { |
490 | @{$arg}{qw(verbose safe)} = (0, 0); |
491 | } |
492 | $arg->{depth} = 0; |
493 | $paths = [@_]; |
494 | } |
495 | else { |
496 | my ($verbose, $safe); |
497 | ($paths, $verbose, $safe) = @_; |
498 | $paths = [$paths] unless ref($paths) eq 'ARRAY'; |
499 | $arg->{verbose} = defined $verbose ? $verbose : 0; |
500 | $arg->{safe} = defined $safe ? $safe : 0; |
501 | } |
fed7345c |
502 | |
12c2e016 |
503 | if (@$paths < 1) { |
504 | if ($arg->{error}) { |
505 | push @{${$arg->{error}}}, {'' => "No root path(s) specified"}; |
ee79a11f |
506 | } |
507 | else { |
12c2e016 |
508 | _carp ("No root path(s) specified\n"); |
509 | } |
ee79a11f |
510 | return 0; |
511 | } |
12c2e016 |
512 | return _rmtree($arg, $paths); |
513 | } |
ee79a11f |
514 | |
12c2e016 |
515 | sub _rmtree { |
516 | my $arg = shift; |
517 | my $paths = shift; |
518 | my($count) = 0; |
519 | my (@files, $root); |
520 | foreach $root (@{$paths}) { |
ffb9ee5f |
521 | if ($Is_MacOS) { |
522 | $root = ":$root" if $root !~ /:/; |
12c2e016 |
523 | $root =~ s/([^:])\z/$1:/; |
524 | } |
525 | else { |
ffb9ee5f |
526 | $root =~ s#/\z##; |
527 | } |
12c2e016 |
528 | my $rp = (lstat $root)[2] or next; |
7025f710 |
529 | $rp &= 07777; # don't forget setuid, setgid, sticky bits |
530 | if ( -d _ ) { |
e2ba98a1 |
531 | # notabene: 0700 is for making readable in the first place, |
037c8c09 |
532 | # it's also intended to change it to writable in case we have |
533 | # to recurse in which case we are better than rm -rf for |
534 | # subtrees with strange permissions |
12c2e016 |
535 | if (!chmod($rp | 0700, |
536 | ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) |
537 | ) { |
538 | if (!$arg->{safe}) { |
539 | if ($arg->{error}) { |
540 | push @{${$arg->{error}}}, |
541 | {$root => "Can't make directory read+writeable: $!"}; |
542 | } |
543 | else { |
544 | _carp ("Can't make directory $root read+writeable: $!"); |
545 | } |
546 | } |
547 | } |
548 | |
549 | my $d; |
550 | $d = gensym() if $] < 5.006; |
551 | if (!opendir $d, $root) { |
552 | if ($arg->{error}) { |
553 | push @{${$arg->{error}}}, {$root => "opendir: $!"}; |
554 | } |
555 | else { |
556 | _carp ("Can't read $root: $!"); |
557 | } |
558 | @files = (); |
559 | } |
560 | else { |
7068481f |
561 | no strict 'refs'; |
562 | if (!defined ${"\cTAINT"} or ${"\cTAINT"}) { |
12c2e016 |
563 | # Blindly untaint dir names if taint mode is |
564 | # active, or any perl < 5.006 |
565 | @files = map { /\A(.*)\z/s; $1 } readdir $d; |
566 | } |
567 | else { |
7068481f |
568 | @files = readdir $d; |
569 | } |
ff21075d |
570 | closedir $d; |
571 | } |
037c8c09 |
572 | |
573 | # Deleting large numbers of files from VMS Files-11 filesystems |
574 | # is faster if done in reverse ASCIIbetical order |
575 | @files = reverse @files if $Is_VMS; |
1b1e14d3 |
576 | ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS; |
ffb9ee5f |
577 | if ($Is_MacOS) { |
578 | @files = map("$root$_", @files); |
ffb9ee5f |
579 | } |
12c2e016 |
580 | else { |
581 | my $updir = File::Spec->updir(); |
582 | my $curdir = File::Spec->curdir(); |
bfbf02a1 |
583 | @files = map(File::Spec->catfile($root,$_), |
12c2e016 |
584 | grep {$_ ne $updir and $_ ne $curdir} |
585 | @files |
586 | ); |
587 | } |
588 | $arg->{depth}++; |
589 | $count += _rmtree($arg, \@files); |
590 | $arg->{depth}--; |
591 | if ($arg->{depth} or !$arg->{keep_root}) { |
592 | if ($arg->{safe} && |
037c8c09 |
593 | ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { |
12c2e016 |
594 | print "skipped $root\n" if $arg->{verbose}; |
037c8c09 |
595 | next; |
596 | } |
12c2e016 |
597 | if (!chmod $rp | 0700, $root) { |
598 | if ($Force_Writeable) { |
599 | if ($arg->{error}) { |
600 | push @{${$arg->{error}}}, |
601 | {$root => "Can't make directory writeable: $!"}; |
602 | } |
603 | else { |
604 | _carp ("Can't make directory $root writeable: $!") |
605 | } |
606 | } |
607 | } |
608 | print "rmdir $root\n" if $arg->{verbose}; |
96e4d5b1 |
609 | if (rmdir $root) { |
12c2e016 |
610 | push @{${$arg->{result}}}, $root if $arg->{result}; |
96e4d5b1 |
611 | ++$count; |
612 | } |
613 | else { |
12c2e016 |
614 | if ($arg->{error}) { |
615 | push @{${$arg->{error}}}, {$root => "rmdir: $!"}; |
616 | } |
617 | else { |
618 | _carp ("Can't remove directory $root: $!"); |
96e4d5b1 |
619 | } |
12c2e016 |
620 | if (!chmod($rp, |
621 | ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) |
622 | ) { |
623 | my $mask = sprintf("0%o",$rp); |
624 | if ($arg->{error}) { |
625 | push @{${$arg->{error}}}, {$root => "restore chmod: $!"}; |
037c8c09 |
626 | } |
627 | else { |
12c2e016 |
628 | _carp("and can't restore permissions to $mask\n"); |
629 | } |
630 | } |
631 | } |
632 | } |
633 | } |
634 | else { |
635 | if ($arg->{safe} && |
64f6ddac |
636 | ($Is_VMS ? !&VMS::Filespec::candelete($root) |
637 | : !(-l $root || -w $root))) |
638 | { |
12c2e016 |
639 | print "skipped $root\n" if $arg->{verbose}; |
037c8c09 |
640 | next; |
641 | } |
12c2e016 |
642 | if (!chmod $rp | 0600, $root) { |
643 | if ($Force_Writeable) { |
644 | if ($arg->{error}) { |
645 | push @{${$arg->{error}}}, |
646 | {$root => "Can't make file writeable: $!"}; |
647 | } |
648 | else { |
649 | _carp ("Can't make file $root writeable: $!") |
650 | } |
651 | } |
652 | } |
653 | print "unlink $root\n" if $arg->{verbose}; |
037c8c09 |
654 | # delete all versions under VMS |
94d4f21c |
655 | for (;;) { |
12c2e016 |
656 | if (unlink $root) { |
657 | push @{${$arg->{result}}}, $root if $arg->{result}; |
658 | } |
659 | else { |
660 | if ($arg->{error}) { |
661 | push @{${$arg->{error}}}, |
662 | {$root => "unlink: $!"}; |
663 | } |
664 | else { |
665 | _carp ("Can't unlink file $root: $!"); |
666 | } |
667 | if ($Force_Writeable) { |
668 | if (!chmod $rp, $root) { |
669 | my $mask = sprintf("0%o",$rp); |
670 | if ($arg->{error}) { |
671 | push @{${$arg->{error}}}, {$root => "restore chmod: $!"}; |
672 | } |
673 | else { |
674 | _carp("and can't restore permissions to $mask\n"); |
675 | } |
676 | } |
96e4d5b1 |
677 | } |
94d4f21c |
678 | last; |
96e4d5b1 |
679 | } |
94d4f21c |
680 | ++$count; |
681 | last unless $Is_VMS && lstat $root; |
037c8c09 |
682 | } |
683 | } |
fed7345c |
684 | } |
685 | |
12c2e016 |
686 | return $count; |
fed7345c |
687 | } |
688 | |
689 | 1; |