package File::Path;
+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.02';
+@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);
+ ROOT_DIR:
+ foreach $root (@$paths) {
+ if ($Is_MacOS) {
+ $root = ":$root" unless $root =~ /:/;
+ $root .= ":" unless $root =~ /:\z/;
+ }
+ else {
+ $root =~ s{/\z}{};
+ }
+
+ # 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->catfile($arg->{prefix}, $root)
+ : $root
+ ;
+
+ my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next ROOT_DIR;
+
+ 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;
+ }
+ }
+
+ my ($device, $inode, $perm) = (stat $curdir)[0,1,2] or do {
+ _error($arg, "cannot stat current working directory", $canon);
+ next ROOT_DIR;
+ };
+
+ ($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 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.01 of File::Path, released
-2007-09-29.
+This document describes version 2.02 of File::Path, released
+2007-10-24.
=head1 SYNOPSIS
=item cannot reset chmod [dir]: [errmsg]
-C<rmtree>, after having deleted everything in a directory, attempted
-to restore its permissions to the original state but failed. The
-directory may wind up being left behind.
-
-=item cannot chdir to [parent-dir] from [child-dir]: [errmsg], aborting. (FATAL)
-
-C<rmtree>, after having deleted everything and restored the permissions
-of a directory, was unable to chdir back to the parent. This is usually
-a sign that something evil this way comes.
-
-=item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL)
-
-C<rmtree> was unable to stat the parent directory after have returned
-from the child. Since there is no way of knowing if we returned to
-where we think we should be (by comparing device and inode) the only
-way out is to C<croak>.
-
-=item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] inode=[n], actual dev=[n] ino=[n], aborting. (FATAL)
-
-When C<rmtree> returned from deleting files in a child directory, a
-check revealed that the parent directory it returned to wasn't the one
-it started out from. This is considered a sign of malicious activity.
-
-=item cannot make directory [dir] writeable: [errmsg]
-
-Just before removing a directory (after having successfully removed
-everything it contained), C<rmtree> attempted to set the permissions
-on the directory to ensure it could be removed and failed. Program
-execution continues, but the directory may possibly not be deleted.
-
-=item cannot remove directory [dir]: [errmsg]
-
-C<rmtree> attempted to remove a directory, but failed. This may because
-some objects that were unable to be removed remain in the directory, or
-a permissions issue. The directory will be left behind.
-
-=item cannot restore permissions of [dir] to [0nnn]: [errmsg]
-
-After having failed to remove a directory, C<rmtree> was unable to
-restore its permissions from a permissive state back to a possibly
-more restrictive setting. (Permissions given in octal).
-
-=item cannot make file [file] writeable: [errmsg]
-
-C<rmtree> attempted to force the permissions of a file to ensure it
-could be deleted, but failed to do so. It will, however, still attempt
-to unlink the file.
-
-=item cannot unlink file [file]: [errmsg]
-
-C<rmtree> failed to remove a file. Probably a permissions issue.
-
-=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 possibly less permissive
-setting. (Permissions given in octal).
-
-=back
-
-=head1 SEE ALSO
-
-=over 4
-
-=item *
-
-L<Find::File::Rule>
-
-When removing directory trees, if you want to examine each file to
-decide whether to delete it (and possibly leaving large swathes
-alone), F<File::Find::Rule> offers a convenient and flexible approach
-to examining directory trees.
-
-=back
-
-=head1 BUGS
-
-Please report all bugs on the RT queue:
-
-L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path>
-
-=head1 ACKNOWLEDGEMENTS
-
-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.
-
-=head1 AUTHORS
-
-Tim Bunce <F<Tim.Bunce@ig.co.uk>> and Charles Bailey
-<F<bailey@newman.upenn.edu>>. Currently maintained by David Landgren
-<F<david@landgren.net>>.
-
-=head1 COPYRIGHT
-
-This module is copyright (C) Charles Bailey, Tim Bunce and
-David Landgren 1995-2007. All rights reserved.
-
-=head1 LICENSE
-
-This library is free software; you can redistribute it and/or modify
-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.01';
-@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;
+C<rmtree>, after having deleted everything in a directory, attempted
+to restore its permissions to the original state but failed. The
+directory may wind up being left behind.
- my $arg;
- my $paths;
+=item cannot chdir to [parent-dir] from [child-dir]: [errmsg], aborting. (FATAL)
- if ($old_style) {
- my ($verbose, $safe);
- ($paths, $verbose, $safe) = @_;
- $arg->{verbose} = defined $verbose ? $verbose : 0;
- $arg->{safe} = defined $safe ? $safe : 0;
+C<rmtree>, after having deleted everything and restored the permissions
+of a directory, was unable to chdir back to the parent. This is usually
+a sign that something evil this way comes.
- 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 = [@_];
- }
+=item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL)
- $arg->{prefix} = '';
- $arg->{depth} = 0;
+C<rmtree> was unable to stat the parent directory after have returned
+from the child. Since there is no way of knowing if we returned to
+where we think we should be (by comparing device and inode) the only
+way out is to C<croak>.
- $arg->{cwd} = getcwd() or do {
- _error($arg, "cannot fetch initial working directory");
- return 0;
- };
- for ($arg->{cwd}) { /\A(.*)\Z/; $_ = $1 } # untaint
+=item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] inode=[n], actual dev=[n] ino=[n], aborting. (FATAL)
- @{$arg}{qw(device inode)} = (stat $arg->{cwd})[0,1] or do {
- _error($arg, "cannot stat initial working directory", $arg->{cwd});
- return 0;
- };
+When C<rmtree> returned from deleting files in a child directory, a
+check revealed that the parent directory it returned to wasn't the one
+it started out from. This is considered a sign of malicious activity.
- return _rmtree($arg, $paths);
-}
+=item cannot make directory [dir] writeable: [errmsg]
-sub _rmtree {
- my $arg = shift;
- my $paths = shift;
+Just before removing a directory (after having successfully removed
+everything it contained), C<rmtree> attempted to set the permissions
+on the directory to ensure it could be removed and failed. Program
+execution continues, but the directory may possibly not be deleted.
- my $count = 0;
- my $curdir = File::Spec->curdir();
- my $updir = File::Spec->updir();
+=item cannot remove directory [dir]: [errmsg]
- my (@files, $root);
- ROOT_DIR:
- foreach $root (@$paths) {
- if ($Is_MacOS) {
- $root = ":$root" unless $root =~ /:/;
- $root .= ":" unless $root =~ /:\z/;
- }
- else {
- $root =~ s{/\z}{};
- }
+C<rmtree> attempted to remove a directory, but failed. This may because
+some objects that were unable to be removed remain in the directory, or
+a permissions issue. The directory will be left behind.
- # 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 (/).
+=item cannot restore permissions of [dir] to [0nnn]: [errmsg]
- my $canon = $arg->{prefix}
- ? File::Spec->catfile($arg->{prefix}, $root)
- : $root
- ;
+After having failed to remove a directory, C<rmtree> was unable to
+restore its permissions from a permissive state back to a possibly
+more restrictive setting. (Permissions given in octal).
- my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next ROOT_DIR;
+=item cannot make file [file] writeable: [errmsg]
- 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;
- }
- }
+C<rmtree> attempted to force the permissions of a file to ensure it
+could be deleted, but failed to do so. It will, however, still attempt
+to unlink the file.
- my ($device, $inode, $perm) = (stat $curdir)[0,1,2] or do {
- _error($arg, "cannot stat current working directory", $canon);
- next ROOT_DIR;
- };
+=item cannot unlink file [file]: [errmsg]
- ($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.");
+C<rmtree> failed to remove a file. Probably a permissions issue.
- $perm &= 07777; # don't forget setuid, setgid, sticky bits
- my $nperm = $perm | 0700;
+=item cannot restore permissions of [file] to [0nnn]: [errmsg]
- # 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
+After having failed to remove a file, C<rmtree> was also unable
+to restore the permissions on the file to a possibly less permissive
+setting. (Permissions given in octal).
- if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $curdir))) {
- _error($arg, "cannot make directory read+writeable", $canon);
- $nperm = $perm;
- }
+=back
- 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;
- }
+=head1 SEE ALSO
- 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;
+=over 4
- 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);
- }
+=item *
- # 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);
- }
+L<File::Find::Rule>
- # don't leave the client code in an unexpected directory
- chdir($arg->{cwd})
- or _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting.");
+When removing directory trees, if you want to examine each file to
+decide whether to delete it (and possibly leaving large swathes
+alone), F<File::Find::Rule> offers a convenient and flexible approach
+to examining directory trees.
- # 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.");
+=back
- ($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.");
+=head1 BUGS
- 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
+Please report all bugs on the RT queue:
- $root = VMS::Filespec::vmsify("./$root")
- if $Is_VMS && !File::Spec->file_name_is_absolute($root);
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path>
- if ($arg->{safe} &&
- ($Is_VMS ? !&VMS::Filespec::candelete($root)
- : !(-l $root || -w $root)))
- {
- print "skipped $root\n" if $arg->{verbose};
- next ROOT_DIR;
- }
+=head1 ACKNOWLEDGEMENTS
- 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;
- }
- }
- }
+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.
- return $count;
-}
+=head1 AUTHORS
-1;
+Tim Bunce <F<Tim.Bunce@ig.co.uk>> and Charles Bailey
+<F<bailey@newman.upenn.edu>>. Currently maintained by David Landgren
+<F<david@landgren.net>>.
+
+=head1 COPYRIGHT
+
+This module is copyright (C) Charles Bailey, Tim Bunce and
+David Landgren 1995-2007. All rights reserved.
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
projects / p5sagit/p5-mst-13.2.git / commitdiff