From: rabbit+bugs@rabbit.us <rabbit+bugs@rabbit.us>
Date: Mon, 6 Oct 2008 04:19:10 +0000 (-0700)
Subject: [perl #59650] File::Copy does not handle file objects sanely
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e55c0a828f279342571a887d09d7309727bcde4a;p=p5sagit%2Fp5-mst-13.2.git

[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
--- 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
--- 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-$$";