package File::Path;
-=head1 NAME
+use 5.005_04;
+use strict;
-File::Path - Create or remove directory trees
+use Cwd 'getcwd';
+use File::Basename ();
+use File::Spec ();
-=head1 VERSION
+BEGIN {
+ if ($] < 5.006) {
+ # can't say 'opendir my $dh, $dirname'
+ # need to initialise $dh
+ eval "use Symbol";
+ }
+}
-This document describes version 2.00_11 of File::Path, released
-2007-09-08.
+use Exporter ();
+use vars qw($VERSION @ISA @EXPORT);
+$VERSION = '2.02';
+@ISA = qw(Exporter);
+@EXPORT = qw(mkpath rmtree);
-=head1 SYNOPSIS
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MacOS = $^O eq 'MacOS';
- use File::Path;
+# These OSes complain if you want to remove a file that you have no
+# write permission to:
+my $Force_Writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' ||
+ $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc');
- # modern
- mkpath( 'foo/bar/baz', '/zug/zwang', {verbose => 1} );
+sub _carp {
+ require Carp;
+ goto &Carp::carp;
+}
- rmtree(
- 'foo/bar/baz', '/zug/zwang',
- { verbose => 1, error => \my $err_list }
- );
+sub _croak {
+ require Carp;
+ goto &Carp::croak;
+}
- # traditional
- mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
- rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
+sub _error {
+ my $arg = shift;
+ my $message = shift;
+ my $object = shift;
-=head1 DESCRIPTION
+ if ($arg->{error}) {
+ $object = '' unless defined $object;
+ push @{${$arg->{error}}}, {$object => "$message: $!"};
+ }
+ else {
+ _carp(defined($object) ? "$message for $object: $!" : "$message: $!");
+ }
+}
-The C<mkpath> function provides a convenient way to create directories
-of arbitrary depth. Similarly, the C<rmtree> function provides a
-convenient way to delete an entire directory subtree from the
-filesystem, much like the Unix command C<rm -r>.
+sub mkpath {
+ my $old_style = (
+ UNIVERSAL::isa($_[0],'ARRAY')
+ or (@_ == 2 and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1))
+ or (@_ == 3
+ and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1)
+ and (defined $_[2] ? $_[2] =~ /\A\d+\z/ : 1)
+ )
+ ) ? 1 : 0;
-Both functions may be called in one of two ways, the traditional,
-compatible with code written since the dawn of time, and modern,
-that offers a more flexible and readable idiom. New code should use
-the modern interface.
+ my $arg;
+ my $paths;
-=head2 FUNCTIONS
+ if ($old_style) {
+ my ($verbose, $mode);
+ ($paths, $verbose, $mode) = @_;
+ $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY');
+ $arg->{verbose} = defined $verbose ? $verbose : 0;
+ $arg->{mode} = defined $mode ? $mode : 0777;
+ }
+ else {
+ if (@_ > 0 and UNIVERSAL::isa($_[-1], 'HASH')) {
+ $arg = pop @_;
+ exists $arg->{mask} and $arg->{mode} = delete $arg->{mask};
+ $arg->{mode} = 0777 unless exists $arg->{mode};
+ ${$arg->{error}} = [] if exists $arg->{error};
+ }
+ else {
+ @{$arg}{qw(verbose mode)} = (0, 0777);
+ }
+ $paths = [@_];
+ }
+ return _mkpath($arg, $paths);
+}
-The modern way of calling C<mkpath> and C<rmtree> is with a list
-of directories to create, or remove, respectively, followed by an
-optional hash reference containing keys to control the
-function's behaviour.
+sub _mkpath {
+ my $arg = shift;
+ my $paths = shift;
-=head3 C<mkpath>
+ local($")=$Is_MacOS ? ":" : "/";
+ my(@created,$path);
+ foreach $path (@$paths) {
+ next unless length($path);
+ $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT
+ # Logic wants Unix paths, so go with the flow.
+ if ($Is_VMS) {
+ next if $path eq '/';
+ $path = VMS::Filespec::unixify($path);
+ }
+ next if -d $path;
+ my $parent = File::Basename::dirname($path);
+ unless (-d $parent or $path eq $parent) {
+ push(@created,_mkpath($arg, [$parent]));
+ }
+ print "mkdir $path\n" if $arg->{verbose};
+ if (mkdir($path,$arg->{mode})) {
+ push(@created, $path);
+ }
+ else {
+ my $save_bang = $!;
+ my ($e, $e1) = ($save_bang, $^E);
+ $e .= "; $e1" if $e ne $e1;
+ # allow for another process to have created it meanwhile
+ if (!-d $path) {
+ $! = $save_bang;
+ if ($arg->{error}) {
+ push @{${$arg->{error}}}, {$path => $e};
+ }
+ else {
+ _croak("mkdir $path: $e");
+ }
+ }
+ }
+ }
+ return @created;
+}
-The following keys are recognised as parameters to C<mkpath>.
-The function returns the list of files actually created during the
-call.
+sub rmtree {
+ my $old_style = (
+ UNIVERSAL::isa($_[0],'ARRAY')
+ or (@_ == 2 and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1))
+ or (@_ == 3
+ and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1)
+ and (defined $_[2] ? $_[2] =~ /\A\d+\z/ : 1)
+ )
+ ) ? 1 : 0;
- my @created = mkpath(
- qw(/tmp /flub /home/nobody),
- {verbose => 1, mode => 0750},
- );
- print "created $_\n" for @created;
+ my $arg;
+ my $paths;
-=over 4
+ if ($old_style) {
+ my ($verbose, $safe);
+ ($paths, $verbose, $safe) = @_;
+ $arg->{verbose} = defined $verbose ? $verbose : 0;
+ $arg->{safe} = defined $safe ? $safe : 0;
-=item mode
+ if (defined($paths) and length($paths)) {
+ $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY');
+ }
+ else {
+ _carp ("No root path(s) specified\n");
+ return 0;
+ }
+ }
+ else {
+ if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH')) {
+ $arg = pop @_;
+ ${$arg->{error}} = [] if exists $arg->{error};
+ ${$arg->{result}} = [] if exists $arg->{result};
+ }
+ else {
+ @{$arg}{qw(verbose safe)} = (0, 0);
+ }
+ $paths = [@_];
+ }
-The numeric permissions mode to apply to each created directory
-(defaults to 0777), to be modified by the current C<umask>. If the
-directory already exists (and thus does not need to be created),
-the permissions will not be modified.
+ $arg->{prefix} = '';
+ $arg->{depth} = 0;
-C<mask> is recognised as an alias for this parameter.
+ $arg->{cwd} = getcwd() or do {
+ _error($arg, "cannot fetch initial working directory");
+ return 0;
+ };
+ for ($arg->{cwd}) { /\A(.*)\Z/; $_ = $1 } # untaint
-=item verbose
+ @{$arg}{qw(device inode)} = (stat $arg->{cwd})[0,1] or do {
+ _error($arg, "cannot stat initial working directory", $arg->{cwd});
+ return 0;
+ };
-If present, will cause C<mkpath> to print the name of each directory
-as it is created. By default nothing is printed.
+ return _rmtree($arg, $paths);
+}
-=item error
+sub _rmtree {
+ my $arg = shift;
+ my $paths = shift;
-If present, will be interpreted as a reference to a list, and will
-be used to store any errors that are encountered. See the ERROR
-HANDLING section for more information.
+ my $count = 0;
+ my $curdir = File::Spec->curdir();
+ my $updir = File::Spec->updir();
-If this parameter is not used, certain error conditions may raise
-a fatal error that will cause the program will halt, unless trapped
-in an C<eval> block.
+ my (@files, $root);
+ ROOT_DIR:
+ foreach $root (@$paths) {
+ if ($Is_MacOS) {
+ $root = ":$root" unless $root =~ /:/;
+ $root .= ":" unless $root =~ /:\z/;
+ }
+ else {
+ $root =~ s{/\z}{};
+ }
-=back
+ # since we chdir into each directory, it may not be obvious
+ # to figure out where we are if we generate a message about
+ # a file name. We therefore construct a semi-canonical
+ # filename, anchored from the directory being unlinked (as
+ # opposed to being truly canonical, anchored from the root (/).
-=head3 C<rmtree>
+ my $canon = $arg->{prefix}
+ ? File::Spec->catfile($arg->{prefix}, $root)
+ : $root
+ ;
-=over 4
+ my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next ROOT_DIR;
-=item verbose
+ if ( -d _ ) {
+ $root = VMS::Filespec::pathify($root) if $Is_VMS;
+ if (!chdir($root)) {
+ # see if we can escalate privileges to get in
+ # (e.g. funny protection mask such as -w- instead of rwx)
+ $perm &= 07777;
+ my $nperm = $perm | 0700;
+ if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $root))) {
+ _error($arg, "cannot make child directory read-write-exec", $canon);
+ next ROOT_DIR;
+ }
+ elsif (!chdir($root)) {
+ _error($arg, "cannot chdir to child", $canon);
+ next ROOT_DIR;
+ }
+ }
-If present, will cause C<rmtree> to print the name of each file as
-it is unlinked. By default nothing is printed.
+ my ($device, $inode, $perm) = (stat $curdir)[0,1,2] or do {
+ _error($arg, "cannot stat current working directory", $canon);
+ next ROOT_DIR;
+ };
-=item skip_others
+ ($ldev eq $device and $lino eq $inode)
+ or _croak("directory $canon changed before chdir, expected dev=$ldev inode=$lino, actual dev=$device ino=$inode, aborting.");
-When set to a true value, will cause C<rmtree> to skip the files
-for which the process lacks the required privileges needed to delete
-files, such as delete privileges on VMS.
+ $perm &= 07777; # don't forget setuid, setgid, sticky bits
+ my $nperm = $perm | 0700;
-=item keep_root
+ # notabene: 0700 is for making readable in the first place,
+ # it's also intended to change it to writable in case we have
+ # to recurse in which case we are better than rm -rf for
+ # subtrees with strange permissions
-When set to a true value, will cause all files and subdirectories
-to be removed, except the initially specified directories. This comes
+ if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $curdir))) {
+ _error($arg, "cannot make directory read+writeable", $canon);
+ $nperm = $perm;
+ }
+
+ my $d;
+ $d = gensym() if $] < 5.006;
+ if (!opendir $d, $curdir) {
+ _error($arg, "cannot opendir", $canon);
+ @files = ();
+ }
+ else {
+ no strict 'refs';
+ if (!defined ${"\cTAINT"} or ${"\cTAINT"}) {
+ # Blindly untaint dir names if taint mode is
+ # active, or any perl < 5.006
+ @files = map { /\A(.*)\z/s; $1 } readdir $d;
+ }
+ else {
+ @files = readdir $d;
+ }
+ closedir $d;
+ }
+
+ if ($Is_VMS) {
+ # Deleting large numbers of files from VMS Files-11
+ # filesystems is faster if done in reverse ASCIIbetical order.
+ # include '.' to '.;' from blead patch #31775
+ @files = map {$_ eq '.' ? '.;' : $_} reverse @files;
+ ($root = VMS::Filespec::unixify($root)) =~ s/\.dir\z//;
+ }
+ @files = grep {$_ ne $updir and $_ ne $curdir} @files;
+
+ if (@files) {
+ # remove the contained files before the directory itself
+ my $narg = {%$arg};
+ @{$narg}{qw(device inode cwd prefix depth)}
+ = ($device, $inode, $updir, $canon, $arg->{depth}+1);
+ $count += _rmtree($narg, \@files);
+ }
+
+ # restore directory permissions of required now (in case the rmdir
+ # below fails), while we are still in the directory and may do so
+ # without a race via '.'
+ if ($nperm != $perm and not chmod($perm, $curdir)) {
+ _error($arg, "cannot reset chmod", $canon);
+ }
+
+ # don't leave the client code in an unexpected directory
+ chdir($arg->{cwd})
+ or _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting.");
+
+ # ensure that a chdir upwards didn't take us somewhere other
+ # than we expected (see CVE-2002-0435)
+ ($device, $inode) = (stat $curdir)[0,1]
+ or _croak("cannot stat prior working directory $arg->{cwd}: $!, aborting.");
+
+ ($arg->{device} eq $device and $arg->{inode} eq $inode)
+ or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev inode=$lino, actual dev=$device ino=$inode, aborting.");
+
+ if ($arg->{depth} or !$arg->{keep_root}) {
+ if ($arg->{safe} &&
+ ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
+ print "skipped $root\n" if $arg->{verbose};
+ next ROOT_DIR;
+ }
+ if (!chmod $perm | 0700, $root) {
+ if ($Force_Writeable) {
+ _error($arg, "cannot make directory writeable", $canon);
+ }
+ }
+ print "rmdir $root\n" if $arg->{verbose};
+ if (rmdir $root) {
+ push @{${$arg->{result}}}, $root if $arg->{result};
+ ++$count;
+ }
+ else {
+ _error($arg, "cannot remove directory", $canon);
+ if (!chmod($perm, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
+ ) {
+ _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon);
+ }
+ }
+ }
+ }
+ else {
+ # not a directory
+
+ $root = VMS::Filespec::vmsify("./$root")
+ if $Is_VMS && !File::Spec->file_name_is_absolute($root);
+
+ if ($arg->{safe} &&
+ ($Is_VMS ? !&VMS::Filespec::candelete($root)
+ : !(-l $root || -w $root)))
+ {
+ print "skipped $root\n" if $arg->{verbose};
+ next ROOT_DIR;
+ }
+
+ my $nperm = $perm & 07777 | 0600;
+ if ($nperm != $perm and not chmod $nperm, $root) {
+ if ($Force_Writeable) {
+ _error($arg, "cannot make file writeable", $canon);
+ }
+ }
+ print "unlink $canon\n" if $arg->{verbose};
+ # delete all versions under VMS
+ for (;;) {
+ if (unlink $root) {
+ push @{${$arg->{result}}}, $root if $arg->{result};
+ }
+ else {
+ _error($arg, "cannot unlink file", $canon);
+ $Force_Writeable and chmod($perm, $root) or
+ _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon);
+ last;
+ }
+ ++$count;
+ last unless $Is_VMS && lstat $root;
+ }
+ }
+ }
+
+ return $count;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+File::Path - Create or remove directory trees
+
+=head1 VERSION
+
+This document describes version 2.02 of File::Path, released
+2007-10-24.
+
+=head1 SYNOPSIS
+
+ use File::Path;
+
+ # modern
+ mkpath( 'foo/bar/baz', '/zug/zwang', {verbose => 1} );
+
+ rmtree(
+ 'foo/bar/baz', '/zug/zwang',
+ { verbose => 1, error => \my $err_list }
+ );
+
+ # traditional
+ mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
+ rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
+
+=head1 DESCRIPTION
+
+The C<mkpath> function provides a convenient way to create directories
+of arbitrary depth. Similarly, the C<rmtree> function provides a
+convenient way to delete an entire directory subtree from the
+filesystem, much like the Unix command C<rm -r>.
+
+Both functions may be called in one of two ways, the traditional,
+compatible with code written since the dawn of time, and modern,
+that offers a more flexible and readable idiom. New code should use
+the modern interface.
+
+=head2 FUNCTIONS
+
+The modern way of calling C<mkpath> and C<rmtree> is with a list
+of directories to create, or remove, respectively, followed by an
+optional hash reference containing keys to control the
+function's behaviour.
+
+=head3 C<mkpath>
+
+The following keys are recognised as parameters to C<mkpath>.
+The function returns the list of files actually created during the
+call.
+
+ my @created = mkpath(
+ qw(/tmp /flub /home/nobody),
+ {verbose => 1, mode => 0750},
+ );
+ print "created $_\n" for @created;
+
+=over 4
+
+=item mode
+
+The numeric permissions mode to apply to each created directory
+(defaults to 0777), to be modified by the current C<umask>. If the
+directory already exists (and thus does not need to be created),
+the permissions will not be modified.
+
+C<mask> is recognised as an alias for this parameter.
+
+=item verbose
+
+If present, will cause C<mkpath> to print the name of each directory
+as it is created. By default nothing is printed.
+
+=item error
+
+If present, will be interpreted as a reference to a list, and will
+be used to store any errors that are encountered. See the ERROR
+HANDLING section for more information.
+
+If this parameter is not used, certain error conditions may raise
+a fatal error that will cause the program will halt, unless trapped
+in an C<eval> block.
+
+=back
+
+=head3 C<rmtree>
+
+=over 4
+
+=item verbose
+
+If present, will cause C<rmtree> to print the name of each file as
+it is unlinked. By default nothing is printed.
+
+=item safe
+
+When set to a true value, will cause C<rmtree> to skip the files
+for which the process lacks the required privileges needed to delete
+files, such as delete privileges on VMS. In other words, the code
+will make no attempt to alter file permissions. Thus, if the process
+is interrupted, no filesystem object will be left in a more
+permissive mode.
+
+=item keep_root
+
+When set to a true value, will cause all files and subdirectories
+to be removed, except the initially specified directories. This comes
in handy when cleaning out an application's scratch directory.
rmtree( '/tmp', {keep_root => 1} );
http://www.nntp.perl.org/group/perl.perl5.porters/2005/01/msg97623.html
http://www.debian.org/security/2005/dsa-696
-Additionally, unless the C<skip_others> parameter is set (or the
-third parameter in the traditional inferface is TRUE), should a
+Additionally, unless the C<safe> parameter is set (or the
+third parameter in the traditional interface is TRUE), should a
C<rmtree> be interrupted, files that were originally in read-only
mode may now have their permissions set to a read-write (or "delete
OK") mode.
=over 4
-=item mkdir [ppath]: [errmsg] (SEVERE)
+=item mkdir [path]: [errmsg] (SEVERE)
C<mkpath> was unable to create the path. Probably some sort of
permissions error at the point of departure, or insufficient resources
=item cannot restore permissions of [file] to [0nnn]: [errmsg]
After having failed to remove a file, C<rmtree> was also unable
-to restore the permissions on the file to a possibily less permissive
+to restore the permissions on the file to a possibly less permissive
setting. (Permissions given in octal).
=back
=item *
-L<Find::File::Rule>
+L<File::Find::Rule>
When removing directory trees, if you want to examine each file to
decide whether to delete it (and possibly leaving large swathes
=head1 ACKNOWLEDGEMENTS
-Paul Szabo identified the race condition orignially, and Brendan
+Paul Szabo identified the race condition originally, and Brendan
O'Dea wrote an implementation for Debian that addressed the problem.
That code was used as a basis for the current code. Their efforts
are greatly appreciated.
it under the same terms as Perl itself.
=cut
-
-use 5.005_04;
-use strict;
-
-use Cwd 'getcwd';
-use File::Basename ();
-use File::Spec ();
-
-BEGIN {
- if ($] < 5.006) {
- # can't say 'opendir my $dh, $dirname'
- # need to initialise $dh
- eval "use Symbol";
- }
-}
-
-use Exporter ();
-use vars qw($VERSION @ISA @EXPORT);
-$VERSION = '2.00_11';
-@ISA = qw(Exporter);
-@EXPORT = qw(mkpath rmtree);
-
-my $Is_VMS = $^O eq 'VMS';
-my $Is_MacOS = $^O eq 'MacOS';
-
-# These OSes complain if you want to remove a file that you have no
-# write permission to:
-my $Force_Writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' ||
- $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc');
-
-sub _carp {
- require Carp;
- goto &Carp::carp;
-}
-
-sub _croak {
- require Carp;
- goto &Carp::croak;
-}
-
-sub _error {
- my $arg = shift;
- my $message = shift;
- my $object = shift;
-
- if ($arg->{error}) {
- $object = '' unless defined $object;
- push @{${$arg->{error}}}, {$object => "$message: $!"};
- }
- else {
- _carp(defined($object) ? "$message for $object: $!" : "$message: $!");
- }
-}
-
-sub mkpath {
- my $old_style = (
- UNIVERSAL::isa($_[0],'ARRAY')
- or (@_ == 2 and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1))
- or (@_ == 3
- and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1)
- and (defined $_[2] ? $_[2] =~ /\A\d+\z/ : 1)
- )
- ) ? 1 : 0;
-
- my $arg;
- my $paths;
-
- if ($old_style) {
- my ($verbose, $mode);
- ($paths, $verbose, $mode) = @_;
- $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY');
- $arg->{verbose} = defined $verbose ? $verbose : 0;
- $arg->{mode} = defined $mode ? $mode : 0777;
- }
- else {
- if (@_ > 0 and UNIVERSAL::isa($_[-1], 'HASH')) {
- $arg = pop @_;
- exists $arg->{mask} and $arg->{mode} = delete $arg->{mask};
- $arg->{mode} = 0777 unless exists $arg->{mode};
- ${$arg->{error}} = [] if exists $arg->{error};
- }
- else {
- @{$arg}{qw(verbose mode)} = (0, 0777);
- }
- $paths = [@_];
- }
- return _mkpath($arg, $paths);
-}
-
-sub _mkpath {
- my $arg = shift;
- my $paths = shift;
-
- local($")=$Is_MacOS ? ":" : "/";
- my(@created,$path);
- foreach $path (@$paths) {
- next unless length($path);
- $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT
- # Logic wants Unix paths, so go with the flow.
- if ($Is_VMS) {
- next if $path eq '/';
- $path = VMS::Filespec::unixify($path);
- }
- next if -d $path;
- my $parent = File::Basename::dirname($path);
- unless (-d $parent or $path eq $parent) {
- push(@created,_mkpath($arg, [$parent]));
- }
- print "mkdir $path\n" if $arg->{verbose};
- if (mkdir($path,$arg->{mode})) {
- push(@created, $path);
- }
- else {
- my $save_bang = $!;
- my ($e, $e1) = ($save_bang, $^E);
- $e .= "; $e1" if $e ne $e1;
- # allow for another process to have created it meanwhile
- if (!-d $path) {
- $! = $save_bang;
- if ($arg->{error}) {
- push @{${$arg->{error}}}, {$path => $e};
- }
- else {
- _croak("mkdir $path: $e");
- }
- }
- }
- }
- return @created;
-}
-
-sub rmtree {
- my $old_style = (
- UNIVERSAL::isa($_[0],'ARRAY')
- or (@_ == 2 and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1))
- or (@_ == 3
- and (defined $_[1] ? $_[1] =~ /\A\d+\z/ : 1)
- and (defined $_[2] ? $_[2] =~ /\A\d+\z/ : 1)
- )
- ) ? 1 : 0;
-
- my $arg;
- my $paths;
-
- if ($old_style) {
- my ($verbose, $safe);
- ($paths, $verbose, $safe) = @_;
- $arg->{verbose} = defined $verbose ? $verbose : 0;
- $arg->{safe} = defined $safe ? $safe : 0;
-
- if (defined($paths) and length($paths)) {
- $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY');
- }
- else {
- _carp ("No root path(s) specified\n");
- return 0;
- }
- }
- else {
- if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH')) {
- $arg = pop @_;
- ${$arg->{error}} = [] if exists $arg->{error};
- ${$arg->{result}} = [] if exists $arg->{result};
- }
- else {
- @{$arg}{qw(verbose safe)} = (0, 0);
- }
- $paths = [@_];
- }
-
- $arg->{prefix} = '';
- $arg->{depth} = 0;
-
- $arg->{cwd} = getcwd() or do {
- _error($arg, "cannot fetch initial working directory");
- return 0;
- };
- for ($arg->{cwd}) { /\A(.*)\Z/; $_ = $1 } # untaint
-
- @{$arg}{qw(device inode)} = (stat $arg->{cwd})[0,1] or do {
- _error($arg, "cannot stat initial working directory", $arg->{cwd});
- return 0;
- };
-
- return _rmtree($arg, $paths);
-}
-
-sub _rmtree {
- my $arg = shift;
- my $paths = shift;
-
- my $count = 0;
- my $curdir = File::Spec->curdir();
- my $updir = File::Spec->updir();
-
- my (@files, $root);
- foreach $root (@$paths) {
- if ($Is_MacOS) {
- $root = ":$root" unless $root =~ /:/;
- $root .= ":" unless $root =~ /:\z/;
- }
- else {
- $root =~ s{/\z}{};
- }
- my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next;
-
- # since we chdir into each directory, it may not be obvious
- # to figure out where we are if we generate a message about
- # a file name. We therefore construct a semi-canonical
- # filename, anchored from the directory being unlinked (as
- # opposed to being truly canonical, anchored from the root (/).
-
- my $canon = $arg->{prefix}
- ? File::Spec->catdir($arg->{prefix}, $root)
- : $root
- ;
-
- if ( -d _ ) {
- if (!chdir($root)) {
- # see if we can escalate privileges to get in
- # (e.g. funny protection mask such as -w- instead of rwx)
- $perm &= 07777;
- my $nperm = $perm | 0700;
- if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $root))) {
- _error($arg, "cannot make child directory read-write-exec", $canon);
- next;
- }
- elsif (!chdir($root)) {
- _error($arg, "cannot chdir to child", $canon);
- next;
- }
- }
-
- my ($device, $inode, $perm) = (stat $curdir)[0,1,2] or do {
- _error($arg, "cannot stat current working directory", $canon);
- return $count;
- };
-
- ($ldev eq $device and $lino eq $inode)
- or _croak("directory $canon changed before chdir, expected dev=$ldev inode=$lino, actual dev=$device ino=$inode, aborting.");
-
- $perm &= 07777; # don't forget setuid, setgid, sticky bits
- my $nperm = $perm | 0700;
-
- # notabene: 0700 is for making readable in the first place,
- # it's also intended to change it to writable in case we have
- # to recurse in which case we are better than rm -rf for
- # subtrees with strange permissions
-
- if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $curdir))) {
- _error($arg, "cannot make directory read+writeable", $canon);
- $nperm = $perm;
- }
-
- my $d;
- $d = gensym() if $] < 5.006;
- if (!opendir $d, $curdir) {
- _error($arg, "cannot opendir", $canon);
- @files = ();
- }
- else {
- no strict 'refs';
- if (!defined ${"\cTAINT"} or ${"\cTAINT"}) {
- # Blindly untaint dir names if taint mode is
- # active, or any perl < 5.006
- @files = map { /\A(.*)\z/s; $1 } readdir $d;
- }
- else {
- @files = readdir $d;
- }
- closedir $d;
- }
-
- if ($Is_VMS) {
- # Deleting large numbers of files from VMS Files-11
- # filesystems is faster if done in reverse ASCIIbetical order.
- # include '.' to '.;' from blead patch #31775
- @files = map {$_ eq '.' ? '.;' : $_} reverse @files;
- ($root = VMS::Filespec::unixify($root)) =~ s/\.dir\z//;
- }
- @files = grep {$_ ne $updir and $_ ne $curdir} @files;
-
- if (@files) {
- # remove the contained files before the directory itself
- my $narg = {%$arg};
- @{$narg}{qw(device inode cwd prefix depth)}
- = ($device, $inode, $updir, $canon, $arg->{depth}+1);
- $count += _rmtree($narg, \@files);
- }
-
- # restore directory permissions of required now (in case the rmdir
- # below fails), while we are still in the directory and may do so
- # without a race via '.'
- if ($nperm != $perm and not chmod($perm, $curdir)) {
- _error($arg, "cannot reset chmod", $canon);
- }
-
- # don't leave the client code in an unexpected directory
- chdir($arg->{cwd})
- or _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting.");
-
- # ensure that a chdir upwards didn't take us somewhere other
- # than we expected (see CVE-2002-0435)
- ($device, $inode) = (stat $curdir)[0,1]
- or _croak("cannot stat prior working directory $arg->{cwd}: $!, aborting.");
-
- ($arg->{device} eq $device and $arg->{inode} eq $inode)
- or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev inode=$lino, actual dev=$device ino=$inode, aborting.");
-
- if ($arg->{depth} or !$arg->{keep_root}) {
- if ($arg->{safe} &&
- ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
- print "skipped $root\n" if $arg->{verbose};
- next;
- }
- if (!chmod $perm | 0700, $root) {
- if ($Force_Writeable) {
- _error($arg, "cannot make directory writeable", $canon);
- }
- }
- print "rmdir $root\n" if $arg->{verbose};
- if (rmdir $root) {
- push @{${$arg->{result}}}, $root if $arg->{result};
- ++$count;
- }
- else {
- _error($arg, "cannot remove directory", $canon);
- if (!chmod($perm, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
- ) {
- _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon);
- }
- }
- }
- }
- else {
- # not a directory
- if ($arg->{safe} &&
- ($Is_VMS ? !&VMS::Filespec::candelete($root)
- : !(-l $root || -w $root)))
- {
- print "skipped $root\n" if $arg->{verbose};
- next;
- }
-
- my $nperm = $perm & 07777 | 0600;
- if ($nperm != $perm and not chmod $nperm, $root) {
- if ($Force_Writeable) {
- _error($arg, "cannot make file writeable", $canon);
- }
- }
- print "unlink $canon\n" if $arg->{verbose};
- # delete all versions under VMS
- for (;;) {
- if (unlink $root) {
- push @{${$arg->{result}}}, $root if $arg->{result};
- }
- else {
- _error($arg, "cannot unlink file", $canon);
- $Force_Writeable and chmod($perm, $root) or
- _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon);
- last;
- }
- ++$count;
- last unless $Is_VMS && lstat $root;
- }
- }
- }
-
- return $count;
-}
-
-1;