Fix scrambled and incorrect proto mismatch error

$ ./perl -Ilib -e 'use constant foo=>bar; sub foo(@);'
Prototype mismatch:: none vs (@) at -e line 1.
$ ./perl -Ilib -e 'sub foo(); sub foo(@);'
Prototype mismatch: () vs (@) at -e line 1.

Notice the double colon and the ‘none’ in the first example?

We also have this bug, where the prototype is the same, but we get the
warning anyway:

$ ./perl -Ilib -e 'use constant foo=>bar; sub foo();'
Prototype mismatch:: none vs () at -e line 1.

When the $::{foo} = \1 constant optimisation was added in 5.10.0, pro-
totype warnings were not taken into account.  A forward declaration
like sub foo() puts a string in the stash element.  newATTRSUB was
passing a non-SVt_NULL non-gv stash element to cv_ckproto_len_flags,
which assumed that !SvPOK meant no prototype.  That’s not the case
with a reference.

The double colon, which goes back to 5.8.4 (ebe643b99/59e7bac08e),
occurs when the sub name is not available:

$ perl5.8.4 -e 'sub foo; sub foo();'
Prototype mismatch:: none vs () at -e line 1.

(Before that the message was worse:
$ perl5.8.3 -e 'sub foo; sub foo();'
Prototype mismatch: vs () at -e line 1.)

In 5.10.0, it started applying to constants as well, which used to
show the sub name:

$ perl5.8.9 -e 'use constant foo=>bar; sub foo(@);'
Prototype mismatch: sub main::foo () vs (@) at -e line 1.
$ perl5.10.0 -e 'use constant foo=>bar; sub foo(@);'
Runaway prototype at -e line 1.
Prototype mismatch:: none vs (@) at -e line 1.

(‘Runaway prototype’ is already gone in blead [acfcf464b177, in which
I stated wrongly that the warning could only come about with stash
manipulation].)

This commit changes cv_ckproto_len_flags to assume that a reference
is a constant with an empty string for a prototype.  It also makes
newATTRSUB pass the sub name sv instead of a gv in those cases where
the stash element isn’t a gv.  This doesn’t restore things to exactly
the way they were before (foo instead of main::foo), but I’m not sure
it’s worth the added complexity of constructing the fully-qualified
name, just for a warning.

diff --git a/op.c b/op.c
index 41bea3b..8fc0312 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6649,7 +6649,7 @@ void
 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
                    const STRLEN len, const U32 flags)
 {
-    const char * const cvp = CvPROTO(cv);
+    const char * const cvp = SvROK(cv) ? "" : CvPROTO(cv);
     const STRLEN clen = CvPROTOLEN(cv);
 
     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
@@ -6671,11 +6671,15 @@ Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
        SV* name = NULL;
 
        if (gv)
+       {
+         if (isGV(gv))
            gv_efullname3(name = sv_newmortal(), gv, NULL);
+         else name = (SV *)gv;
+       }
        sv_setpvs(msg, "Prototype mismatch:");
        if (name)
            Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
-       if (SvPOK(cv))
+       if (cvp)
            Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
                SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
            );
@@ -6928,7 +6932,9 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     if (SvTYPE(gv) != SVt_PVGV) {      /* Maybe prototype now, and had at
                                           maximum a prototype before. */
        if (SvTYPE(gv) > SVt_NULL) {
-           cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
+           cv_ckproto_len_flags((const CV *)gv,
+                                o ? (const GV *)cSVOPo->op_sv : NULL, ps,
+                                ps_len, ps_utf8);
        }
        if (ps) {
            sv_setpvn(MUTABLE_SV(gv), ps, ps_len);

diff --git a/t/lib/warnings/op b/t/lib/warnings/op
index c6a3bb8..4f33700 100644 (file)
--- a/t/lib/warnings/op
+++ b/t/lib/warnings/op
@@ -844,8 +844,13 @@ EXPECT
 # op.c
 sub fred();
 sub fred($) {}
+use constant foo=>bar; sub foo(@);
+use constant bav=>bar; sub bav(); # no warning
+sub btu; sub btu();
 EXPECT
 Prototype mismatch: sub main::fred () vs ($) at - line 3.
+Prototype mismatch: sub foo () vs (@) at - line 4.
+Prototype mismatch: sub btu: none vs () at - line 6.
 ########
 # op.c
 use utf8;