Upgrade to File::Path 2.06_06. (a diff from David via http)

p4raw-id: //depot/perl@34615

diff --git a/lib/File/Path.pm b/lib/File/Path.pm
index 19b5750..a622ac7 100644 (file)
--- a/lib/File/Path.pm
+++ b/lib/File/Path.pm
@@ -16,10 +16,11 @@ BEGIN {
 }
 
 use Exporter ();
 }
 
 use Exporter ();

-use vars qw($VERSION @ISA @EXPORT);
-$VERSION = '2.04';
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+$VERSION   = '2.06_06';

 @ISA     = qw(Exporter);
 @EXPORT  = qw(mkpath rmtree);
 @ISA     = qw(Exporter);
 @EXPORT  = qw(mkpath rmtree);

+@EXPORT_OK = qw(make_path remove_tree);

 
 my $Is_VMS   = $^O eq 'VMS';
 my $Is_MacOS = $^O eq 'MacOS';
 
 my $Is_VMS   = $^O eq 'VMS';
 my $Is_MacOS = $^O eq 'MacOS';


@@ -45,22 +46,21 @@ sub _error {
 
     if ($arg->{error}) {
         $object = '' unless defined $object;
 
     if ($arg->{error}) {
         $object = '' unless defined $object;

-        push @{${$arg->{error}}}, {$object => "$message: $!"};
+        $message .= ": $!" if $!;
+        push @{${$arg->{error}}}, {$object => $message};

     }
     else {
         _carp(defined($object) ? "$message for $object: $!" : "$message: $!");
     }
 }
 
     }
     else {
         _carp(defined($object) ? "$message for $object: $!" : "$message: $!");
     }
 }
 

