Tests to check cp() doesn't drop set[eu]id bits.

Also, calculate the number of skipped tests instead of having a hard
coded number.

1 files changed, 68 insertions, 48 deletions

diff --git a/lib/File/Copy.t b/lib/File/Copy.t
index 687e129b52..7081f5e5ed 100755
--- a/lib/File/Copy.t
+++ b/lib/File/Copy.t
@@ -14,7 +14,7 @@ use Test::More;
 
 my $TB = Test::More->builder;
 
-plan tests => 157;
+plan tests => 451;
 
 # We're going to override rename() later on but Perl has to see an override
 # at compile time to honor it.
@@ -227,14 +227,35 @@ for my $cross_partition_test (0..1) {
 
 
 SKIP: {
+    my @tests = (
+        [0000,  0777,  0777,  0777],
+        [0000,  0751,  0751,  0644],
+        [0022,  0777,  0755,  0206],
+        [0022,  0415,  0415,  0666],
+        [0077,  0777,  0700,  0333],
+        [0027,  0755,  0750,  0251],
+        [0777,  0751,  0000,  0215],
+    );
+
+    my $skips = @tests * 6 * 8;
 
-    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";
+    skip "-- Copy preserves RMS defaults, not POSIX permissions.", $skips
+          if $^O eq 'VMS';
+    skip "Copy doesn't set file permissions correctly on Win32.",  $skips
+          if $^O eq "MSWin32";
 
     # Just a sub to get better failure messages.
     sub __ ($) {
-        join "" => map {(qw [--- --x -w- -wx r-- r-x rw- rwx]) [$_]} 
-                   split // => sprintf "%03o" => shift
+        my $perm   = shift;
+        my $id     = 07000 & $perm;
+           $id   >>= 9;
+        $perm     &= 0777;
+        my @chunks = map {(qw [--- --x -w- -wx r-- r-x rw- rwx]) [$_]}
+                     split // => sprintf "%03o" => $perm;
+        if ($id & 4) {$chunks [0] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;}
+        if ($id & 2) {$chunks [1] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;}
+        if ($id & 1) {$chunks [2] =~ s/(.)$/$1 eq '-' ? 'T' : 't'/e;}
+        join "" => @chunks;
     }
     # Testing permission bits.
     my $src   = "file-$$";
@@ -254,56 +275,55 @@ SKIP: {
     open    $fh => ">", $copy6 or die $!;
     close   $fh                or die $!;
 
-    my @tests = (
-        [0000,  0777,  0777,  0777],
-        [0000,  0751,  0751,  0644],
-        [0022,  0777,  0755,  0206],
-        [0022,  0415,  0415,  0666],
-        [0077,  0777,  0700,  0333],
-        [0027,  0755,  0750,  0251],
-        [0777,  0751,  0000,  0215],
-    );
     my $old_mask = umask;
     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, $copy4, $copy5;
-
-	(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;
-        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");
+        foreach my $id (0 .. 7) {
+            my ($umask, $s_perm, $c_perm1, $c_perm3) = @$test;
+            # Make sure the copies doesn't exist.
+            ! -e $_ or unlink $_ or die $! for $copy1, $copy2, $copy4, $copy5;
+
+            $s_perm  |= $id << 9;
+            $c_perm1 |= $id << 9;
+            diag sprintf "Src permission: %04o; umask %03o\n", $s_perm, $umask;
+
+            (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] & 07777;
+            my $perm2 = (stat $copy2) [2] & 07777;
+            my $perm3 = (stat $copy3) [2] & 07777;
+            my $perm4 = (stat $copy4) [2] & 07777;
+            my $perm5 = (stat $copy5) [2] & 07777;
+            my $perm6 = (stat $copy6) [2] & 07777;
+            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, $copy4, $copy5, $copy6;
+    ! -e $_ or unlink $_ or die $! for $src, $copy1, $copy2, $copy3,
+                                             $copy4, $copy5, $copy6;
 }
 
 {