From 2f154f3e5dd7fda13f2d920993cdeb70c1da4443 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 to File-Path 2.09 / perl 5.20 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 | 20 ++++++++++++++------
 cpan/File-Path/t/Path.t         | 24 +++++++++++++++++-------
 2 files changed, 31 insertions(+), 13 deletions(-)

diff --git a/cpan/File-Path/lib/File/Path.pm b/cpan/File-Path/lib/File/Path.pm
index 23751d5..0ea6671 100644
--- a/cpan/File-Path/lib/File/Path.pm
+++ b/cpan/File-Path/lib/File/Path.pm
@@ -284,13 +284,21 @@ 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 &= 07777;
+                    my $nperm = $perm | 0700;
+                    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 a33c15a..b6df00a 100644
--- a/cpan/File-Path/t/Path.t
+++ b/cpan/File-Path/t/Path.t
@@ -16,6 +16,13 @@ my $has_Test_Output = $@ ? 0 : 1;
 
 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) {
@@ -258,13 +265,16 @@ is(scalar(@created), 1, "created directory (old style 3 mode undef)");
 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;
-
-@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");
+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, 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) {