Move the prototype related code into its own func This will also be called by perly...
authorPeter Martini <PeterCMartini@GMail.com>
Sat, 8 Sep 2012 03:40:03 +0000 (23:40 -0400)
committerJesse Luehrs <doy@tozt.net>
Thu, 13 Sep 2012 00:19:48 +0000 (19:19 -0500)
embed.fnc
embed.h
proto.h
toke.c

index ab2cdec..c75c338 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2155,6 +2155,7 @@ s |U8*    |add_utf16_textfilter|NN U8 *const s|bool reversed
 #endif
 s      |void   |checkcomma     |NN const char *s|NN const char *name \
                                |NN const char *what
+s      |bool   |scan_named_proto       |NN SV *sv|NN bool *bad
 s      |void   |force_ident    |NN const char *s|int kind
 s      |void   |incline        |NN const char *s
 s      |int    |intuit_method  |NN char *s|NULLOK GV *gv|NULLOK CV *cv
@@ -2183,6 +2184,8 @@ s |int    |tokereport     |I32 rv|NN const YYSTYPE* lvalp
 s      |void   |printbuf       |NN const char *const fmt|NN const char *const s
 #  endif
 #endif
+: used in perly.y
+px     |bool   |scan_proto     |NN SV *sv|const bool allowextended
 
 #if defined(PERL_IN_UNIVERSAL_C)
 s      |bool|isa_lookup        |NN HV *stash|NN const char * const name \
diff --git a/embed.h b/embed.h
index 45291f0..41534a5 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define sawparens(a)           Perl_sawparens(aTHX_ a)
 #define scalar(a)              Perl_scalar(aTHX_ a)
 #define scalarvoid(a)          Perl_scalarvoid(aTHX_ a)
+#define scan_proto(a,b)                Perl_scan_proto(aTHX_ a,b)
 #define sub_crush_depth(a)     Perl_sub_crush_depth(aTHX_ a)
 #define sv_2num(a)             Perl_sv_2num(aTHX_ a)
 #define sv_clean_all()         Perl_sv_clean_all(aTHX)
 #define scan_heredoc(a)                S_scan_heredoc(aTHX_ a)
 #define scan_ident(a,b,c,d,e)  S_scan_ident(aTHX_ a,b,c,d,e)
 #define scan_inputsymbol(a)    S_scan_inputsymbol(aTHX_ a)
+#define scan_named_proto(a,b)  S_scan_named_proto(aTHX_ a,b)
 #define scan_pat(a,b)          S_scan_pat(aTHX_ a,b)
 #define scan_str(a,b,c,d)      S_scan_str(aTHX_ a,b,c,d)
 #define scan_subst(a)          S_scan_subst(aTHX_ a)
diff --git a/proto.h b/proto.h
index f97fe1f..a0d54ef 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3650,6 +3650,11 @@ PERL_CALLCONV NV Perl_scan_oct(pTHX_ const char* start, STRLEN len, STRLEN* retl
 #define PERL_ARGS_ASSERT_SCAN_OCT      \
        assert(start); assert(retlen)
 
+PERL_CALLCONV bool     Perl_scan_proto(pTHX_ SV *sv, const bool allowextended)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SCAN_PROTO    \
+       assert(sv)
+
 PERL_CALLCONV const char*      Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
@@ -7172,6 +7177,12 @@ STATIC char*     S_scan_inputsymbol(pTHX_ char *start)
 #define PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL      \
        assert(start)
 
+STATIC bool    S_scan_named_proto(pTHX_ SV *sv, bool *bad)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SCAN_NAMED_PROTO      \
+       assert(sv); assert(bad)
+
 STATIC char*   S_scan_pat(pTHX_ char *start, I32 type)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1);
