Move cp(1)-like permission changes from copy to cp,

and add setid bit handling

- Moves the permission-changing code to File::Copy::cp(), making it
non-identical to File::Copy::copy().  I think this is a decent
compromise, retaining backwards compatibility in the "primary"
routine, while allowing people who chose cp() to get more POSIXy
semantics.  It does break backwards compatibility of cp() wrt
permissions.  I can find a handful of examples in CPAN, for which I
hope smokers will give some feedback.  As for the DARKpan, who knows .
. .

- Expands the permission changing in cp() a bit to cover the rest of
what cp(1) claims on the local POSIX box.

- Removes Fcntl from the mix, to eliminate some build-time hoops.

- Shifts Abigail's permission tests to cp(), and adds parallel tests for copy().

- Documents the permission-related behavior in more detail.

2 files changed, 90 insertions, 36 deletions

diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm
index 984ef799b6..fc37ee66de 100644
--- a/lib/File/Copy.pm
+++ b/lib/File/Copy.pm
@@ -12,9 +12,7 @@ use strict;
 use warnings;
 use File::Spec;
 use Config;
-# During perl build, we need File::Copy but Fcntl might not be built yet
-my $Fcntl_loaded = eval q{ use Fcntl qw [O_CREAT O_WRONLY O_TRUNC]; 1 };
-# Similarly Scalar::Util
+# During perl build, we need File::Copy but Scalar::Util might not be built yet
 # And then we need these games to avoid loading overload, as that will
 # confuse miniperl during the bootstrap of perl.
 my $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 };
@@ -229,7 +227,7 @@ sub copy {
     } else {
        open $from_h, "<", $from or goto fail_open1;
        binmode $from_h or die "($!,$^E)";
-	$closefrom = 1;
+       $closefrom = 1;
     }
 
     # Seems most logical to do this here, in case future changes would want to
@@ -245,15 +243,8 @@ sub copy {
        $to_h = $to;
     } else {
 	$to = _protect($to) if $to =~ /^\s/s;
-	if ($Fcntl_loaded) {
-	    my $perm = (stat $from_h) [2] & 0xFFF;
-	    sysopen $to_h, $to, O_CREAT() | O_TRUNC() | O_WRONLY(), $perm
-		or goto fail_open2;
-	}
-	else {
-	    $to_h = \do { local *FH };
-	    open $to_h, ">", $to or goto fail_open2;
-	}
+	$to_h = \do { local *FH };
+	open $to_h, ">", $to or goto fail_open2;
 	binmode $to_h or die "($!,$^E)";
 	$closeto = 1;
     }
@@ -295,10 +286,52 @@ sub copy {
     return 0;
 }
 
