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 | |
3376a30f |
9 | This document describes version 2.00_02 of File::Path, released |
10 | 2007-06-06. |
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', |
91c4f65e |
21 | { verbose => 1, error => \my $err_list } |
12c2e016 |
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 | |
d78e0c3b |
295 | Additionally, if the C<skip_others> parameter is not set (or the |
12c2e016 |
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 { |
91c4f65e |
365 | if ($] < 5.006) { |
12c2e016 |
366 | # can't say 'opendir my $dh, $dirname' |
367 | # need to initialise $dh |
368 | eval "use Symbol"; |
369 | } |
370 | } |
371 | |
372 | use Exporter (); |
373 | use vars qw($VERSION @ISA @EXPORT); |
3376a30f |
374 | $VERSION = '2.00_02'; |
12c2e016 |
375 | @ISA = qw(Exporter); |
376 | @EXPORT = qw(mkpath rmtree); |
fed7345c |
377 | |
68dc0745 |
378 | my $Is_VMS = $^O eq 'VMS'; |
ffb9ee5f |
379 | my $Is_MacOS = $^O eq 'MacOS'; |
037c8c09 |
380 | |
381 | # These OSes complain if you want to remove a file that you have no |
382 | # write permission to: |
12c2e016 |
383 | my $Force_Writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' || |
fa6a1c44 |
384 | $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc'); |
748a9306 |
385 | |
12c2e016 |
386 | sub _carp { |
8878f897 |
387 | require Carp; |
388 | goto &Carp::carp; |
389 | } |
390 | |
12c2e016 |
391 | sub _croak { |
8878f897 |
392 | require Carp; |
393 | goto &Carp::croak; |
394 | } |
395 | |
a5f75d66 |
396 | sub mkpath { |
12c2e016 |
397 | my $new_style = ( |
3376a30f |
398 | UNIVERSAL::isa($_[0],'ARRAY') |
12c2e016 |
399 | or (@_ == 2 and $_[1] =~ /\A\d+\z/) |
400 | or (@_ == 3 and $_[1] =~ /\A\d+\z/ and $_[2] =~ /\A\d+\z/) |
401 | ) ? 0 : 1; |
402 | |
403 | my $arg; |
404 | my $paths; |
405 | |
406 | if ($new_style) { |
3376a30f |
407 | if (@_ > 0 and UNIVERSAL::isa($_[-1], 'HASH')) { |
12c2e016 |
408 | $arg = pop @_; |
409 | exists $arg->{mask} and $arg->{mode} = delete $arg->{mask}; |
410 | $arg->{mode} = 0777 unless exists $arg->{mode}; |
411 | ${$arg->{error}} = [] if exists $arg->{error}; |
412 | } |
413 | else { |
414 | @{$arg}{qw(verbose mode)} = (0, 0777); |
415 | } |
416 | $paths = [@_]; |
417 | } |
418 | else { |
419 | my ($verbose, $mode); |
420 | ($paths, $verbose, $mode) = @_; |
3376a30f |
421 | $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY'); |
12c2e016 |
422 | $arg->{verbose} = defined $verbose ? $verbose : 0; |
423 | $arg->{mode} = defined $mode ? $mode : 0777; |
424 | } |
425 | return _mkpath($arg, $paths); |
426 | } |
427 | |
428 | sub _mkpath { |
429 | my $arg = shift; |
430 | my $paths = shift; |
431 | |
ffb9ee5f |
432 | local($")=$Is_MacOS ? ":" : "/"; |
037c8c09 |
433 | my(@created,$path); |
68dc0745 |
434 | foreach $path (@$paths) { |
12c2e016 |
435 | next unless length($path); |
1b1e14d3 |
436 | $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT |
037c8c09 |
437 | # Logic wants Unix paths, so go with the flow. |
e3830a4e |
438 | if ($Is_VMS) { |
439 | next if $path eq '/'; |
440 | $path = VMS::Filespec::unixify($path); |
491527d0 |
441 | } |
e3830a4e |
442 | next if -d $path; |
443 | my $parent = File::Basename::dirname($path); |
444 | unless (-d $parent or $path eq $parent) { |
12c2e016 |
445 | push(@created,_mkpath($arg, [$parent])); |
446 | } |
447 | print "mkdir $path\n" if $arg->{verbose}; |
448 | if (mkdir($path,$arg->{mode})) { |
449 | push(@created, $path); |
dde45d8e |
450 | } |
12c2e016 |
451 | else { |
452 | my $save_bang = $!; |
453 | my ($e, $e1) = ($save_bang, $^E); |
dde45d8e |
454 | $e .= "; $e1" if $e ne $e1; |
c3420933 |
455 | # allow for another process to have created it meanwhile |
12c2e016 |
456 | if (!-d $path) { |
457 | $! = $save_bang; |
458 | if ($arg->{error}) { |
459 | push @{${$arg->{error}}}, {$path => $e}; |
460 | } |
461 | else { |
462 | _croak("mkdir $path: $e"); |
463 | } |
67e4c828 |
464 | } |
fed7345c |
465 | } |
12c2e016 |
466 | } |
467 | return @created; |
fed7345c |
468 | } |
469 | |
470 | sub rmtree { |
12c2e016 |
471 | my $new_style = ( |
3376a30f |
472 | UNIVERSAL::isa($_[0],'ARRAY') |
12c2e016 |
473 | or (@_ == 2 and $_[1] =~ /\A\d+\z/) |
474 | or (@_ == 3 and $_[1] =~ /\A\d+\z/ and $_[2] =~ /\A\d+\z/) |
475 | ) ? 0 : 1; |
476 | |
477 | my $arg; |
478 | my $paths; |
479 | |
480 | if ($new_style) { |
3376a30f |
481 | if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH')) { |
12c2e016 |
482 | $arg = pop @_; |
483 | ${$arg->{error}} = [] if exists $arg->{error}; |
484 | ${$arg->{result}} = [] if exists $arg->{result}; |
485 | } |
486 | else { |
487 | @{$arg}{qw(verbose safe)} = (0, 0); |
488 | } |
489 | $arg->{depth} = 0; |
490 | $paths = [@_]; |
491 | } |
492 | else { |
493 | my ($verbose, $safe); |
494 | ($paths, $verbose, $safe) = @_; |
12c2e016 |
495 | $arg->{verbose} = defined $verbose ? $verbose : 0; |
496 | $arg->{safe} = defined $safe ? $safe : 0; |
fed7345c |
497 | |
3376a30f |
498 | if (defined($paths) and length($paths)) { |
499 | $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY'); |
500 | } |
501 | else { |
12c2e016 |
502 | if ($arg->{error}) { |
503 | push @{${$arg->{error}}}, {'' => "No root path(s) specified"}; |
ee79a11f |
504 | } |
505 | else { |
3376a30f |
506 | _carp ("No root path(s) specified\n"); |
12c2e016 |
507 | } |
ee79a11f |
508 | return 0; |
509 | } |
3376a30f |
510 | } |
12c2e016 |
511 | return _rmtree($arg, $paths); |
512 | } |
ee79a11f |
513 | |
12c2e016 |
514 | sub _rmtree { |
515 | my $arg = shift; |
516 | my $paths = shift; |
517 | my($count) = 0; |
518 | my (@files, $root); |
519 | foreach $root (@{$paths}) { |
ffb9ee5f |
520 | if ($Is_MacOS) { |
521 | $root = ":$root" if $root !~ /:/; |
12c2e016 |
522 | $root =~ s/([^:])\z/$1:/; |
523 | } |
524 | else { |
ffb9ee5f |
525 | $root =~ s#/\z##; |
526 | } |
12c2e016 |
527 | my $rp = (lstat $root)[2] or next; |
7025f710 |
528 | $rp &= 07777; # don't forget setuid, setgid, sticky bits |
529 | if ( -d _ ) { |
e2ba98a1 |
530 | # notabene: 0700 is for making readable in the first place, |
037c8c09 |
531 | # it's also intended to change it to writable in case we have |
532 | # to recurse in which case we are better than rm -rf for |
533 | # subtrees with strange permissions |
12c2e016 |
534 | if (!chmod($rp | 0700, |
535 | ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) |
536 | ) { |
537 | if (!$arg->{safe}) { |
538 | if ($arg->{error}) { |
539 | push @{${$arg->{error}}}, |
540 | {$root => "Can't make directory read+writeable: $!"}; |
541 | } |
542 | else { |
543 | _carp ("Can't make directory $root read+writeable: $!"); |
544 | } |
545 | } |
546 | } |
547 | |
548 | my $d; |
549 | $d = gensym() if $] < 5.006; |
550 | if (!opendir $d, $root) { |
551 | if ($arg->{error}) { |
552 | push @{${$arg->{error}}}, {$root => "opendir: $!"}; |
553 | } |
554 | else { |
555 | _carp ("Can't read $root: $!"); |
556 | } |
557 | @files = (); |
558 | } |
559 | else { |
7068481f |
560 | no strict 'refs'; |
561 | if (!defined ${"\cTAINT"} or ${"\cTAINT"}) { |
12c2e016 |
562 | # Blindly untaint dir names if taint mode is |
563 | # active, or any perl < 5.006 |
564 | @files = map { /\A(.*)\z/s; $1 } readdir $d; |
565 | } |
566 | else { |
7068481f |
567 | @files = readdir $d; |
568 | } |
ff21075d |
569 | closedir $d; |
570 | } |
037c8c09 |
571 | |
572 | # Deleting large numbers of files from VMS Files-11 filesystems |
573 | # is faster if done in reverse ASCIIbetical order |
574 | @files = reverse @files if $Is_VMS; |
1b1e14d3 |
575 | ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS; |
ffb9ee5f |
576 | if ($Is_MacOS) { |
577 | @files = map("$root$_", @files); |
ffb9ee5f |
578 | } |
12c2e016 |
579 | else { |
580 | my $updir = File::Spec->updir(); |
581 | my $curdir = File::Spec->curdir(); |
bfbf02a1 |
582 | @files = map(File::Spec->catfile($root,$_), |
12c2e016 |
583 | grep {$_ ne $updir and $_ ne $curdir} |
584 | @files |
585 | ); |
586 | } |
587 | $arg->{depth}++; |
588 | $count += _rmtree($arg, \@files); |
589 | $arg->{depth}--; |
590 | if ($arg->{depth} or !$arg->{keep_root}) { |
591 | if ($arg->{safe} && |
037c8c09 |
592 | ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { |
12c2e016 |
593 | print "skipped $root\n" if $arg->{verbose}; |
037c8c09 |
594 | next; |
595 | } |
12c2e016 |
596 | if (!chmod $rp | 0700, $root) { |
597 | if ($Force_Writeable) { |
598 | if ($arg->{error}) { |
599 | push @{${$arg->{error}}}, |
600 | {$root => "Can't make directory writeable: $!"}; |
601 | } |
602 | else { |
603 | _carp ("Can't make directory $root writeable: $!") |
604 | } |
605 | } |
606 | } |
607 | print "rmdir $root\n" if $arg->{verbose}; |
96e4d5b1 |
608 | if (rmdir $root) { |
12c2e016 |
609 | push @{${$arg->{result}}}, $root if $arg->{result}; |
96e4d5b1 |
610 | ++$count; |
611 | } |
612 | else { |
12c2e016 |
613 | if ($arg->{error}) { |
614 | push @{${$arg->{error}}}, {$root => "rmdir: $!"}; |
615 | } |
616 | else { |
617 | _carp ("Can't remove directory $root: $!"); |
96e4d5b1 |
618 | } |
12c2e016 |
619 | if (!chmod($rp, |
620 | ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) |
621 | ) { |
622 | my $mask = sprintf("0%o",$rp); |
623 | if ($arg->{error}) { |
624 | push @{${$arg->{error}}}, {$root => "restore chmod: $!"}; |
037c8c09 |
625 | } |
626 | else { |
12c2e016 |
627 | _carp("and can't restore permissions to $mask\n"); |
628 | } |
629 | } |
630 | } |
631 | } |
632 | } |
633 | else { |
634 | if ($arg->{safe} && |
64f6ddac |
635 | ($Is_VMS ? !&VMS::Filespec::candelete($root) |
636 | : !(-l $root || -w $root))) |
637 | { |
12c2e016 |
638 | print "skipped $root\n" if $arg->{verbose}; |
037c8c09 |
639 | next; |
640 | } |
12c2e016 |
641 | if (!chmod $rp | 0600, $root) { |
642 | if ($Force_Writeable) { |
643 | if ($arg->{error}) { |
644 | push @{${$arg->{error}}}, |
645 | {$root => "Can't make file writeable: $!"}; |
646 | } |
647 | else { |
648 | _carp ("Can't make file $root writeable: $!") |
649 | } |
650 | } |
651 | } |
652 | print "unlink $root\n" if $arg->{verbose}; |
037c8c09 |
653 | # delete all versions under VMS |
94d4f21c |
654 | for (;;) { |
12c2e016 |
655 | if (unlink $root) { |
656 | push @{${$arg->{result}}}, $root if $arg->{result}; |
657 | } |
658 | else { |
659 | if ($arg->{error}) { |
660 | push @{${$arg->{error}}}, |
661 | {$root => "unlink: $!"}; |
662 | } |
663 | else { |
664 | _carp ("Can't unlink file $root: $!"); |
665 | } |
666 | if ($Force_Writeable) { |
667 | if (!chmod $rp, $root) { |
668 | my $mask = sprintf("0%o",$rp); |
669 | if ($arg->{error}) { |
670 | push @{${$arg->{error}}}, {$root => "restore chmod: $!"}; |
671 | } |
672 | else { |
673 | _carp("and can't restore permissions to $mask\n"); |
674 | } |
675 | } |
96e4d5b1 |
676 | } |
94d4f21c |
677 | last; |
96e4d5b1 |
678 | } |
94d4f21c |
679 | ++$count; |
680 | last unless $Is_VMS && lstat $root; |
037c8c09 |
681 | } |
682 | } |
fed7345c |
683 | } |
684 | |
12c2e016 |
685 | return $count; |
fed7345c |
686 | } |
687 | |
688 | 1; |