diff --git a/toke.c b/toke.c
index d6ac752..570cbb7 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -8280,78 +8280,9 @@ Perl_yylex(pTHX)
 
                /* Look for a prototype */
                if (*s == '(') {
-                   char *p;
-                   bool bad_proto = FALSE;
-                   bool in_brackets = FALSE;
-                   char greedy_proto = ' ';
-                   bool proto_after_greedy_proto = FALSE;
-                   bool must_be_last = FALSE;
-                   bool underscore = FALSE;
-                   bool seen_underscore = FALSE;
-                   const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
-                    STRLEN tmplen;
-
                    s = scan_str(s,!!PL_madskills,FALSE,FALSE);
                    if (!s)
                        Perl_croak(aTHX_ "Prototype not terminated");
-                   /* strip spaces and check for bad characters */
-                   d = SvPV(PL_lex_stuff, tmplen);
-                   tmp = 0;
-                   for (p = d; tmplen; tmplen--, ++p) {
-                       if (!isSPACE(*p)) {
-                            d[tmp++] = *p;
-
-                           if (warnillegalproto) {
-                               if (must_be_last)
-                                   proto_after_greedy_proto = TRUE;
-                               if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
-                                   bad_proto = TRUE;
-                               }
-                               else {
-                                   if ( underscore ) {
-                                       if ( !strchr(";@%", *p) )
-                                           bad_proto = TRUE;
-                                       underscore = FALSE;
-                                   }
-                                   if ( *p == '[' ) {
-                                       in_brackets = TRUE;
-                                   }
-                                   else if ( *p == ']' ) {
-                                       in_brackets = FALSE;
-                                   }
-                                   else if ( (*p == '@' || *p == '%') &&
-                                        ( tmp < 2 || d[tmp-2] != '\\' ) &&
-                                        !in_brackets ) {
-                                       must_be_last = TRUE;
-                                       greedy_proto = *p;
-                                   }
-                                   else if ( *p == '_' ) {
-                                       underscore = seen_underscore = TRUE;
-                                   }
-                               }
-                           }
-                       }
-                   }
-                    d[tmp] = '\0';
-                   if (proto_after_greedy_proto)
-                       Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
-                                   "Prototype after '%c' for %"SVf" : %s",
-                                   greedy_proto, SVfARG(PL_subname), d);
-                   if (bad_proto) {
-                        SV *dsv = newSVpvs_flags("", SVs_TEMP);
-                       Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
-                                   "Illegal character %sin prototype for %"SVf" : %s",
-                                   seen_underscore ? "after '_' " : "",
-                                   SVfARG(PL_subname),
-                                    SvUTF8(PL_lex_stuff)
-                                        ? sv_uni_display(dsv,
-                                            newSVpvn_flags(d, tmp, SVs_TEMP | SVf_UTF8),
-                                            tmp,
-                                            UNI_DISPLAY_ISPRINT)
-                                        : pv_pretty(dsv, d, tmp, 60, NULL, NULL,
-                                            PERL_PV_ESCAPE_NONASCII));
-                    }
-                    SvCUR_set(PL_lex_stuff, tmp);
                    have_proto = TRUE;
 
 #ifdef PERL_MAD
@@ -8743,6 +8674,189 @@ S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
     }
 }
 
