[perl #59650] File::Copy does not handle file objects sanely

From: "rabbit+bugs@rabbit.us (via RT)" <perlbug-followup@perl.org>
Message-ID: <rt-3.6.HEAD-29762-1223291950-1373.59650-75-0@perl.org>

Suggested change modified to cope with the hoop-jumping needed to keep
File::Copy working whilst bootstrapping the core build.

Some tests by me, to try to ensure that (arguablly buggy) IO::Scalar
will still work.

p4raw-id: //depot/perl@34519

diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm
index b6a05ba..9597264 100644 (file)
--- a/lib/File/Copy.pm
+++ b/lib/File/Copy.pm
@@ -14,13 +14,17 @@ 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
+# 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 };
 our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
 sub copy;
 sub syscopy;
 sub cp;
 sub mv;
 
-$VERSION = '2.13';
+$VERSION = '2.14';
 
 require Exporter;
 @ISA = qw(Exporter);
@@ -62,11 +66,16 @@ sub _catname {
 }
 
 # _eq($from, $to) tells whether $from and $to are identical
-# works for strings and references
 sub _eq {
-    return $_[0] == $_[1] if ref $_[0] && ref $_[1];
-    return $_[0] eq $_[1] if !ref $_[0] && !ref $_[1];
-    return "";
+    my ($from, $to) = map {
+        $Scalar_Util_loaded && Scalar::Util::blessed($_)
+           && overload::Method($_, q{""})
+            ? "$_"
+            : $_
+    } (@_);
+    return '' if ( (ref $from) xor (ref $to) );
+    return $from == $to if ref $from;
+    return $from eq $to;
 }
 
 sub copy {

diff --git a/lib/File/Copy.t b/lib/File/Copy.t
index a6fa3cf..fc1f860 100755 (executable)
--- a/lib/File/Copy.t
+++ b/lib/File/Copy.t
@@ -14,7 +14,7 @@ use Test::More;
 
 my $TB = Test::More->builder;
 
-plan tests => 91;
+plan tests => 136;
 
 # We're going to override rename() later on but Perl has to see an override
 # at compile time to honor it.
@@ -289,6 +289,52 @@ SKIP: {
     ! -e $_ or unlink $_ or die $! for $src, $copy1, $copy2, $copy3;
 }
 
+{
+    package Crash;
+    # a package overloaded suspiciously like IO::Scalar
+    use overload '""' => sub { ${$_[0]} };
+    use overload 'bool' => sub { 1 };
+    sub new {
+       my ($class, $name) = @_;
+       bless \$name, $class;
+    }
+
+    package Zowie;
+    # a different package overloaded suspiciously like IO::Scalar
+    use overload '""' => sub { ${$_[0]} };
+    use overload 'bool' => sub { 1 };
+    sub new {
+       my ($class, $name) = @_;
+       bless \$name, $class;
+    }
+}
+{
+    my $object = Crash->new('whack_eth');
+    my %what = (plain => "$object",
+               object1 => $object,
+               object2 => Zowie->new('whack_eth'),
+               object2 => Zowie->new('whack_eth'),
+              );
+
+    my @warnings;
+    local $SIG{__WARN__} = sub {
+       push @warnings, @_;
+    };
+
+    foreach my $left (qw(plain object1 object2)) {
+       foreach my $right (qw(plain object1 object2)) {
+           @warnings = ();
+           $! = 0;
+           is eval {copy $what{$left}, $what{$right}}, 1, "copy $left $right";
+           is $@, '', 'No croaking';
+           is $!, '', 'No system call errors';
+           is @warnings, 1, 'Exactly 1 warning';
+           like $warnings[0],
+               qr/'$object' and '$object' are identical \(not copied\)/,
+                   'with the text we expect';
+       }
+    }
+}
 
 END {
     1 while unlink "file-$$";