Re: Prototype checking on assignment of coderef to typeglob

   Message-Id: <20020222230107.A15069@rafael>

p4raw-id: //depot/perl@14837

diff --git a/sv.c b/sv.c
index 217df87..89c6e20 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3752,8 +3752,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
                                        GvENAME((GV*)dstr));
                                }
                            }
-                           cv_ckproto(cv, (GV*)dstr,
-                                      SvPOK(sref) ? SvPVX(sref) : Nullch);
+                           if (!intro)
+                               cv_ckproto(cv, (GV*)dstr,
+                                       SvPOK(sref) ? SvPVX(sref) : Nullch);
                        }
                        GvCV(dstr) = (CV*)sref;
                        GvCVGEN(dstr) = 0; /* Switch off cacheness. */

diff --git a/t/op/gv.t b/t/op/gv.t
index 9380735..9ce1135 100755 (executable)
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -11,7 +11,7 @@ BEGIN {
 
 use warnings;
 
-print "1..44\n";
+print "1..47\n";
 
 # type coersion on assignment
 $foo = 'foo';
@@ -193,5 +193,20 @@ print $j[0] == 1 ? "ok 43\n" : "not ok 43\n";
     print $g;
 }
 
+{
+    my $w = '';
+    $SIG{__WARN__} = sub { $w = $_[0] };
+    sub abc1 ();
+    local *abc1 = sub { };
+    print $w eq '' ? "ok 45\n" : "not ok 45\n# $w";
+    sub abc2 ();
+    local *abc2;
+    *abc2 = sub { };
+    print $w eq '' ? "ok 46\n" : "not ok 46\n# $w";
+    sub abc3 ();
+    *abc3 = sub { };
+    print $w =~ /Prototype mismatch/ ? "ok 47\n" : "not ok 47\n# $w";
+}
+
 __END__
 ok 44