[perl #72098] File::Copy stripping 06000 perms on cp for root

The problem is with the use of cp when perms & 06000.

There is logic that checks to see if the target file is owned by the
user ($>) running the copy and/or if $> is a member of the group that
owns the target file. If this is not the case, then the 06000 bits are
masked out before the chmod is called after the copy.

This is mostly good logic except when root is executing this, in which
case root should get to do whatever it wants to do.

Looking closer at the code to test for group membership, I think it can
be more easily and more cheaply be written using $). I've added this
change to the patch.

This will also fix the problem where someone has a group membership
based on /etc/passwd and is not mentioned in /etc/group.

1 files changed, 2 insertions, 6 deletions

diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm
index 83d7a25c67..c2fdab2e21 100644
--- a/lib/File/Copy.pm
+++ b/lib/File/Copy.pm
@@ -313,14 +313,10 @@ sub cp {
 	    $perm &= ~06000;
 	}
 
-	if ($perm & 02000) {                      # setgid
+	if ($perm & 02000 && $> != 0) {           # if not root, setgid
 	    my $ok = $fromstat[5] == $tostat[5];  # group must match
 	    if ($ok) {                            # and we must be in group
-	        my $uname = (getpwuid($>))[0] || '';
-                my $group = (getpwuid($>))[3];
-                $ok = $group && $group == $fromstat[5] ||
-                      grep { $_ eq $uname }
-                             split /\s+/, (getgrgid($fromstat[5]))[3];
+                $ok = grep { $_ == $fromstat[5] } split /\s+/, $)
 	    }
 	    $perm &= ~06000 unless $ok;
 	}