guix/gnu/packages/patches/perl-file-path-CVE-2017-6512.patch

Fix CVE-2017-6512:

https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2017-6512
https://rt.cpan.org/Public/Bug/Display.html?id=121951

Patch copied from Debian, adapted to apply to the copy of File::Path in Perl
5.24.0.

https://github.com/jkeenan/File-Path/commit/e5ef95276ee8ad471c66ee574a5d42552b3a6af2
https://anonscm.debian.org/cgit/perl/perl.git/diff/debian/patches/fixes/file_path_chmod_race.diff?id=e7b50f8fb6413f8ddfbbfda2d531615fb029e2d3

From d760748be0efca7c05454440e24f3df77bf7cf5d Mon Sep 17 00:00:00 2001
From: John Lightsey <john@nixnuts.net>
Date: Tue, 2 May 2017 12:03:52 -0500
Subject: Prevent directory chmod race attack.

CVE-2017-6512 is a race condition attack where the chmod() of directories
that cannot be entered is misused to change the permissions on other
files or directories on the system. This has been corrected by limiting
the directory-permission loosening logic to systems where fchmod() is
supported.

[Backported (whitespace adjustments) to File-Path 2.12 / perl 5.24 by
Dominic Hargreaves for Debian.]

Bug: https://rt.cpan.org/Public/Bug/Display.html?id=121951
Bug-Debian: https://bugs.debian.org/863870
Patch-Name: fixes/file_path_chmod_race.diff
---
 cpan/File-Path/lib/File/Path.pm | 39 +++++++++++++++++++++++++--------------
 cpan/File-Path/t/Path.t         | 40 ++++++++++++++++++++++++++--------------
 2 files changed, 51 insertions(+), 28 deletions(-)

diff --git a/cpan/File-Path/lib/File/Path.pm b/cpan/File-Path/lib/File/Path.pm
index 034da1e..a824cc8 100644
--- a/cpan/File-Path/lib/File/Path.pm
+++ b/cpan/File-Path/lib/File/Path.pm
@@ -354,21 +354,32 @@ sub _rmtree {
 
                 # see if we can escalate privileges to get in
                 # (e.g. funny protection mask such as -w- instead of rwx)
-                $perm &= oct '7777';
-                my $nperm = $perm | oct '700';
-                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;
                 }
diff --git a/cpan/File-Path/t/Path.t b/cpan/File-Path/t/Path.t
index ff52fd6..956ca09 100644
--- a/cpan/File-Path/t/Path.t
+++ b/cpan/File-Path/t/Path.t
@@ -3,7 +3,7 @@
 
 use strict;
 
-use Test::More tests => 127;
+use Test::More tests => 126;
 use Config;
 use Fcntl ':mode';
 use lib 't/';
@@ -18,6 +18,13 @@ BEGIN {
 
 my $Is_VMS = $^O eq 'VMS';
 
+my $fchmod_supported = 0;
+if (open my $fh, curdir()) {
+    my ($perm) = (stat($fh))[2];
+    $perm &= 07777;
+    eval { $fchmod_supported = chmod( $perm, $fh); };
+}
+
 # first check for stupid permissions second for full, so we clean up
 # behind ourselves
 for my $perm (0111,0777) {
@@ -299,16 +306,19 @@ is($created[0], $dir, "created directory (old style 3 mode undef) cross-check");
 
 is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef");
 
-$dir = catdir($tmp_base,'G');
-$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
+SKIP: {
+    skip "fchmod of directories not supported on this platform", 3 unless $fchmod_supported;
+    $dir = catdir($tmp_base,'G');
+    $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 
-@created = mkpath($dir, undef, 0200);
+    @created = mkpath($dir, undef, 0400);
 
-is(scalar(@created), 1, "created write-only dir");
+    is(scalar(@created), 1, "created read-only dir");
 
-is($created[0], $dir, "created write-only directory cross-check");
+    is($created[0], $dir, "created read-only directory cross-check");
 
-is(rmtree($dir), 1, "removed write-only dir");
+    is(rmtree($dir), 1, "removed read-only dir");
+}
 
 # borderline new-style heuristics
 if (chdir $tmp_base) {
@@ -450,26 +460,28 @@ SKIP: {
 }
 
 SKIP : {
-    my $skip_count = 19;
+    my $skip_count = 18;
     # this test will fail on Windows, as per:
     #   http://perldoc.perl.org/perlport.html#chmod
 
     skip "Windows chmod test skipped", $skip_count
         if $^O eq 'MSWin32';
+    skip "fchmod() on directories is not supported on this platform", $skip_count
+        unless $fchmod_supported;
     my $mode;
     my $octal_mode;
     my @inputs = (
-      0777, 0700, 0070, 0007,
-      0333, 0300, 0030, 0003,
-      0111, 0100, 0010, 0001,
-      0731, 0713, 0317, 0371, 0173, 0137,
-      00 );
+      0777, 0700, 0470, 0407,
+      0433, 0400, 0430, 0403,
+      0111, 0100, 0110, 0101,
+      0731, 0713, 0317, 0371,
+      0173, 0137);
     my $input;
     my $octal_input;
-    $dir = catdir($tmp_base, 'chmod_test');
 
     foreach (@inputs) {
         $input = $_;
+        $dir = catdir($tmp_base, sprintf("chmod_test%04o", $input));
         # We can skip from here because 0 is last in the list.
         skip "Mode of 0 means assume user defaults on VMS", 1
           if ($input == 0 && $Is_VMS);