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