perl/perl-5.8.7-can_2005_0448.patch

--- perl-5.8.7/lib/File/Path.pm	2005-05-05 18:00:32.000000000 +0200
+++ perl-5.8.7-fix/lib/File/Path.pm	2005-06-06 11:19:45.000000000 +0200
@@ -72,33 +72,17 @@
 
 =item *
 
-a boolean value, which if TRUE will cause C<rmtree> to
-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)
+a boolean value, which if FALSE (the default for non-root users) will
+cause C<rmtree> to adjust the mode of directories (if required) prior
+to attempting to remove the contents.  Note that on interruption or
+failure of C<rmtree>, directories may be left with more permissive
+modes for the owner.
 
 =back
 
 It returns the number of files successfully deleted.  Symlinks are
 simply deleted and not followed.
 
-B<NOTE:> There are race conditions internal to the implementation of
-C<rmtree> making it unsafe to use on directory trees which may be
-altered or moved while C<rmtree> is running, and in particular on any
-directory trees with any path components or subdirectories potentially
-writable by untrusted users.
-
-Additionally, if the third parameter is not TRUE and C<rmtree> is
-interrupted, it may leave files and directories with permissions altered
-to allow deletion (and older versions of this module would even set
-files and directories to world-read/writable!)
-
-Note also that the occurrence of errors in C<rmtree> can be determined I<only>
-by trapping diagnostic messages using C<$SIG{__WARN__}>; it is not apparent
-from the return value.
-
 =head1 DIAGNOSTICS
 
 =over 4
@@ -124,6 +108,7 @@
 use Exporter ();
 use strict;
 use warnings;
+use Cwd 'getcwd';
 
 our $VERSION = "1.07";
 our @ISA = qw( Exporter );
@@ -172,111 +157,128 @@
     @created;
 }
 
-sub rmtree {
-    my($roots, $verbose, $safe) = @_;
-    my(@files);
-    my($count) = 0;
-    $verbose ||= 0;
-    $safe ||= 0;
-
-    if ( defined($roots) && length($roots) ) {
-      $roots = [$roots] unless ref $roots;
-    }
-    else {
-      carp "No root path(s) specified\n";
-      return 0;
-    }
-
-    my($root);
-    foreach $root (@{$roots}) {
-    	if ($Is_MacOS) {
-	    $root = ":$root" if $root !~ /:/;
-	    $root =~ s#([^:])\z#$1:#;
-	} else {
-	    $root =~ s#/\z##;
+sub _rmtree;
+sub _rmtree
+{
+    my ($path, $prefix, $up, $up_dev, $up_ino, $verbose, $safe) = @_;
+
+    my ($dev, $ino) = lstat $path or return 0;
+    unless (-d _)
+    {
+	print "unlink $prefix$path\n" if $verbose;
+	unless (unlink $path)
+	{
+	    carp "Can't remove file $prefix$path ($!)";
+	    return 0;
 	}
-	(undef, undef, my $rp) = lstat $root or next;
-	$rp &= 07777;	# don't forget setuid, setgid, sticky bits
-	if ( -d _ ) {
-	    # 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
-	    chmod($rp | 0700, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
-	      or carp "Can't make directory $root read+writeable: $!"
-		unless $safe;
-
-	    if (opendir my $d, $root) {
-		no strict 'refs';
-		if (!defined ${"\cTAINT"} or ${"\cTAINT"}) {
-		    # Blindly untaint dir names
-		    @files = map { /^(.*)$/s ; $1 } readdir $d;
-		} else {
-		    @files = readdir $d;
-		}
-		closedir $d;
-	    }
-	    else {
-	        carp "Can't read $root: $!";
-		@files = ();
-	    }
+	return 1;
+    }
 
-	    # Deleting large numbers of files from VMS Files-11 filesystems
-	    # is faster if done in reverse ASCIIbetical order 
-	    @files = reverse @files if $Is_VMS;
-	    ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS;
-	    if ($Is_MacOS) {
-		@files = map("$root$_", @files);
-	    } else {
-		@files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files);
-	    }
-	    $count += rmtree(\@files,$verbose,$safe);
-	    if ($safe &&
-		($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
-		print "skipped $root\n" if $verbose;
-		next;
-	    }
-	    chmod $rp | 0700, $root
-	      or carp "Can't make directory $root writeable: $!"
-		if $force_writeable;
-	    print "rmdir $root\n" if $verbose;
-	    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 &&
-		($Is_VMS ? !&VMS::Filespec::candelete($root)
-		         : !(-l $root || -w $root)))
-	    {
-		print "skipped $root\n" if $verbose;
-		next;
-	    }
-	    chmod $rp | 0600, $root
-	      or carp "Can't make file $root writeable: $!"
-		if $force_writeable;
-	    print "unlink $root\n" if $verbose;
-	    # delete all versions under VMS
-	    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;
-	    }
+    unless (chdir $path)
+    {
+	carp "Can't chdir to $prefix$path ($!)";
+	return 0;
+    }
+
+    # avoid a race condition where a directory may be replaced by a
+    # symlink between the lstat and the chdir
+    my ($new_dev, $new_ino, $perm) = stat '.';
+    unless ("$new_dev:$new_ino" eq "$dev:$ino")
+    {
+	croak "Directory $prefix$path changed before chdir, aborting";
+    }
+
+    $perm &= 07777;
+    my $nperm = $perm | 0700;
+    unless ($safe or $nperm == $perm or chmod $nperm, '.')
+    {
+	carp "Can't make directory $prefix$path read+writeable ($!)";
+	$nperm = $perm;
+    }
+
+    my $count = 0;
+    if (opendir my $dir, '.')
+    {
+	my $entry;
+	while (defined ($entry = readdir $dir))
+	{
+	    next if $entry =~ /^\.\.?$/;
+	    $entry =~ /^(.*)$/s; $entry = $1; # untaint
+	    $count += _rmtree $entry, "$prefix$path/", '..', $dev, $ino,
+		$verbose, $safe;
 	}
+
+	closedir $dir;
+    }
+
+    # restore directory permissions if required (in case the rmdir
+    # below fails) now, while we're still in the directory and may do
+    # so without a race via '.'
+    unless ($nperm == $perm or chmod $perm, '.')
+    {
+	carp "Can't restore permissions on directory $prefix$path ($!)";
+    }
+
+    # don't leave the caller in an unexpected directory
+    unless (chdir $up)
+    {
+	croak "Can't return to $up from $prefix$path ($!)";
+    }
+
+    # ensure that a chdir ..  didn't take us somewhere other than
+    # where we expected (see CVE-2002-0435)
+    unless (($new_dev, $new_ino) = stat '.'
+	and "$new_dev:$new_ino" eq "$up_dev:$up_ino")
+    {
+	croak "Previous directory $up changed since entering $prefix$path";
+    }
+
+    print "rmdir $prefix$path\n" if $verbose;
+    if (rmdir $path)
+    {
+	$count++;
+    }
+    else
+    {
+	carp "Can't remove directory $prefix$path ($!)";
+    }
+
+    return $count;
+}
+
+sub rmtree
+{
+    my ($p, $verbose, $safe) = @_;
+    $p = [] unless defined $p and length $p;
+    $p = [ $p ] unless ref $p;
+    my @paths = grep defined && length, @$p;
+
+    # default to "unsafe" for non-root (will chmod dirs)
+    $safe = $> ? 0 : 1 unless defined $safe;
+
+    unless (@paths)
+    {
+	carp "No root path(s) specified";
+	return;
+    }
+
+    my $oldpwd = getcwd or do {
+	carp "Can't fetch initial working directory";
+	return;
+    };
+
+    my ($dev, $ino) = stat '.' or do {
+	carp "Can't stat initial working directory";
+	return;
+    };
+
+    # untaint
+    for ($oldpwd) { /^(.*)$/s; $_ = $1 }
+
+    my $count = 0;
+    for my $path (@paths)
+    {
+	$count += _rmtree $path, '', $oldpwd, $dev, $ino, $verbose, $safe;
     }
 
     $count;