Apply patch from Sprout to make vxs.inc better

[perl5.git] / toke.c

diff --git a/toke.c b/toke.c
index d7de0db..8ac0f31 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -482,7 +482,9 @@ S_printbuf(pTHX_ const char *const fmt, const char *const s)
 
     PERL_ARGS_ASSERT_PRINTBUF;
 
+    GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
     PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
+    GCC_DIAG_RESTORE;
     SvREFCNT_dec(tmp);
 }
 
@@ -2171,15 +2173,15 @@ S_force_next(pTHX_ I32 type)
  */
 
 static int
-S_postderef(pTHX_ char const funny, char const next)
+S_postderef(pTHX_ int const funny, char const next)
 {
     dVAR;
-    assert(strchr("$@%&*", funny));
+    assert(funny == DOLSHARP || strchr("$@%&*", funny));
     assert(strchr("*[{", next));
     if (next == '*') {
        PL_expect = XOPERATOR;
        if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
-           assert('@' == funny || '$' == funny);
+           assert('@' == funny || '$' == funny || DOLSHARP == funny);
            PL_lex_state = LEX_INTERPEND;
            start_force(PL_curforce);
            force_next(POSTJOIN);
@@ -2744,7 +2746,8 @@ S_sublex_done(pTHX)
 
     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
     assert(PL_lex_inwhat != OP_TRANSR);
-    if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
+    if (PL_lex_repl) {
+       assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
        PL_linestr = PL_lex_repl;
        PL_lex_inpat = 0;
        PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
@@ -2859,7 +2862,8 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
         SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
     {
         const char * const name = HvNAME(stash);
-        if strEQ(name, "_charnames") {
+        if (HvNAMELEN(stash) == sizeof("_charnames")-1
+         && strEQ(name, "_charnames")) {
            return res;
        }
     }
@@ -3378,6 +3382,7 @@ S_scan_const(pTHX_ char *start)
            if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
                isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
            {
+               /* diag_listed_as: \%d better written as $%d */
                Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
                *--s = '$';
                break;
@@ -3565,7 +3570,7 @@ S_scan_const(pTHX_ char *start)
                    if (! PL_lex_inpat) {
                        yyerror("Missing right brace on \\N{}");
                    } else {
-                       yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
+                       yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
                    }
                    continue;
                }
@@ -3939,7 +3944,7 @@ S_scan_const(pTHX_ char *start)
  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
  *
  * ->[ and ->{ return TRUE
- * ->$* ->@* ->@[ and ->@{ return TRUE if postfix_interpolate is enabled
+ * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
  * { and [ outside a pattern are always subscripts, so return TRUE
  * if we're outside a pattern and it's not { or [, then return FALSE
  * if we're in a pattern and the first char is a {
@@ -3967,7 +3972,7 @@ S_intuit_more(pTHX_ char *s)
        return TRUE;
     if (*s == '-' && s[1] == '>'
      && FEATURE_POSTDEREF_QQ_IS_ENABLED
-     && ( (s[2] == '$' && s[3] == '*')
+     && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
        ||(s[2] == '@' && strchr("*[{",s[3])) ))
        return TRUE;
     if (*s != '{' && *s != '[')
@@ -5743,6 +5748,7 @@ Perl_yylex(pTHX)
                s = SKIPSPACE1(s);
                if (FEATURE_POSTDEREF_IS_ENABLED && (
                    ((*s == '$' || *s == '&') && s[1] == '*')
+                 ||(*s == '$' && s[1] == '#' && s[2] == '*')
                  ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
                  ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
                 ))
@@ -5852,13 +5858,6 @@ Perl_yylex(pTHX)
        if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
            if (*s == '[')
                PL_tokenbuf[0] = '@';
-
-           /* Warn about % where they meant $. */
-           if (*s == '[' || *s == '{') {
-               if (ckWARN(WARN_SYNTAX)) {
-                   S_check_scalar_slice(aTHX_ s);
-               }
-           }
        }
        PL_expect = XOPERATOR;
        force_ident_maybe_lex('%');
@@ -5951,7 +5950,7 @@ Perl_yylex(pTHX)
                }
                sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
                if (*d == '(') {
-                   d = scan_str(d,TRUE,TRUE,FALSE, FALSE);
+                   d = scan_str(d,TRUE,TRUE,FALSE,FALSE,NULL);
                    COPLINE_SET_FROM_MULTI_END;
                    if (!d) {
                        /* MUST advance bufptr here to avoid bogus
@@ -6094,6 +6093,7 @@ Perl_yylex(pTHX)
            TOKEN(0);
        s++;
        if (PL_lex_brackets <= 0)
+           /* diag_listed_as: Unmatched right %s bracket */
            yyerror("Unmatched right square bracket");
        else
            --PL_lex_brackets;
@@ -6272,6 +6272,7 @@ Perl_yylex(pTHX)
       rightbracket:
        s++;
        if (PL_lex_brackets <= 0)
+           /* diag_listed_as: Unmatched right %s bracket */
            yyerror("Unmatched right curly bracket");
        else
            PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
@@ -6582,7 +6583,13 @@ Perl_yylex(pTHX)
                return deprecate_commaless_var_list();
            }
        }
-       else if (PL_expect == XPOSTDEREF) POSTDEREF('$');
+       else if (PL_expect == XPOSTDEREF) {
+           if (s[1] == '#') {
+               s++;
+               POSTDEREF(DOLSHARP);
+           }
+           POSTDEREF('$');
+       }
 
        if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
            PL_tokenbuf[0] = '@';
@@ -6848,7 +6855,7 @@ Perl_yylex(pTHX)
        TERM(THING);
 
     case '\'':
-       s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+       s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
        COPLINE_SET_FROM_MULTI_END;
        DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
        if (PL_expect == XOPERATOR) {
@@ -6864,7 +6871,7 @@ Perl_yylex(pTHX)
        TERM(sublex_start());
 
     case '"':
-       s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+       s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
        DEBUG_T( {
            if (s)
                printbuf("### Saw string before %s\n", s);
@@ -6895,7 +6902,7 @@ Perl_yylex(pTHX)
        TERM(sublex_start());
 
     case '`':
-       s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+       s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
        DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
        if (PL_expect == XOPERATOR)
            no_op("Backticks",s);
@@ -7106,7 +7113,8 @@ Perl_yylex(pTHX)
            if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
                CV *cv;
                if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
-                                            UTF ? SVf_UTF8 : 0, SVt_PVCV)) &&
+                                           (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
+                                           SVt_PVCV)) &&
                    (cv = GvCVu(gv)))
                {
                    if (GvIMPORTED_CV(gv))
@@ -7602,8 +7610,13 @@ Perl_yylex(pTHX)
                            while (isLOWER(*d))
                                d++;
                            if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
+                            {
+                                /* PL_warn_reserved is constant */
+                                GCC_DIAG_IGNORE(-Wformat-nonliteral);
                                Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
                                       PL_tokenbuf);
+                                GCC_DIAG_RESTORE;
+                            }
                        }
                    }
                }
@@ -7879,7 +7892,8 @@ Perl_yylex(pTHX)
                *PL_tokenbuf = '&';
                d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
                              1, &len);
-               if (len && !keyword(PL_tokenbuf + 1, len, 0)) {
+               if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
+                && !keyword(PL_tokenbuf + 1, len, 0)) {
                    d = SKIPSPACE1(d);
                    if (*d == '(') {
                        force_ident_maybe_lex('&');
@@ -8146,7 +8160,7 @@ Perl_yylex(pTHX)
 
        case KEY_glob:
            LOP(
-            orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
+            orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
             XTERM
            );
 
@@ -8379,7 +8393,7 @@ Perl_yylex(pTHX)
            LOP(OP_PIPE_OP,XTERM);
 
        case KEY_q:
-           s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+           s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
            COPLINE_SET_FROM_MULTI_END;
            if (!s)
                missingterm(NULL);
@@ -8391,7 +8405,7 @@ Perl_yylex(pTHX)
 
        case KEY_qw: {
            OP *words = NULL;
-           s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+           s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
            COPLINE_SET_FROM_MULTI_END;
            if (!s)
                missingterm(NULL);
@@ -8442,7 +8456,7 @@ Perl_yylex(pTHX)
        }
 
        case KEY_qq:
-           s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+           s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
            if (!s)
                missingterm(NULL);
            pl_yylval.ival = OP_STRINGIFY;
@@ -8455,7 +8469,7 @@ Perl_yylex(pTHX)
            TERM(sublex_start());
 
        case KEY_qx:
-           s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+           s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
            if (!s)
                missingterm(NULL);
            pl_yylval.ival = OP_BACKTICK;
@@ -8772,7 +8786,7 @@ Perl_yylex(pTHX)
 
                /* Look for a prototype */
                if (*s == '(') {
-                   s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+                   s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
                    COPLINE_SET_FROM_MULTI_END;
                    if (!s)
                        Perl_croak(aTHX_ "Prototype not terminated");
@@ -9036,10 +9050,14 @@ S_pending_ident(pTHX)
             tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
         }
         else {
-            if (has_colon)
+            if (has_colon) {
+                /* PL_no_myglob is constant */
+                GCC_DIAG_IGNORE(-Wformat-nonliteral);
                 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
                            PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
                             UTF ? SVf_UTF8 : 0);
+                GCC_DIAG_RESTORE;
+            }
 
             pl_yylval.opval = newOP(OP_PADANY, 0);
             pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
@@ -9231,7 +9249,7 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
                            newSVpvs(":full"),
                            newSVpvs(":short"),
                            NULL);
-           SPAGAIN;
+            assert(sp == PL_stack_sp);
            table = GvHV(PL_hintgv);
            if (table
                && (PL_hints & HINT_LOCALIZE_HH)
@@ -9671,6 +9689,7 @@ S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charse
            yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
        }
        else if (c == 'a') {
+  /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
            yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
        }
        else {
@@ -9698,7 +9717,7 @@ S_scan_pat(pTHX_ char *start, I32 type)
     PERL_ARGS_ASSERT_SCAN_PAT;
 
     s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING),
-                       TRUE /* look for escaped bracketed metas */ );
+                       TRUE /* look for escaped bracketed metas */, NULL);
 
     if (!s) {
        const char * const delimiter = skipspace(start);
@@ -9786,19 +9805,19 @@ S_scan_subst(pTHX_ char *start)
 #ifdef PERL_MAD
     char *modstart;
 #endif
+    char *t;
 
     PERL_ARGS_ASSERT_SCAN_SUBST;
 
     pl_yylval.ival = OP_NULL;
 
     s = scan_str(start,!!PL_madskills,FALSE,FALSE,
-                 TRUE /* look for escaped bracketed metas */ );
+                 TRUE /* look for escaped bracketed metas */, &t);
 
     if (!s)
        Perl_croak(aTHX_ "Substitution pattern not terminated");
 
-    if (s[-1] == PL_multi_open)
-       s--;
+    s = t;
 #ifdef PERL_MAD
     if (PL_madskills) {
        CURMAD('q', PL_thisopen);
@@ -9811,7 +9830,7 @@ S_scan_subst(pTHX_ char *start)
 
     first_start = PL_multi_start;
     first_line = CopLINE(PL_curcop);
-    s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+    s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
     if (!s) {
        if (PL_lex_stuff) {
            SvREFCNT_dec(PL_lex_stuff);
@@ -9898,17 +9917,17 @@ S_scan_trans(pTHX_ char *start)
 #ifdef PERL_MAD
     char *modstart;
 #endif
+    char *t;
 
     PERL_ARGS_ASSERT_SCAN_TRANS;
 
     pl_yylval.ival = OP_NULL;
 
-    s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
+    s = scan_str(start,!!PL_madskills,FALSE,FALSE,FALSE,&t);
     if (!s)
        Perl_croak(aTHX_ "Transliteration pattern not terminated");
 
-    if (s[-1] == PL_multi_open)
-       s--;
+    s = t;
 #ifdef PERL_MAD
     if (PL_madskills) {
        CURMAD('q', PL_thisopen);
@@ -9919,7 +9938,7 @@ S_scan_trans(pTHX_ char *start)
     }
 #endif
 
-    s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+    s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
     if (!s) {
        if (PL_lex_stuff) {
            SvREFCNT_dec(PL_lex_stuff);
@@ -10372,7 +10391,7 @@ S_scan_inputsymbol(pTHX_ char *start)
 
     if (d - PL_tokenbuf != len) {
        pl_yylval.ival = OP_GLOB;
-       s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
+       s = scan_str(start,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
        if (!s)
           Perl_croak(aTHX_ "Glob not terminated");
        return s;
@@ -10472,6 +10491,11 @@ intro_sym:
        deprecate_escaped_meta  issue a deprecation warning for cer-
                                tain paired metacharacters that appear
                                escaped within it
+       delimp                  if non-null, this is set to the position of
+                               the closing delimiter, or just after it if
+                               the closing and opening delimiters differ
+                               (i.e., the opening delimiter of a substitu-
+                               tion replacement)
    returns: position to continue reading from buffer
    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
        updates the read buffer.
@@ -10513,7 +10537,7 @@ intro_sym:
 
 STATIC char *
 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse,
-                bool deprecate_escaped_meta
+                bool deprecate_escaped_meta, char **delimp
     )
 {
     dVAR;
@@ -10940,6 +10964,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse,
        PL_sublex_info.repl = sv;
     else
        PL_lex_stuff = sv;
+    if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
     return s;
 }