regen/mph.pl: Move a print around

[perl5.git] / toke.c

diff --git a/toke.c b/toke.c
index df1d7fe..fc87252 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -39,6 +39,7 @@ Individual members of C<PL_parser> have their own documentation.
 #define PERL_IN_TOKE_C
 #include "perl.h"
 #include "dquote_inline.h"
+#include "invlist_inline.h"
 
 #define new_constant(a,b,c,d,e,f,g)    \
        S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
@@ -2683,14 +2684,11 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
             s += 2;
         }
         else {
-            if (! PL_utf8_charname_begin) {
-                U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
-                PL_utf8_charname_begin = _core_swash_init("utf8",
-                                                        "_Perl_Charname_Begin",
-                                                        &PL_sv_undef,
-                                                        1, 0, NULL, &flags);
-            }
-            if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
+            if (! _invlist_contains_cp(PL_utf8_charname_begin,
+                                       utf8_to_uvchr_buf((U8 *) s,
+                                                         (U8 *) e,
+                                                         NULL)))
+            {
                 goto bad_charname;
             }
             s += UTF8SKIP(s);
@@ -2714,14 +2712,11 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
                 s += 2;
             }
             else {
-                if (! PL_utf8_charname_continue) {
-                    U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
-                    PL_utf8_charname_continue = _core_swash_init("utf8",
-                                                "_Perl_Charname_Continue",
-                                                &PL_sv_undef,
-                                                1, 0, NULL, &flags);
-                }
-                if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
+                if (! _invlist_contains_cp(PL_utf8_charname_continue,
+                                           utf8_to_uvchr_buf((U8 *) s,
+                                                             (U8 *) e,
+                                                             NULL)))
+                {
                     goto bad_charname;
                 }
                 s += UTF8SKIP(s);
@@ -5944,9 +5939,17 @@ Perl_yylex(pTHX)
        case XATTRTERM:
            PL_expect = XTERMBLOCK;
         grabattrs:
+            /* NB: as well as parsing normal attributes, we also end up
+             * here if there is something looking like attributes
+             * following a signature (which is illegal, but used to be
+             * legal in 5.20..5.26). If the latter, we still parse the
+             * attributes so that error messages(s) are less confusing,
+             * but ignore them (parser->sig_seen).
+             */
            s = skipspace(s);
            attrs = NULL;
             while (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
+                bool sig = PL_parser->sig_seen;
                I32 tmp;
                SV *sv;
                d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
@@ -5989,23 +5992,27 @@ Perl_yylex(pTHX)
                       the CVf_BUILTIN_ATTRS define in cv.h! */
                    if (!PL_in_my && memEQs(SvPVX(sv), len, "lvalue")) {
                        sv_free(sv);
-                       CvLVALUE_on(PL_compcv);
+                       if (!sig)
+                            CvLVALUE_on(PL_compcv);
                    }
                    else if (!PL_in_my && memEQs(SvPVX(sv), len, "method")) {
                        sv_free(sv);
-                       CvMETHOD_on(PL_compcv);
+                       if (!sig)
+                            CvMETHOD_on(PL_compcv);
                    }
                    else if (!PL_in_my && memEQs(SvPVX(sv), len, "const"))
                    {
                        sv_free(sv);
-                       Perl_ck_warner_d(aTHX_
-                           packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
-                          ":const is experimental"
-                       );
-                       CvANONCONST_on(PL_compcv);
-                       if (!CvANON(PL_compcv))
-                           yyerror(":const is not permitted on named "
-                                   "subroutines");
+                        if (!sig) {
+                            Perl_ck_warner_d(aTHX_
+                                packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
+                               ":const is experimental"
+                            );
+                            CvANONCONST_on(PL_compcv);
+                            if (!CvANON(PL_compcv))
+                                yyerror(":const is not permitted on named "
+                                        "subroutines");
+                        }
                    }
                    /* After we've set the flags, it could be argued that
                       we don't need to do the attributes.pm-based setting
@@ -6058,6 +6065,14 @@ Perl_yylex(pTHX)
                }
            }
        got_attrs:
+            if (PL_parser->sig_seen) {
+                /* see comment about about sig_seen and parser error
+                 * handling */
+                if (attrs)
+                    op_free(attrs);
+                Perl_croak(aTHX_ "Subroutine attributes must come "
+                                 "before the signature");
+                }
            if (attrs) {
                NEXTVAL_NEXTTOKE.opval = attrs;
                force_next(THING);
@@ -8669,6 +8684,9 @@ Perl_yylex(pTHX)
                s = skipspace(s);
                 d = SvPVX(PL_linestr)+off;
 
+                SAVEBOOL(PL_parser->sig_seen);
+                PL_parser->sig_seen = FALSE;
+
                 if (   isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
                     || *s == '\''
                     || (*s == ':' && s[1] == ':'))
@@ -9034,7 +9052,7 @@ S_pending_ident(pTHX)
                HEK * const stashname = HvNAME_HEK(stash);
                SV *  const sym = newSVhek(stashname);
                 sv_catpvs(sym, "::");
-                sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
+                sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
                 pl_yylval.opval = newSVOP(OP_CONST, 0, sym);
                 pl_yylval.opval->op_private = OPpCONST_ENTERED;
                 if (pit != '&')
@@ -9062,7 +9080,7 @@ S_pending_ident(pTHX)
         && PL_lex_state != LEX_NORMAL
         && !PL_lex_brackets)
     {
-        GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
+        GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
                                          ( UTF ? SVf_UTF8 : 0 ) | GV_ADDMG,
                                          SVt_PVAV);
         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
@@ -9079,11 +9097,11 @@ S_pending_ident(pTHX)
     /* build ops for a bareword */
     pl_yylval.opval = newSVOP(OP_CONST, 0,
                                   newSVpvn_flags(PL_tokenbuf + 1,
-                                                     tokenbuf_len - 1,
+                                                      tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
                                                       UTF ? SVf_UTF8 : 0 ));
     pl_yylval.opval->op_private = OPpCONST_ENTERED;
     if (pit != '&')
-       gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
+        gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
                     (PL_in_eval ? GV_ADDMULTI : GV_ADD)
                      | ( UTF ? SVf_UTF8 : 0 ),
                     ((PL_tokenbuf[0] == '$') ? SVt_PV
@@ -9861,7 +9879,7 @@ S_scan_subst(pTHX_ char *start)
          * the NVX field indicates how many src code lines the replacement
          * spreads over */
         sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV);
-        ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = 0;
+        ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = linediff;
         ((XPVIV*)SvANY(PL_parser->lex_sub_repl))->xiv_u.xivu_eval_seen =
                                                                     cBOOL(es);
     }