gnu: perl: Fix CVE-2017-6512 in File::Path.

* gnu/packages/perl.scm (perl)[replacement]: New field.
(perl/fixed): New variable.
* gnu/packages/patches/perl-file-path-CVE-2017-6512.patch: New file.
* gnu/local.mk (dist_patch_DATA): Add it.

3 files changed, 187 insertions, 0 deletions

diff --git a/gnu/local.mk b/gnu/local.mk
index 4b2bdfe37a..ab3fbb2d39 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -884,6 +884,7 @@ dist_patch_DATA =						\
   %D%/packages/patches/pcre-CVE-2017-7186.patch			\
   %D%/packages/patches/pcre2-CVE-2017-7186.patch		\
   %D%/packages/patches/pcre2-CVE-2017-8786.patch		\
+  %D%/packages/patches/perl-file-path-CVE-2017-6512.patch	\
   %D%/packages/patches/perl-autosplit-default-time.patch	\
   %D%/packages/patches/perl-deterministic-ordering.patch	\
   %D%/packages/patches/perl-finance-quote-unuse-mozilla-ca.patch \
diff --git a/gnu/packages/patches/perl-file-path-CVE-2017-6512.patch b/gnu/packages/patches/perl-file-path-CVE-2017-6512.patch
new file mode 100644
index 0000000000..28ab067599
--- /dev/null
+++ b/gnu/packages/patches/perl-file-path-CVE-2017-6512.patch
@@ -0,0 +1,173 @@
+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);
diff --git a/gnu/packages/perl.scm b/gnu/packages/perl.scm
index e56c80609b..6da4bb13fd 100644
--- a/gnu/packages/perl.scm
+++ b/gnu/packages/perl.scm
@@ -51,6 +51,7 @@
   ;; Yeah, Perl...  It is required early in the bootstrap process by Linux.
   (package
     (name "perl")
+    (replacement perl/fixed)
     (version "5.24.0")
     (source (origin
              (method url-fetch)
@@ -147,6 +148,18 @@
     (home-page "http://www.perl.org/")
     (license gpl1+)))                          ; or "Artistic"
 
+(define perl/fixed
+  (package
+    (inherit perl)
+    (replacement #f)
+    (source
+      (origin
+        (inherit (package-source perl))
+        (patches
+          (append
+            (origin-patches (package-source perl))
+            (search-patches "perl-file-path-CVE-2017-6512.patch")))))))
+
 (define-public perl-algorithm-c3
   (package
     (name "perl-algorithm-c3")