+/* 
+  scan_proto:
+    If allowextended is false or the proto is strictly symbols,
+    use <= 5.16 rules:
+      remove all spaces, warn if WARN_ILLEGALPROTO is set, but set it
+      as the prototype anyway
+    If allowextended is true and an ID character is detected,
+      finish chewing spaces, and pass back a flag to scan_proto to warn
+*/
+
+bool
+Perl_scan_proto (pTHX_ SV *sv, bool allowextended)
+{
+    char *p;
+    char *d;
+    bool use_for_cvproto = TRUE;
+    bool bad_proto = FALSE;
+    bool named_proto = FALSE;
+    bool in_brackets = FALSE;
+    char greedy_proto = ' ';
+    bool proto_after_greedy_proto = FALSE;
+    bool must_be_last = FALSE;
+    bool underscore = FALSE;
+    bool seen_underscore = FALSE;
+    const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
+    IV tmp = 0;
+    STRLEN tmplen;
+
+    PERL_ARGS_ASSERT_SCAN_PROTO;
+
+    /* strip spaces and check for bad characters */
+    /* skip all warnings if this looks like a named prototype */
+    d = SvPV(sv, tmplen);
+    for (p = d; tmplen; tmplen--, ++p) {
+       if ( isSPACE(*p) && named_proto)
+           d[tmp++] = *p;
+       if (!isSPACE(*p)) {
+           d[tmp++] = *p;
+           if (!named_proto && (!strchr("$@%*;[]&\\_+", *p) || *p == '\0')) {
+               if (*p && !named_proto && isIDFIRST_lazy_if(p,UTF))
+                   named_proto = allowextended;
+               if (warnillegalproto)
+                   bad_proto = TRUE;
+           }
+
+           if (warnillegalproto && !named_proto) {
+               if (must_be_last)
+                   proto_after_greedy_proto = TRUE;
+               if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
+                   bad_proto = TRUE;
+               }
+               else {
+                 if ( underscore ) {
+                       if ( !strchr(";@%", *p) )
+                           bad_proto = TRUE;
+                       underscore = FALSE;
+                   }
+                   if ( *p == '[' ) {
+                       in_brackets = TRUE;
+                   }
+                   else if ( *p == ']' ) {
+                       in_brackets = FALSE;
+                   }
+                   else if ( (*p == '@' || *p == '%') &&
+                       ( tmp < 2 || d[tmp-2] != '\\' ) &&
+                       !in_brackets ) {
+                       must_be_last = TRUE;
+                       greedy_proto = *p;
+                   }
+                   else if ( *p == '_' ) {
+                       underscore = seen_underscore = TRUE;
+                   }
+               }
+           }
+       }
+    }
+    d[tmp] = '\0';
+    SvCUR_set(sv, tmp);
+
+    if (named_proto) {
+       use_for_cvproto = scan_named_proto(sv,
+                                          &bad_proto);
+       seen_underscore = FALSE;
+    }
+
+    if (warnillegalproto && proto_after_greedy_proto)
+       Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
+                   "Prototype after '%c' for %"SVf" : %s",
+                   greedy_proto, SVfARG(PL_subname), d);
+    if (warnillegalproto && bad_proto) {
+       SV *dsv = newSVpvs_flags("", SVs_TEMP);
+       Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
+                    "Illegal character %sin prototype for %"SVf" : %s",
+                    seen_underscore ? "after '_' " : "",
+                    SVfARG(PL_subname),
+                    SvUTF8(sv)
+                        ? sv_uni_display(dsv,
+                            newSVpvn_flags(d, tmp, SVs_TEMP | SVf_UTF8),
+                            tmp,
+                            UNI_DISPLAY_ISPRINT)
+                        : pv_pretty(dsv, d, tmp, 60, NULL, NULL,
+                            PERL_PV_ESCAPE_NONASCII));
+    }
+    return use_for_cvproto;
+}
+
+/*
+  scan_named_proto parses the prototype as if its an argument list,
+    and leaves the results in @_
+    pp_entersub checks if namedargs is set, and if it is, uses that array
+    to generate the appropriate local variables prior to putting the arguments
+    from the stack into @_
+    If the prototype doesn't parse, an illegal prototype warning is generated,
+    but the whole thing is stored in CvPROTO anyway (that's the current design)
+*/
+
+bool
+S_scan_named_proto (pTHX_ SV *sv, bool * bad)
+{
+    STRLEN protolen, len;
+    char *proto;
+    char token[sizeof PL_tokenbuf];
+/* XXX TODO: Greedy named parameters are currently invalid */
+    AV *protolist;
+    int arg_count = 0;
+
+    PERL_ARGS_ASSERT_SCAN_NAMED_PROTO;
+
+    *bad = false;
+    protolist = newAV();
+    proto = SvPV(sv, protolen);
+    while (*proto) {
+       while (isSPACE(*proto)) proto++;
+       if (strchr("$", *proto)) {
+           token[0] = *proto++;
+           proto = scan_word(proto, token+1, sizeof(token) - 1, FALSE, &len);
+           if (len) {
+/* XXX TODO: Disallow globals like '$1' */
+               arg_count++;
+               av_push(protolist, newSVpvn_flags(token, len + 1, UTF));
+               while (isSPACE(*proto)) proto++;
+               if (*proto == ',')
+                   proto++;
+               else if (*proto != '\0') {
+                   *bad = true;
+                   break;
+               }
+           }
+           else {
+               *bad = true;
+               break;
+           }
+       }
+       else {
+           *bad = true;
+           break;
+       }
+    }
+
+    /* Undo what's been done if this is invalid, and return early */
+    if (*bad) {
+       sv_free(MUTABLE_SV(protolist));
+       return true;
+    }
+
+    PadlistNAMEDPARAMS(CvPADLIST(PL_compcv)) = protolist;
+    while (arg_count--) {
+       SV * pad_name;
+       SV * proto_name = AvARRAY(protolist)[arg_count];
+       /* Add the pad entry, and mark it as visible */
+       int ix = pad_add_name_pv(SvPV_nolen(proto_name), 0, NULL, NULL);
+       pad_name = AvARRAY(PL_comppad_name)[ix];
+       ((XPVNV*)SvANY(pad_name))->xnv_u.xpad_cop_seq.xlow = PL_cop_seqmax;
+       ((XPVNV*)SvANY(pad_name))->xnv_u.xpad_cop_seq.xhigh = PERL_PADSEQ_INTRO;
+       /* Mark the prototype entry with a pointer into the pad */
+       sv_upgrade(proto_name, SVt_PVIV);
+       SvIV_set(proto_name, ix);
+       SvIOK_on(proto_name);
+    }
+    PL_cop_seqmax++;
+    return false;
+}
+
 /* Either returns sv, or mortalizes sv and returns a new SV*.
    Best used as sv=new_constant(..., sv, ...).
    If s, pv are NULL, calls subroutine with one argument,