File perl-file_path_rmtree_fchmod.diff of Package perl.openSUSE_Leap_42.3_Update

Overview Repositories Revisions Requests Users Attributes Meta

File perl-file_path_rmtree_fchmod.diff of Package perl.openSUSE_Leap_42.3_Update

--- ./cpan/File-Path/lib/File/Path.pm.orig	2013-11-04 15:15:37.000000000 +0000
+++ ./cpan/File-Path/lib/File/Path.pm	2017-10-26 09:10:04.278497074 +0000
@@ -284,13 +284,32 @@ sub _rmtree {
             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;
+                # This uses fchmod to avoid traversing outside of the proper
+                # location (CVE-2017-6512)
+                my $root_fh;
+                if (open($root_fh, '<', $root)) {
+                    my ($fh_dev, $fh_inode) = (stat $root_fh )[0,1];
+                    $perm &= oct '7777';
+                    my $nperm = $perm | oct '700';
+                    local $@;
+                    if (
+                        !(
+                            $arg->{safe}
+                            or $nperm == $perm
+                            or !-d _
+                            or $fh_dev ne $ldev
+                            or $fh_inode ne $lino
+                            or eval { chmod( $nperm, $root_fh ) }
+                         )
+                       )
+                    {
+                        _error($arg,
+                            "cannot make child directory read-write-exec", $canon);
+                        next ROOT_DIR;
+                    }
+                    close $root_fh;
                 }
-                elsif (!chdir($root)) {
+                if (!chdir($root) ) {
                     _error($arg, "cannot chdir to child", $canon);
                     next ROOT_DIR;
                 }
--- ./cpan/File-Path/t/Path.t.orig	2017-10-26 09:10:23.446441463 +0000
+++ ./cpan/File-Path/t/Path.t	2017-10-26 09:10:46.539374461 +0000
@@ -261,10 +261,10 @@ is(rmtree($dir, 0, undef), 1, "removed d
 $dir = catdir($tmp_base,'G');
 $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 
-@created = mkpath($dir, undef, 0200);
-is(scalar(@created), 1, "created write-only dir");
-is($created[0], $dir, "created write-only directory cross-check");
-is(rmtree($dir), 1, "removed write-only dir");
+@created = mkpath($dir, undef, 0400);
+is(scalar(@created), 1, "created read-only dir");
+is($created[0], $dir, "created read-only directory cross-check");
+is(rmtree($dir), 1, "removed read-only dir");
 
 # borderline new-style heuristics
 if (chdir $tmp_base) {
--- ./dist/ExtUtils-Command/t/eu_command.t.orig	2017-10-26 09:11:01.918329840 +0000
+++ ./dist/ExtUtils-Command/t/eu_command.t	2017-10-26 09:11:51.555186229 +0000
@@ -151,19 +151,19 @@ BEGIN {
         is( ((stat('testdir'))[2] & 07777) & 0700,
             0100, 'change a dir to execute-only' );
 
-        # change a dir to read-only
-        @ARGV = ( '0400', 'testdir' );
+        # change a dir to write-only
+        @ARGV = ( '0200', 'testdir' );
         ExtUtils::Command::chmod();
 
         is( ((stat('testdir'))[2] & 07777) & 0700,
-            ($^O eq 'vos' ? 0500 : 0400), 'change a dir to read-only' );
+            ($^O eq 'vos' ? 0700 : 0200), 'change a dir to write-only' );
 
-        # change a dir to write-only
-        @ARGV = ( '0200', 'testdir' );
+        # change a dir to read-only
+        @ARGV = ( '0400', 'testdir' );
         ExtUtils::Command::chmod();
 
         is( ((stat('testdir'))[2] & 07777) & 0700,
-            ($^O eq 'vos' ? 0700 : 0200), 'change a dir to write-only' );
+            ($^O eq 'vos' ? 0500 : 0400), 'change a dir to read-only' );
 
         @ARGV = ('testdir');
         rm_rf;

Places

File perl-file_path_rmtree_fchmod.diff of Package perl.openSUSE_Leap_42.3_Update

Places