+sub make_path {
+    push @_, {} if !@_ or (@_ and !UNIVERSAL::isa($_[-1],'HASH'));
+    goto &mkpath;
+}
+

 sub mkpath {
 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 $old_style = !(@_ > 0 and UNIVERSAL::isa($_[-1],'HASH'));

 
     my $arg;
     my $paths;
 
     my $arg;
     my $paths;


@@ -73,15 +73,11 @@ sub mkpath {
         $arg->{mode}    = defined $mode    ? $mode    : 0777;
     }
     else {
         $arg->{mode}    = defined $mode    ? $mode    : 0777;
     }
     else {

-        if (@_ > 0 and UNIVERSAL::isa($_[-1], 'HASH')) {

             $arg = pop @_;
             $arg = pop @_;

-            exists $arg->{mask} and $arg->{mode} = delete $arg->{mask};
+        $arg->{verbose} ||= 0;
+        $arg->{mode}      = delete $arg->{mask} if exists $arg->{mask};

             $arg->{mode} = 0777 unless exists $arg->{mode};
             ${$arg->{error}} = [] if exists $arg->{error};
             $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);
         $paths = [@_];
     }
     return _mkpath($arg, $paths);


@@ -91,10 +87,9 @@ sub _mkpath {
     my $arg   = shift;
     my $paths = shift;
 
     my $arg   = shift;
     my $paths = shift;
 

-    local($")=$Is_MacOS ? ":" : "/";

     my(@created,$path);
     foreach $path (@$paths) {
     my(@created,$path);
     foreach $path (@$paths) {

-        next unless length($path);
+        next unless defined($path) and 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) {
         $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) {


@@ -129,15 +124,13 @@ sub _mkpath {
     return @created;
 }
 
     return @created;
 }
 

+sub remove_tree {
+    push @_, {} if !@_ or (@_ and !UNIVERSAL::isa($_[-1],'HASH'));
+    goto &rmtree;
+}
+

 sub rmtree {
 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 $old_style = !(@_ > 0 and UNIVERSAL::isa($_[-1],'HASH'));

 
     my $arg;
     my $paths;
 
     my $arg;
     my $paths;


@@ -171,18 +164,42 @@ sub rmtree {
     $arg->{prefix} = '';
     $arg->{depth}  = 0;
 
     $arg->{prefix} = '';
     $arg->{depth}  = 0;
 

+    my @clean_path;

     $arg->{cwd} = getcwd() or do {
         _error($arg, "cannot fetch initial working directory");
         return 0;
     };
     for ($arg->{cwd}) { /\A(.*)\Z/; $_ = $1 } # untaint
 
     $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 {
+    for my $p (@$paths) {
+        # need to fixup case and map \ to / on Windows
+        my $ortho_root = $^O eq 'MSWin32' ? _slash_lc($p)          : $p;
+        my $ortho_cwd  = $^O eq 'MSWin32' ? _slash_lc($arg->{cwd}) : $arg->{cwd};
+        if ($ortho_root eq substr($ortho_cwd, 0, length($ortho_root))) {
+            local $! = 0;
+            _error($arg, "cannot remove path when cwd is $arg->{cwd}", $p);
+            next;
+        }
+
+        if ($Is_MacOS) {
+            $p  = ":$p" unless $p =~ /:/;
+            $p .= ":"   unless $p =~ /:\z/;
+        }
+        elsif ($^O eq 'MSWin32') {
+            $p =~ s{[/\\]\z}{};
+        }
+        else {
+            $p =~ s{/\z}{};
+        }
+        push @clean_path, $p;
+    }
+
+    @{$arg}{qw(device inode perm)} = (lstat $arg->{cwd})[0,1] or do {

         _error($arg, "cannot stat initial working directory", $arg->{cwd});
         return 0;
     };
 
         _error($arg, "cannot stat initial working directory", $arg->{cwd});
         return 0;
     };
 

-    return _rmtree($arg, $paths);
+    return _rmtree($arg, \@clean_path);

 }
 
 sub _rmtree {
 }
 
 sub _rmtree {


@@ -196,14 +213,6 @@ sub _rmtree {
     my (@files, $root);
     ROOT_DIR:
     foreach $root (@$paths) {
     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
         # 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


@@ -234,13 +243,13 @@ sub _rmtree {
                 }
             }
 
                 }
             }
 

-            my ($device, $inode, $perm) = (stat $curdir)[0,1,2] or do {
+            my ($cur_dev, $cur_inode, $perm) = (stat $curdir)[0,1,2] or do {

                 _error($arg, "cannot stat current working directory", $canon);
                 next ROOT_DIR;
             };
 
                 _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.");
+            ($ldev eq $cur_dev and $lino eq $cur_inode)
+                or _croak("directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");

 
             $perm &= 07777; # don't forget setuid, setgid, sticky bits
             my $nperm = $perm | 0700;
 
             $perm &= 07777; # don't forget setuid, setgid, sticky bits
             my $nperm = $perm | 0700;


@@ -287,7 +296,7 @@ sub _rmtree {
                 # remove the contained files before the directory itself
                 my $narg = {%$arg};
                 @{$narg}{qw(device inode cwd prefix depth)}
                 # 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);
+                    = ($cur_dev, $cur_inode, $updir, $canon, $arg->{depth}+1);

                 $count += _rmtree($narg, \@files);
             }
 
                 $count += _rmtree($narg, \@files);
             }
 


@@ -304,11 +313,11 @@ sub _rmtree {
 
             # ensure that a chdir upwards didn't take us somewhere other
             # than we expected (see CVE-2002-0435)
 
             # ensure that a chdir upwards didn't take us somewhere other
             # than we expected (see CVE-2002-0435)

-            ($device, $inode) = (stat $curdir)[0,1]
+            ($cur_dev, $cur_inode) = (stat $curdir)[0,1]

                 or _croak("cannot stat prior working directory $arg->{cwd}: $!, aborting.");
 
                 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.");
+            ($arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode)
+                or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");

 
             if ($arg->{depth} or !$arg->{keep_root}) {
                 if ($arg->{safe} &&
 
             if ($arg->{depth} or !$arg->{keep_root}) {
                 if ($arg->{safe} &&


@@ -316,11 +325,9 @@ sub _rmtree {
                     print "skipped $root\n" if $arg->{verbose};
                     next ROOT_DIR;
                 }
                     print "skipped $root\n" if $arg->{verbose};
                     next ROOT_DIR;
                 }

-                if (!chmod $perm | 0700, $root) {
-                    if ($Force_Writeable) {
+                if ($Force_Writeable and !chmod $perm | 0700, $root) {

                         _error($arg, "cannot make directory writeable", $canon);
                     }
                         _error($arg, "cannot make directory writeable", $canon);
                     }

-                }

                 print "rmdir $root\n" if $arg->{verbose};
                 if (rmdir $root) {
                     push @{${$arg->{result}}}, $root if $arg->{result};
                 print "rmdir $root\n" if $arg->{verbose};
                 if (rmdir $root) {
                     push @{${$arg->{result}}}, $root if $arg->{result};


@@ -351,11 +358,9 @@ sub _rmtree {
             }
 
             my $nperm = $perm & 07777 | 0600;
             }
 
             my $nperm = $perm & 07777 | 0600;

-            if ($nperm != $perm and not chmod $nperm, $root) {
-                if ($Force_Writeable) {
+            if ($Force_Writeable and $nperm != $perm and not chmod $nperm, $root) {

                     _error($arg, "cannot make file writeable", $canon);
                 }
                     _error($arg, "cannot make file writeable", $canon);
                 }

-            }

             print "unlink $canon\n" if $arg->{verbose};
             # delete all versions under VMS
             for (;;) {
             print "unlink $canon\n" if $arg->{verbose};
             # delete all versions under VMS
             for (;;) {


@@ -373,10 +378,17 @@ sub _rmtree {
             }
         }
     }
             }
         }
     }

-

     return $count;
 }
 
     return $count;
 }
 

+sub _slash_lc {
+    # fix up slashes and case on MSWin32 so that we can determine that
+    # c:\path\to\dir is underneath C:/Path/To
+    my $path = shift;
+    $path =~ tr{\\}{/};
+    return lc($path);
+}
+

 1;
 __END__
 
 1;
 __END__
 


@@ -386,20 +398,24 @@ File::Path - Create or remove directory trees
 
 =head1 VERSION
 
 
 =head1 VERSION
 

-This document describes version 2.04 of File::Path, released
-2007-11-13.
+This document describes version 2.06_06 of File::Path, released
+2008-10-05.

 
 =head1 SYNOPSIS
 
     use File::Path;
 
     # modern
 
 =head1 SYNOPSIS
 
     use File::Path;
 
     # modern

+  make_path( 'foo/bar/baz', '/zug/zwang' );
+  # or

     mkpath( 'foo/bar/baz', '/zug/zwang', {verbose => 1} );
 
     rmtree(
         'foo/bar/baz', '/zug/zwang',
         { verbose => 1, error  => \my $err_list }
     );
     mkpath( 'foo/bar/baz', '/zug/zwang', {verbose => 1} );
 
     rmtree(
         'foo/bar/baz', '/zug/zwang',
         { verbose => 1, error  => \my $err_list }
     );

+  # or
+  remove_tree( 'foo/bar/baz', '/zug/zwang' );

 
     # traditional
     mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
 
     # traditional
     mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);


@@ -410,32 +426,48 @@ This document describes version 2.04 of File::Path, released
 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
 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>.
+filesystem, much like the Unix command C<rm -r> or C<del /s> on
+Windows.

 
 

-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.
+There are two further functions, C<make_path> and C<remove_tree>
+that perform the same task and offer a more intuitive interface.

 
 =head2 FUNCTIONS
 
 The modern way of calling C<mkpath> and C<rmtree> is with a list
 
 =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.
+of directories to create, or remove, respectively, followed by a
+hash reference containing keys to control the function's behaviour.

 
 

-=head3 C<mkpath>
+=head3 C<make_path>
+
+The C<make_path> routine accepts a list of directories to be
+created. Its behaviour may be tuned by an optional hashref
+appearing as the last parameter on the call.
+
+  my @created = make_path(qw(/tmp /flub /home/nobody));
+  print "created $_\n" for @created;

 
 

-The following keys are recognised as parameters to C<mkpath>.

 The function returns the list of files actually created during the
 call.
 
 The function returns the list of files actually created during the
 call.
 

+=head3 C<mkpath>
+
+The C<mkpath> routine will recognise a final hashref in the
+same manner as C<make_path>. If no hashref is present, the
+parameters are interpreted according to the traditional interface
+(see below).
+

   my @created = mkpath(
     qw(/tmp /flub /home/nobody),
     {verbose => 1, mode => 0750},
   );
   print "created $_\n" for @created;
 
   my @created = mkpath(
     qw(/tmp /flub /home/nobody),
     {verbose => 1, mode => 0750},
   );
   print "created $_\n" for @created;
 

+The function returns the list of directories actually created during
+the call.
+
+The following keys are recognised:
+

 =over 4
 
 =item mode
 =over 4
 
 =item mode


@@ -464,8 +496,24 @@ in an C<eval> block.
 
 =back
 
 
 =back
 

+=head3 C<remove_tree>
+
+The C<remove_tree> routine accepts a list of directories to be
+removed. Its behaviour may be tuned by an optional hashref
+appearing as the last parameter on the call.
+
+  remove_tree( 'this/dir', 'that/dir' );
+

 =head3 C<rmtree>
 
 =head3 C<rmtree>
 

+The C<rmtree> routine will recognise a final hashref in the
+same manner as C<remove_tree>. If no hashref is present, the
+parameters are interpreted according to the traditional interface.
+
+  rmtree( 'mydir', 1 );                 # traditional
+  rmtree( ['mydir'], 1 );               # traditional
+  rmtree( 'mydir', 1, {verbose => 0} ); # modern
+

 =over 4
 
 =item verbose
 =over 4
 
 =item verbose


@@ -488,7 +536,7 @@ 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.
 
 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} );
+  remove_tree( '/tmp', {keep_root => 1} );

 
 =item result
 
 
 =item result
 


@@ -497,7 +545,7 @@ be used to store the list of all files and directories unlinked
 during the call. If nothing is unlinked, a reference to an empty
 list is returned (rather than C<undef>).
 
 during the call. If nothing is unlinked, a reference to an empty
 list is returned (rather than C<undef>).
 

-  rmtree( '/tmp', {result => \my $list} );
+  remove_tree( '/tmp', {result => \my $list} );

   print "unlinked $_\n" for @$list;
 
 This is a useful alternative to the C<verbose> key.
   print "unlinked $_\n" for @$list;
 
 This is a useful alternative to the C<verbose> key.


@@ -524,6 +572,11 @@ of hand. This is the safest course of action.
 The old interfaces of C<mkpath> and C<rmtree> take a reference to
 a list of directories (to create or remove), followed by a series
 of positional, numeric, modal parameters that control their behaviour.
 The old interfaces of C<mkpath> and C<rmtree> take a reference to
 a list of directories (to create or remove), followed by a series
 of positional, numeric, modal parameters that control their behaviour.

+If only one directory is being created or removed, a simple scalar
+may be used instead of the reference.
+
+  rmtree( ['dir1', 'dir2'], 0, 1 );
+  rmtree( 'dir3', 1, 1 );

 
 This design made it difficult to add additional functionality, as
 well as posed the problem of what to do when the calling code only
 
 This design made it difficult to add additional functionality, as
 well as posed the problem of what to do when the calling code only


@@ -561,13 +614,13 @@ the numeric mode to use when creating the directories (defaults to
 
 =back
 
 
 =back
 

-It returns a list of all directories (including intermediates, determined
-using the Unix '/' separator) created.  In scalar context it returns
-the number of directories created.
+It returns a list of all directories (including intermediates,
+determined using the Unix '/' separator) created. In scalar context
+it returns the number of directories created.

 
 If a system error prevents a directory from being created, then the
 
 If a system error prevents a directory from being created, then the

-C<mkpath> function throws a fatal error with C<Carp::croak>. This error
-can be trapped with an C<eval> block:
+C<mkpath> function throws a fatal error with C<Carp::croak>. This
+error can be trapped with an C<eval> block:

 
   eval { mkpath($dir) };
   if ($@) {
 
   eval { mkpath($dir) };
   if ($@) {


@@ -602,8 +655,8 @@ other than VMS is settled.  (defaults to FALSE)
 
 =back
 
 
 =back
 

-It returns the number of files, directories and symlinks successfully
-deleted.  Symlinks are simply deleted and not followed.
+C<rmtree> returns the number of files, directories and symlinks
+successfully deleted. Symlinks are simply deleted and not followed.

 
 Note also that the occurrence of errors in C<rmtree> using the
 traditional interface can be determined I<only> by trapping diagnostic
 
 Note also that the occurrence of errors in C<rmtree> using the
 traditional interface can be determined I<only> by trapping diagnostic


@@ -611,6 +664,9 @@ messages using C<$SIG{__WARN__}>; it is not apparent from the return
 value. (The modern interface may use the C<error> parameter to
 record any problems encountered).
 
 value. (The modern interface may use the C<error> parameter to
 record any problems encountered).
 

+It is not possible to invoke the C<keep_root> functionality through
+the traditional interface.
+

 =head2 ERROR HANDLING
 
 If C<mkpath> or C<rmtree> encounter an error, a diagnostic message
 =head2 ERROR HANDLING
 
 If C<mkpath> or C<rmtree> encounter an error, a diagnostic message


@@ -624,7 +680,7 @@ references. For each hash reference, the key is the name of the
 file, and the value is the error message (usually the contents of
 C<$!>). An example usage looks like:
 
 file, and the value is the error message (usually the contents of
 C<$!>). An example usage looks like:
 

-  rmpath( 'foo/bar', 'bar/rat', {error => \my $err} );
+  remove_tree( 'foo/bar', 'bar/rat', {error => \my $err} );

   for my $diag (@$err) {
     my ($file, $message) = each %$diag;
     print "problem unlinking $file: $message\n";
   for my $diag (@$err) {
     my ($file, $message) = each %$diag;
     print "problem unlinking $file: $message\n";


@@ -636,7 +692,7 @@ is encountered (for instance, C<rmtree> attempts to remove a directory
 tree that does not exist), the diagnostic key will be empty, only
 the value will be set:
 
 tree that does not exist), the diagnostic key will be empty, only
 the value will be set:
 

-  rmpath( '/no/such/path', {error => \my $err} );
+  remove_tree( '/no/such/path', {error => \my $err} );

   for my $diag (@$err) {
     my ($file, $message) = each %$diag;
     if ($file eq '') {
   for my $diag (@$err) {
     my ($file, $message) = each %$diag;
     if ($file eq '') {


@@ -653,38 +709,18 @@ invited to specify what it is you are expecting to use:
 
   use File::Path 'rmtree';
 
 
   use File::Path 'rmtree';
 

-=head3 HEURISTICS
-
-The functions detect (as far as possible) which way they are being
-called and will act appropriately. It is important to remember that
-the heuristic for detecting the old style is either the presence
-of an array reference, or two or three parameters total and second
-and third parameters are numeric. Hence...
-
-    mkpath 486, 487, 488;
-
-... will not assume the modern style and create three directories, rather
-it will create one directory verbosely, setting the permission to
-0750 (488 being the decimal equivalent of octal 750). Here, old
-style trumps new. It must, for backwards compatibility reasons.
+The routines C<make_path> and C<remove_tree> are B<not> exported
+by default. You must specify which ones you want to use.

 
 

-If you want to ensure there is absolutely no ambiguity about which
-way the function will behave, make sure the first parameter is a
-reference to a one-element list, to force the old style interpretation:
+  use File::Path 'remove_tree';

 
 

-    mkpath [486], 487, 488;
+Note that a side-effect of the above is that C<mkpath> and C<rmtree>
+are no longer exported at all. This is due to the way the C<Exporter>
+module works. If you are migrating a codebase to use the new
+interface, you will have to list everything explicitly. But that's
+just good practice anyway.

 
 

-and get only one directory created. Or add a reference to an empty
-parameter hash, to force the new style:
-
-    mkpath 486, 487, 488, {};
-
-... and hence create the three directories. If the empty hash
-reference seems a little strange to your eyes, or you suspect a
-subsequent programmer might I<helpfully> optimise it away, you
-can add a parameter set to a default value:
-
-    mkpath 486, 487, 488, {verbose => 0};
+  use File::Path qw(remove_tree rmtree);

 
 =head3 SECURITY CONSIDERATIONS
 
 
 =head3 SECURITY CONSIDERATIONS
 


@@ -757,7 +793,7 @@ begin deleting the objects therein, but was unsuccessful. This is
 usually a permissions issue. The routine will continue to delete
 other things, but this directory will be left intact.
 
 usually a permissions issue. The routine will continue to delete
 other things, but this directory will be left intact.
 

-=item directory [dir] changed before chdir, expected dev=[n] inode=[n], actual dev=[n] ino=[n], aborting. (FATAL)
+=item directory [dir] changed before chdir, expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL)

 
 C<rmtree> recorded the device and inode of a directory, and then
 moved into it. It then performed a C<stat> on the current directory
 
 C<rmtree> recorded the device and inode of a directory, and then
 moved into it. It then performed a C<stat> on the current directory


@@ -786,11 +822,20 @@ 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.
 
 to restore its permissions to the original state but failed. The
 directory may wind up being left behind.
 

+=item cannot remove [dir] when cwd is [dir]
+
+The current working directory of the program is F</some/path/to/here>
+and you are attempting to remove an ancestor, such as F</some/path>.
+The directory tree is left untouched.
+
+The solution is to C<chdir> out of the child directory to a place
+outside the directory tree to be removed.
+

 =item cannot chdir to [parent-dir] from [child-dir]: [errmsg], aborting. (FATAL)
 
 C<rmtree>, after having deleted everything and restored the permissions
 =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.
+of a directory, was unable to chdir back to the parent. The program
+halts to avoid a race condition from occurring.

 
 =item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL)
 
 
 =item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL)
 


@@ -799,7 +844,7 @@ 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>.
 
 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)
+=item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] ino=[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
 
 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


@@ -881,14 +926,13 @@ are greatly appreciated.
 
 =head1 AUTHORS
 
 
 =head1 AUTHORS
 

-Tim Bunce <F<Tim.Bunce@ig.co.uk>> and Charles Bailey
-<F<bailey@newman.upenn.edu>>. Currently maintained by David Landgren
+Tim Bunce and Charles Bailey. Currently maintained by David Landgren

 <F<david@landgren.net>>.
 
 =head1 COPYRIGHT
 
 This module is copyright (C) Charles Bailey, Tim Bunce and
 <F<david@landgren.net>>.
 
 =head1 COPYRIGHT
 
 This module is copyright (C) Charles Bailey, Tim Bunce and

-David Landgren 1995-2007.  All rights reserved.
+David Landgren 1995-2008. All rights reserved.

 
 =head1 LICENSE
 
 
 =head1 LICENSE
 

diff --git a/lib/File/Path.t b/lib/File/Path.t
index f1b5928..b66b28d 100755 (executable)
--- a/lib/File/Path.t
+++ b/lib/File/Path.t
@@ -2,10 +2,11 @@
 
 use strict;
 
 
 use strict;
 

-use Test::More tests => 99;
+use Test::More tests => 114;

 
 BEGIN {
 
 BEGIN {

-    use_ok('File::Path');
+    use_ok('Cwd');
+    use_ok('File::Path', qw(rmtree mkpath make_path remove_tree));

     use_ok('File::Spec::Functions');
 }
 
     use_ok('File::Spec::Functions');
 }
 


@@ -45,7 +46,7 @@ my @dir = (
 );
 
 # create them
 );
 
 # create them

-my @created = mkpath(@dir);
+my @created = mkpath([@dir]);

 
 is(scalar(@created), 7, "created list of directories");
 
 
 is(scalar(@created), 7, "created list of directories");
 


@@ -79,18 +80,94 @@ is(scalar(@created), 0, "Can't create a directory named ''");
 my $dir;
 my $dir2;
 
 my $dir;
 my $dir2;
 

+sub gisle {
+    # background info: @_ = 1; !shift # gives '' not 0
+    # Message-Id: <3C820CE6-4400-4E91-AF43-A3D19B356E68@activestate.com>
+    # http://www.nntp.perl.org/group/perl.perl5.porters/2008/05/msg136625.html
+    mkpath(shift, !shift, 0755);
+}
+
+sub count {
+    opendir D, shift or return -1;
+    my $count = () = readdir D;
+    closedir D or return -1;
+    return $count;
+}
+
+{
+    mkdir 'solo', 0755;
+    chdir 'solo';
+    my $before = count(curdir());
+    cmp_ok($before, '>', 0, "baseline $before");
+
+    gisle('1st', 1);
+    is(count(curdir()), $before + 1, "first after $before");
+
+    $before = count(curdir());
+    gisle('2nd', 1);
+    is(count(curdir()), $before + 1, "second after $before");
+
+    chdir updir();
+    rmtree 'solo';
+}
+
+{
+    mkdir 'solo', 0755;
+    chdir 'solo';
+    my $before = count(curdir());
+    cmp_ok($before, '>', 0, "ARGV $before");
+    {
+        local @ARGV = (1);
+        mkpath('3rd', !shift, 0755);
+    }
+    is(count(curdir()), $before + 1, "third after $before");
+
+    $before = count(curdir());
+    {
+        local @ARGV = (1);
+        mkpath('4th', !shift, 0755);
+    }
+    is(count(curdir()), $before + 1, "fourth after $before");
+
+    chdir updir();
+    rmtree 'solo';
+}
+

 SKIP: {
 SKIP: {

-    $dir = catdir($tmp_base, 'B');
-    $dir2 = catdir($dir, updir());
-    # IOW: File::Spec->catdir( qw(foo bar), File::Spec->updir ) eq 'foo'
-    # rather than foo/bar/..    
-    skip "updir() canonicalises path on this platform", 2
-        if $dir2 eq $tmp_base
-            or $^O eq 'cygwin';
+    # tests for rmtree() of ancestor directory
+    my $nr_tests = 6;
+    my $cwd = getcwd() or skip "failed to getcwd: $!", $nr_tests;
+    my $dir  = catdir($cwd, 'remove');
+    my $dir2 = catdir($cwd, 'remove', 'this', 'dir');

         
         

-    @created = mkpath($dir2, {mask => 0700});
-    is(scalar(@created), 1, "make directory with trailing parent segment");
-    is($created[0], $dir, "made parent");
+    skip "failed to mkpath '$dir2': $!", $nr_tests
+        unless mkpath($dir2, {verbose => 0});
+    skip "failed to chdir dir '$dir2': $!", $nr_tests
+        unless chdir($dir2);
+
+    rmtree($dir, {error => \$error});
+    my $nr_err = @$error;
+    is($nr_err, 1, "ancestor error");
+
+    if ($nr_err) {
+        my ($file, $message) = each %{$error->[0]};
+        is($file, $dir, "ancestor named");
+        my $ortho_dir = $^O eq 'MSWin32' ? File::Path::_slash_lc($dir2) : $dir2;
+        $^O eq 'MSWin32' and $message
+            =~ s/\A(cannot remove path when cwd is )(.*)\Z/$1 . File::Path::_slash_lc($2)/e;
+        is($message, "cannot remove path when cwd is $ortho_dir", "ancestor reason");
+        ok(-d $dir2, "child not removed");
+        ok(-d $dir, "ancestor not removed");
+    }
+    else {
+        fail( "ancestor 1");
+        fail( "ancestor 2");
+        fail( "ancestor 3");
+        fail( "ancestor 4");
+    }
+    chdir $cwd;
+    rmtree($dir);
+    ok(!(-d $dir), "ancestor now removed");

 };
 
 my $count = rmtree({error => \$error});
 };
 
 my $count = rmtree({error => \$error});


@@ -104,7 +181,7 @@ is(scalar(@created), 0, "skipped making existing directories (old style 1)")
 $dir = catdir($tmp_base,'C');
 # mkpath returns unix syntax filespecs on VMS
 $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 $dir = catdir($tmp_base,'C');
 # mkpath returns unix syntax filespecs on VMS
 $dir = VMS::Filespec::unixify($dir) if $Is_VMS;

-@created = mkpath($tmp_base, $dir);
+@created = make_path($tmp_base, $dir);

 is(scalar(@created), 1, "created directory (new style 1)");
 is($created[0], $dir, "created directory (new style 1) cross-check");
 
 is(scalar(@created), 1, "created directory (new style 1)");
 is($created[0], $dir, "created directory (new style 1) cross-check");
 


@@ -115,7 +192,7 @@ is(scalar(@created), 0, "skipped making existing directories (old style 2)")
 $dir2 = catdir($tmp_base,'D');
 # mkpath returns unix syntax filespecs on VMS
 $dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS;
 $dir2 = catdir($tmp_base,'D');
 # mkpath returns unix syntax filespecs on VMS
 $dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS;

-@created = mkpath($tmp_base, $dir, $dir2);
+@created = make_path($tmp_base, $dir, $dir2);

 is(scalar(@created), 1, "created directory (new style 2)");
 is($created[0], $dir2, "created directory (new style 2) cross-check");
 
 is(scalar(@created), 1, "created directory (new style 2)");
 is($created[0], $dir2, "created directory (new style 2) cross-check");
 


@@ -135,7 +212,7 @@ cmp_ok(scalar(@created), '>=', 1, "made one or more dirs because of ..");
 cmp_ok(scalar(@created), '<=', 2, "made less than two dirs because of ..");
 ok( -d catdir($tmp_base, 'Y'), "directory after parent" );
 
 cmp_ok(scalar(@created), '<=', 2, "made less than two dirs because of ..");
 ok( -d catdir($tmp_base, 'Y'), "directory after parent" );
 

-@created = mkpath(catdir(curdir(), $tmp_base));
+@created = make_path(catdir(curdir(), $tmp_base));

 is(scalar(@created), 0, "nothing created")
     or diag(@created);
 
 is(scalar(@created), 0, "nothing created")
     or diag(@created);
 


@@ -195,22 +272,22 @@ else {
 $dir   = catdir('a', 'd1');
 $dir2  = catdir('a', 'd2');
 
 $dir   = catdir('a', 'd1');
 $dir2  = catdir('a', 'd2');
 

-@created = mkpath( $dir, 0, $dir2 );
+@created = make_path( $dir, 0, $dir2 );

 is(scalar @created, 3, 'new-style 3 dirs created');
 
 is(scalar @created, 3, 'new-style 3 dirs created');
 

-$count = rmtree( $dir, 0, $dir2, );
+$count = remove_tree( $dir, 0, $dir2, );

 is($count, 3, 'new-style 3 dirs removed');
 
 is($count, 3, 'new-style 3 dirs removed');
 

-@created = mkpath( $dir, $dir2, 1 );
+@created = make_path( $dir, $dir2, 1 );

 is(scalar @created, 3, 'new-style 3 dirs created (redux)');
 
 is(scalar @created, 3, 'new-style 3 dirs created (redux)');
 

-$count = rmtree( $dir, $dir2, 1 );
+$count = remove_tree( $dir, $dir2, 1 );

 is($count, 3, 'new-style 3 dirs removed (redux)');
 
 is($count, 3, 'new-style 3 dirs removed (redux)');
 

-@created = mkpath( $dir, $dir2 );
+@created = make_path( $dir, $dir2 );

 is(scalar @created, 2, 'new-style 2 dirs created');
 
 is(scalar @created, 2, 'new-style 2 dirs created');
 

-$count = rmtree( $dir, $dir2 );
+$count = remove_tree( $dir, $dir2 );

 is($count, 2, 'new-style 2 dirs removed');
 
 if (chdir updir()) {
 is($count, 2, 'new-style 2 dirs removed');
 
 if (chdir updir()) {


@@ -220,6 +297,42 @@ else {
     fail("chdir parent: $!");
 }
 
     fail("chdir parent: $!");
 }
 

+SKIP: {
+    # test bug http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=487319
+    skip "Don't need Force_Writeable semantics on $^O", 4
+        if grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
+    $dir  = 'bug487319';
+    $dir2 = 'bug487319-symlink';
+    @created = make_path($dir, {mask => 0700});
+    is(scalar @created, 1, 'bug 487319 setup');
+    symlink($dir, $dir2);
+    ok(-e $dir2, "debian bug 487319 setup symlink") or diag($dir2);
+
+    chmod 0500, $dir;
+    my $mask_initial = (stat $dir)[2];
+    remove_tree($dir2);
+
+    my $mask = (stat $dir)[2];
+    is( $mask, $mask_initial, 'mask of symlink target dir unchanged (debian bug 487319)');
+
+    # now try a file
+    my $file = catfile($dir, 'file');
+    open my $out, '>', $file;
+    close $out;
+
+    chmod 0500, $file;
+    $mask_initial = (stat $file)[2];
+
+    my $file2 = catfile($dir, 'symlink');
+    symlink($file, $file2);
+    remove_tree($file2);
+
+    $mask = (stat $file)[2];
+    is( $mask, $mask_initial, 'mask of symlink target file unchanged (debian bug 487319)');
+
+    remove_tree($dir);
+}
+

 # see what happens if a file exists where we want a directory
 SKIP: {
     my $entry = catdir($tmp_base, "file");
 # see what happens if a file exists where we want a directory
 SKIP: {
     my $entry = catdir($tmp_base, "file");


@@ -355,8 +468,8 @@ cannot restore permissions to \d+ for [^:]+: .* at \1 line \2},
         "rmtree of empty dir carps sensibly"
     );
 
         "rmtree of empty dir carps sensibly"
     );
 

-    stderr_is( sub { mkpath() }, '', "mkpath no args does not carp" );
-    stderr_is( sub { rmtree() }, '', "rmtree no args does not carp" );
+    stderr_is( sub { make_path() }, '', "make_path no args does not carp" );
+    stderr_is( sub { remove_tree() }, '', "remove_tree no args does not carp" );

 
     stdout_is(
         sub {@created = mkpath($dir, 1)},
 
     stdout_is(
         sub {@created = mkpath($dir, 1)},