-sub move {
-    croak("Usage: move(FROM, TO) ") unless @_ == 2;
-
+sub cp {
     my($from,$to) = @_;
+    my(@fromstat) = stat $from;
+    my(@tostat) = stat $to;
+    my $perm;
+
+    return 0 unless copy(@_) and @fromstat;
+
+    if (@tostat) {
+        $perm = $tostat[2];
+    } else {
+        $perm = $fromstat[2] & ~(umask || 0);
+	@tostat = stat $to;
+    }
+    # Might be more robust to look for S_I* in Fcntl, but we're
+    # trying to avoid dependence on any XS-containing modules,
+    # since File::Copy is used during the Perl build.
+    $perm &= 07777;
+    if ($perm & 06000) {
+	croak("Unable to check setuid/setgid permissions for $to: $!")
+	    unless @tostat;
+
+	if ($perm & 04000 and                     # setuid
+	    $fromstat[4] != $tostat[4]) {         # owner must match
+	    $perm &= ~06000;
+	}
+
+	if ($perm & 02000) {                      # setgid
+	    my $ok = $fromstat[5] == $tostat[5];  # group must match
+	    if ($ok) {                            # and we must be in group
+	        my $uname = (getpwuid($>))[0] || '';
+		my(@members) = split /\s+/, (getgrgid($fromstat[5]))[3];
+		$ok = grep { $_ eq $uname } @members;
+	    }
+	    $perm &= ~06000 unless $ok;
+	}
+    }
+    return 0 unless @tostat;
+    return 1 if $perm == ($tostat[2] & 07777);
+    return eval { chmod $perm, $to; } ? 1 : 0;
+}
+
+sub _move {
+    croak("Usage: move(FROM, TO) ") unless @_ == 3;
+
+    my($from,$to,$fallback) = @_;
 
     my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
 
@@ -371,7 +404,7 @@ sub move {
         local $@;
         eval {
             local $SIG{__DIE__};
-            copy($from,$to) or die;
+            $fallback->($from,$to) or die;
             my($atime, $mtime) = (stat($from))[8,9];
             utime($atime, $mtime, $to);
             unlink($from)   or die;
@@ -386,8 +419,8 @@ sub move {
     return 0;
 }
 
-*cp = \&copy;
-*mv = \&move;
+sub move { _move(@_,\&copy); }
+sub mv   { _move(@_,\&cp);   }
 
 # &syscopy is an XSUB under OS/2
 unless (defined &syscopy) {
@@ -483,11 +516,15 @@ being written to the second file. The default buffer size depends
 upon the file, but will generally be the whole file (up to 2MB), or
 1k for filehandles that do not reference files (eg. sockets).
 
-You may use the syntax C<use File::Copy "cp"> to get at the
-"cp" alias for this function. The syntax is I<exactly> the same.
-
-As of version 2.14, on UNIX systems, "copy" will preserve permission
-bits like the shell utility C<cp> would do.
+You may use the syntax C<use File::Copy "cp"> to get at the C<cp>
+alias for this function. The syntax is I<exactly> the same.  The
+behavior is nearly the same as well: as of version 2.14, <cp> will
+preserve the source file's permission bits like the shell utility
+C<cp(1)> would do, while C<copy> uses the default permissions for the
+target file (which may depend on the process' C<umask>, file
+ownership, inherited ACLs, etc.).  If an error occurs in setting
+permissions, C<cp> will return 0, regardless of whether the file was
+successfully copied.
 
 =item move
 X<move> X<mv> X<rename>
@@ -503,8 +540,8 @@ the file to the new location and deletes the original.  If an error occurs
 during this copy-and-delete process, you may be left with a (possibly partial)
 copy of the file under the destination name.
 
-You may use the "mv" alias for this function in the same way that
-you may use the "cp" alias for C<copy>.
+You may use the C<mv> alias for this function in the same way that
+you may use the <cp> alias for C<copy>.
 
 =item syscopy
 X<syscopy>
diff --git a/lib/File/Copy.t b/lib/File/Copy.t
index fc1f860a64..687e129b52 100755
--- a/lib/File/Copy.t
+++ b/lib/File/Copy.t
@@ -14,14 +14,14 @@ use Test::More;
 
 my $TB = Test::More->builder;
 
-plan tests => 136;
+plan tests => 157;
 
 # We're going to override rename() later on but Perl has to see an override
 # at compile time to honor it.
 BEGIN { *CORE::GLOBAL::rename = sub { CORE::rename($_[0], $_[1]) }; }
 
 
-use File::Copy;
+use File::Copy qw(copy move cp);
 use Config;
 
 
@@ -228,8 +228,8 @@ for my $cross_partition_test (0..1) {
 
 SKIP: {
 
-    skip "-- Copy preserves RMS defaults, not source file permissions.", 21 if $^O eq 'VMS';
-    skip "Copy doesn't set file permissions correctly on Win32.", 21 if $^O eq "MSWin32";
+    skip "-- Copy preserves RMS defaults, not POSIX permissions.", 42 if $^O eq 'VMS';
+    skip "Copy doesn't set file permissions correctly on Win32.", 42 if $^O eq "MSWin32";
 
     # Just a sub to get better failure messages.
     sub __ ($) {
@@ -241,6 +241,9 @@ SKIP: {
     my $copy1 = "copy1-$$";
     my $copy2 = "copy2-$$";
     my $copy3 = "copy3-$$";
+    my $copy4 = "copy4-$$";
+    my $copy5 = "copy5-$$";
+    my $copy6 = "copy6-$$";
 
     open my $fh => ">", $src   or die $!;
     close   $fh                or die $!;
@@ -248,6 +251,9 @@ SKIP: {
     open    $fh => ">", $copy3 or die $!;
     close   $fh                or die $!;
 
+    open    $fh => ">", $copy6 or die $!;
+    close   $fh                or die $!;
+
     my @tests = (
         [0000,  0777,  0777,  0777],
         [0000,  0751,  0751,  0644],
@@ -261,32 +267,43 @@ SKIP: {
     foreach my $test (@tests) {
         my ($umask, $s_perm, $c_perm1, $c_perm3) = @$test;
         # Make sure the copies doesn't exist.
-        ! -e $_ or unlink $_ or die $! for $copy1, $copy2;
+        ! -e $_ or unlink $_ or die $! for $copy1, $copy2, $copy4, $copy5;
 
-       (umask $umask) // die $!;
-        chmod $s_perm  => $src   or die $!;
+	(umask $umask) // die $!;
+        chmod $s_perm  => $src   or die sprintf "$!: $src => %o", $s_perm;
         chmod $c_perm3 => $copy3 or die $!;
+        chmod $c_perm3 => $copy6 or die $!;
 
         open my $fh => "<", $src or die $!;
 
         copy ($src, $copy1);
         copy ($fh,  $copy2);
         copy ($src, $copy3);
+        cp   ($src, $copy4);
+        cp   ($fh,  $copy5);
+        cp   ($src, $copy6);
 
+	my $permdef = 0666 & ~$umask;
         my $perm1 = (stat $copy1) [2] & 0xFFF;
         my $perm2 = (stat $copy2) [2] & 0xFFF;
         my $perm3 = (stat $copy3) [2] & 0xFFF;
-        is (__$perm1, __$c_perm1, "Permission bits set correctly");
-        is (__$perm2, __$c_perm1, "Permission bits set correctly");
+        my $perm4 = (stat $copy4) [2] & 0xFFF;
+        my $perm5 = (stat $copy5) [2] & 0xFFF;
+        my $perm6 = (stat $copy6) [2] & 0xFFF;
+        is (__$perm1, __$permdef, "Permission bits set correctly");
+        is (__$perm2, __$permdef, "Permission bits set correctly");
+        is (__$perm4, __$c_perm1, "Permission bits set correctly");
+        is (__$perm5, __$c_perm1, "Permission bits set correctly");
         TODO: {
             local $TODO = 'Permission bits inconsistent under cygwin' if $^O eq 'cygwin';
             is (__$perm3, __$c_perm3, "Permission bits not modified");
+            is (__$perm6, __$c_perm3, "Permission bits not modified");
         }
     }
     umask $old_mask or die $!;
 
     # Clean up.
-    ! -e $_ or unlink $_ or die $! for $src, $copy1, $copy2, $copy3;
+    ! -e $_ or unlink $_ or die $! for $src, $copy1, $copy2, $copy3, $copy4, $copy5, $copy6;
 }
 
 {