add files and tweaks needed for MPE/iX port (via PM)

[p5sagit/p5-mst-13.2.git] / lib / File / Path.pm

diff --git a/lib/File/Path.pm b/lib/File/Path.pm
index e086028..39f1ba1 100644 (file)
--- a/lib/File/Path.pm
+++ b/lib/File/Path.pm
@@ -69,21 +69,30 @@ skip any files to which you do not have delete access
 (if running under VMS) or write access (if running
 under another OS).  This will change in the future when
 a criterion for 'delete permission' under OSs other
-than VMS is settled. (defaults to FALSE)
+than VMS is settled.  (defaults to FALSE)
 
 =back
 
-It returns the number of files successfully deleted. Symlinks are
+It returns the number of files successfully deleted.  Symlinks are
 treated as ordinary files.
 
+B<NOTE:> If the third parameter is not TRUE, C<rmtree> is B<unsecure>
+in the face of failure or interruption.  Files and directories which
+were not deleted may be left with permissions reset to allow world
+read and write access.  Note also that the occurrence of errors in
+rmtree can be determined I<only> by trapping diagnostic messages
+using C<$SIG{__WARN__}>; it is not apparent from the return value.
+Therefore, you must be extremely careful about using C<rmtree($foo,$bar,0>
+in situations where security is an issue.
+
 =head1 AUTHORS
 
-Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt>
-Charles Bailey E<lt>F<bailey@genetics.upenn.edu>E<gt>
+Tim Bunce <F<Tim.Bunce@ig.co.uk>> and
+Charles Bailey <F<bailey@genetics.upenn.edu>>
 
 =head1 REVISION
 
-Current $VERSION is 1.02.
+Current $VERSION is 1.0401.
 
 =cut
 
@@ -94,7 +103,7 @@ use Exporter ();
 use strict;
 
 use vars qw( $VERSION @ISA @EXPORT );
-$VERSION = "1.02";
+$VERSION = "1.0401";
 @ISA = qw( Exporter );
 @EXPORT = qw( mkpath rmtree );
 
@@ -102,7 +111,7 @@ my $Is_VMS = $^O eq 'VMS';
 
 # 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 'msdos' || $^O eq 'MSWin32'
+my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32'
                       || $^O eq 'amigaos');
 
 sub mkpath {
@@ -115,13 +124,20 @@ sub mkpath {
     $paths = [$paths] unless ref $paths;
     my(@created,$path);
     foreach $path (@$paths) {
+       $path .= '/' if $^O eq 'os2' and $path =~ /^\w:$/; # feature of CRT 
        next if -d $path;
        # Logic wants Unix paths, so go with the flow.
        $path = VMS::Filespec::unixify($path) if $Is_VMS;
        my $parent = File::Basename::dirname($path);
-       push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent);
+       # Allow for creation of new logical filesystems under VMS
+       if (not $Is_VMS or $parent !~ m:/[^/]+/000000/?:) {
+           push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent);
+       }
        print "mkdir $path\n" if $verbose;
-       mkdir($path,$mode) || croak "mkdir $path: $!";
+       unless (mkdir($path,$mode)) {
+           # allow for another process to have created it meanwhile
+           croak "mkdir $path: $!" unless -d $path;
+       }
        push(@created, $path);
     }
     @created;
@@ -138,13 +154,14 @@ sub rmtree {
     my($root);
     foreach $root (@{$roots}) {
        $root =~ s#/$##;
-       $count++, next unless -e $root;
-       if (not -l $root and -d _) {
+       (undef, undef, my $rp) = lstat $root or next;
+       $rp &= 07777;   # don't forget setuid, setgid, sticky bits
+       if ( -d _ ) {
            # notabene: 0777 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
-           chmod 0777, $root
+           chmod(0777, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
              or carp "Can't make directory $root read+writeable: $!"
                unless $safe;
 
@@ -168,8 +185,15 @@ sub rmtree {
              or carp "Can't make directory $root writeable: $!"
                if $force_writeable;
            print "rmdir $root\n" if $verbose;
-           rmdir($root) && ++$count
-             or carp "Can't remove directory $root: $!";
+           if (rmdir $root) {
+               ++$count;
+           }
+           else {
+               carp "Can't remove directory $root: $!";
+               chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
+                   or carp("and can't restore permissions to "
+                           . sprintf("0%o",$rp) . "\n");
+           }
        }
        else { 
            if ($safe &&
@@ -182,9 +206,18 @@ sub rmtree {
                if $force_writeable;
            print "unlink $root\n" if $verbose;
            # delete all versions under VMS
-           while (-e $root || -l $root) {
-               unlink($root) && ++$count
-                 or croak "Can't unlink file $root: $!";
+           for (;;) {
+               unless (unlink $root) {
+                   carp "Can't unlink file $root: $!";
+                   if ($force_writeable) {
+                       chmod $rp, $root
+                           or carp("and can't restore permissions to "
+                                   . sprintf("0%o",$rp) . "\n");
+                   }
+                   last;
+               }
+               ++$count;
+               last unless $Is_VMS && lstat $root;
            }
        }
     }