Update Encode to CPAN version 2.56

[perl5.git] / toke.c

diff --git a/toke.c b/toke.c
index 509aa8e..b146cdc 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);
@@ -3379,6 +3381,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;
@@ -3566,7 +3569,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;
                }
@@ -3940,7 +3943,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 {
@@ -3968,7 +3971,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 != '[')
@@ -5744,6 +5747,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] == '{'))
                 ))
@@ -5945,7 +5949,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
@@ -6088,6 +6092,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;
@@ -6266,6 +6271,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];
@@ -6576,7 +6582,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] = '@';
@@ -6842,7 +6854,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) {
@@ -6858,7 +6870,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);
@@ -6889,7 +6901,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);
@@ -7100,7 +7112,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))
@@ -7596,8 +7609,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;
+                            }
                        }
                    }
                }
@@ -8140,7 +8158,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
            );
 
@@ -8373,7 +8391,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);
@@ -8385,7 +8403,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);
@@ -8436,7 +8454,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;
@@ -8449,7 +8467,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;
@@ -8766,7 +8784,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");
@@ -9030,10 +9048,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,
@@ -9225,7 +9247,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)
@@ -9665,6 +9687,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 {
@@ -9692,7 +9715,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);
@@ -9780,19 +9803,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);
@@ -9805,7 +9828,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);
@@ -9892,17 +9915,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);
@@ -9913,7 +9936,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);
@@ -10366,7 +10389,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;
@@ -10466,6 +10489,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.
@@ -10507,7 +10535,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;
@@ -10934,6 +10962,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;
 }