This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
File::Path 2.02
authorDavid Landgren <david@landgren.net>
Wed, 24 Oct 2007 15:11:29 +0000 (17:11 +0200)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Wed, 24 Oct 2007 13:43:17 +0000 (13:43 +0000)
Message-ID: <471F4481.6010103@landgren.net>

p4raw-id: //depot/perl@32186

lib/File/Path.pm

index 156e743..13918e2 100644 (file)
 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
 
@@ -402,487 +782,108 @@ after the call.
 
 =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