Add support for the proto() attribute
authorPeter Martini <PeterCMartini@GMail.com>
Wed, 19 Sep 2012 01:37:00 +0000 (21:37 -0400)
committerPeter Martini <PeterCMartini@GMail.com>
Wed, 17 Oct 2012 20:36:09 +0000 (16:36 -0400)
For backwards compatibility

op.c
toke.c

diff --git a/op.c b/op.c
index 8fccf71..f8c1603 100644 (file)
--- a/op.c
+++ b/op.c
@@ -7334,6 +7334,48 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     else
        ps = NULL;
 
     else
        ps = NULL;
 
+    /* Check for a proto attribute.  It's prepended to the list if found,
+       so its either the first item or none at all */
+    if (attrs) {
+       SV * protosv;
+       proto = NULL;
+       if (attrs->op_type == OP_CONST) {
+           protosv = ((SVOP*)attrs)->op_sv;
+           if (SvLEN(protosv) >= 6 && strnEQ(SvPVX(protosv), "proto ", 6)) {
+               proto = attrs;
+               attrs = NULL;
+           }
+       }
+       else {
+           assert(attrs->op_type == OP_LIST);
+           proto = ((LISTOP*)attrs)->op_first->op_sibling;
+           protosv = ((SVOP*)proto)->op_sv;
+           if (SvLEN(protosv) >= 6 && strnEQ(SvPVX(protosv), "proto ", 6)) {
+               ((LISTOP*)attrs)->op_first->op_sibling = proto->op_sibling;
+           }
+           else
+               proto = NULL;
+       }
+       if (proto) {
+           sv_chop(protosv,SvPVX(protosv)+6);
+           /* XXX sub foo($$) : proto($*) ... for now, warn, and use the proto() */
+           if (ps && (ps_len != SvLEN(protosv) || strnNE(SvPV_nolen(protosv), ps, ps_len))) {
+               if (ckWARN_d(WARN_PROTOTYPE)) {
+                   SV* const msg = sv_newmortal();
+                   sv_setpvs(msg, "Prototype mismatch:");
+                   Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
+                       SVfARG(newSVpvn_flags(ps,ps_len,ps_utf8|SVs_TEMP)));
+                   sv_catpvs(msg, " vs ");
+                   Perl_sv_catpvf(aTHX_ msg, "proto(%"SVf")",
+                       SVfARG(protosv));
+                   Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
+               }
+           }
+           ps = SvPV_const(protosv, ps_len);
+           ps_utf8 = SvUTF8(protosv);
+       }
+    }
+
     if (o_is_gv) {
        gv = (GV*)o;
        o = NULL;
     if (o_is_gv) {
        gv = (GV*)o;
        o = NULL;
diff --git a/toke.c b/toke.c
index f29b890..7dcf2c4 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -5622,11 +5622,23 @@ Perl_yylex(pTHX)
                    }
                }
                if (PL_lex_stuff) {
                    }
                }
                if (PL_lex_stuff) {
-                   sv_catsv(sv, PL_lex_stuff);
-                   attrs = op_append_elem(OP_LIST, attrs,
-                                       newSVOP(OP_CONST, 0, sv));
-                   SvREFCNT_dec(PL_lex_stuff);
-                   PL_lex_stuff = NULL;
+                   if (len == 5 && strnEQ(s, "proto", len) && SvCUR(PL_lex_stuff) >= 2) {
+                       SV * proto = newSVpvn(SvPV_nolen(PL_lex_stuff)+1,SvCUR(PL_lex_stuff)-2);
+                       scan_proto(proto, FALSE);
+                       sv_catpv(sv, " ");
+                       sv_catsv(sv, proto);
+                       attrs = op_prepend_elem(OP_LIST,
+                                           newSVOP(OP_CONST, 0, sv), attrs);
+                       PL_lex_stuff = NULL;
+                       sv_free(proto);
+                   }
+                   else {
+                       sv_catsv(sv, PL_lex_stuff);
+                       attrs = op_append_elem(OP_LIST, attrs,
+                                           newSVOP(OP_CONST, 0, sv));
+                       SvREFCNT_dec(PL_lex_stuff);
+                       PL_lex_stuff = NULL;
+                   }
                }
                else {
                    if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
                }
                else {
                    if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {