RT #73714: Regression in 5.12: File::Copy and initial spaces

[p5sagit/p5-mst-13.2.git] / lib / File / Copy.t

diff --git a/lib/File/Copy.t b/lib/File/Copy.t
old mode 100755 (executable)
new mode 100644 (file)
index 2ac93a6..cc1c3ff
--- a/lib/File/Copy.t
+++ b/lib/File/Copy.t
@@ -14,7 +14,7 @@ use Test::More;
 
 my $TB = Test::More->builder;
 
-plan tests => 451;
+plan tests => 463;
 
 # We're going to override rename() later on but Perl has to see an override
 # at compile time to honor it.
@@ -223,6 +223,17 @@ for my $cross_partition_test (0..1) {
 
   unlink "file-$$" or die $!;
   unlink "copy-$$" or die $!;
+
+  # RT #73714 copy to file with leading whitespace failed
+
+  open(F, ">file-$$") or die $!;
+  close F;
+  copy "file-$$", " copy-$$";
+  warn "XXX\n";
+  ok -e " copy-$$", "copy with leading whitespace";
+  unlink "file-$$" or die "unlink: $!";
+  unlink " copy-$$" or die "unlink: $!";
+
 }
 
 
@@ -239,6 +250,9 @@ SKIP: {
 
     my $skips = @tests * 6 * 8;
 
+    # TODO - make this skip fire if we're on a nosuid filesystem rather than guessing by OS
+    skip "OpenBSD filesystems default to nosuid breaking these tests", $skips
+          if $^O eq 'openbsd';
     skip "-- Copy preserves RMS defaults, not POSIX permissions.", $skips
           if $^O eq 'VMS';
     skip "Copy doesn't set file permissions correctly on Win32.",  $skips
@@ -286,6 +300,31 @@ SKIP: {
             $c_perm1 |= $id << 9;
             diag(sprintf "Src permission: %04o; umask %03o\n", $s_perm, $umask)
                 unless ($ENV{PERL_CORE});
+
+           # Test that we can actually set a file to the correct permission.
+           # Slightly convoluted, because some operating systems will let us
+           # set a directory, but not a file. These should all work:
+           mkdir $copy1 or die "Can't mkdir $copy1: $!";
+           chmod $s_perm, $copy1
+               or die sprintf "Can't chmod %o $copy1: $!", $s_perm;
+           rmdir $copy1
+               or die sprintf "Can't rmdir $copy1: $!";
+           open my $fh0, '>', $copy1 or die "Can't open $copy1: $!";
+           close $fh0 or die "Can't close $copy1: $!";
+           unless (chmod $s_perm, $copy1) {
+               $TB->skip(sprintf "Can't chmod $copy1 to %o: $!", $s_perm)
+                   for 1..6;
+               next;
+           }
+            my $perm0 = (stat $copy1) [2] & 07777;
+           unless ($perm0 == $s_perm) {
+               $TB->skip(sprintf "chmod %o $copy1 lies - we actually get %o",
+                         $s_perm, $perm0)
+                   for 1..6;
+               next;
+           }
+           unlink $copy1 or die "Can't unlink $copy1: $!";
+
             (umask $umask) // die $!;
             chmod $s_perm  => $src   or die sprintf "$!: $src => %o", $s_perm;
             chmod $c_perm3 => $copy3 or die $!;
@@ -373,6 +412,56 @@ SKIP: {
     }
 }
 
+# On Unix systems, File::Copy always returns 0 to signal failure,
+# even when in list context!  On Windows, it always returns "" to signal
+# failure.
+#
+# While returning a list containing a false value is arguably a bad
+# API design, at the very least we can make sure it always returns
+# the same false value.
+
+my $NO_SUCH_FILE       = "this_file_had_better_not_exist";
+my $NO_SUCH_OTHER_FILE = "my_goodness_im_sick_of_airports";
+
+use constant EXPECTED_SCALAR => 0;
+use constant EXPECTED_LIST   => [ EXPECTED_SCALAR ];
+
+my %subs = (
+    copy    =>  \&File::Copy::copy,
+    cp      =>  \&File::Copy::cp,
+    move    =>  \&File::Copy::move,
+    mv      =>  \&File::Copy::mv,
+);
+
+SKIP: {
+    skip( "Test can't run with $NO_SUCH_FILE existing", 2 * keys %subs)
+        if (-e $NO_SUCH_FILE);
+
+    foreach my $name (keys %subs) {
+
+        my $sub = $subs{$name};
+
+        my $scalar = $sub->( $NO_SUCH_FILE, $NO_SUCH_OTHER_FILE );
+        is( $scalar, EXPECTED_SCALAR, "$name in scalar context");
+
+        my @array  = $sub->( $NO_SUCH_FILE, $NO_SUCH_OTHER_FILE );
+        is_deeply( \@array, EXPECTED_LIST, "$name in list context");
+    }
+}
+
+SKIP: {
+    skip("fork required to test pipe copying", 2)
+        if (!$Config{'d_fork'});
+
+    open(my $IN, "-|") || exec $^X, '-e', 'print "Hello, world!\n"';
+    open(my $OUT, "|-") || exec $^X, '-ne', 'exit(/Hello/ ? 55 : 0)';
+
+    ok(copy($IN, $OUT), "copy pipe to another");
+    close($OUT);
+    is($? >> 8, 55, "content copied through the pipes");
+    close($IN);
+}
+
 END {
     1 while unlink "file-$$";
     1 while unlink "lib/file-$$";