X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/19742f39bfbfba7529a49232271b390bc4e811cb..30457add2d1f514977190c5b66b67eae3b64bcc6:/toke.c diff --git a/toke.c b/toke.c index 5a711d3..9f37f53 100644 --- a/toke.c +++ b/toke.c @@ -456,21 +456,14 @@ S_printbuf(pTHX_ const char *const fmt, const char *const s) PERL_ARGS_ASSERT_PRINTBUF; - GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */ + GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */ PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60)); - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; SvREFCNT_dec(tmp); } #endif -static int -S_deprecate_commaless_var_list(pTHX) { - PL_expect = XTERM; - deprecate_fatal_in("5.28", "Use of comma-less variable list is deprecated"); - return REPORT(','); /* grandfather non-comma-format format */ -} - /* * S_ao * @@ -563,16 +556,18 @@ S_no_op(pTHX_ const char *const what, char *s) */ STATIC void -S_missingterm(pTHX_ char *s) +S_missingterm(pTHX_ char *s, STRLEN len) { char tmpbuf[UTF8_MAXBYTES + 1]; char q; bool uni = FALSE; SV *sv; if (s) { - char * const nl = strrchr(s,'\n'); - if (nl) - *nl = '\0'; + char * const nl = (char *) my_memrchr(s, '\n', len); + if (nl) { + *nl = '\0'; + len = nl - s; + } uni = UTF; } else if (PL_multi_close < 32) { @@ -580,24 +575,28 @@ S_missingterm(pTHX_ char *s) tmpbuf[1] = (char)toCTRL(PL_multi_close); tmpbuf[2] = '\0'; s = tmpbuf; + len = 2; } else { if (LIKELY(PL_multi_close < 256)) { *tmpbuf = (char)PL_multi_close; tmpbuf[1] = '\0'; + len = 1; } else { + char *end = (char *)uvchr_to_utf8((U8 *)tmpbuf, PL_multi_close); + *end = '\0'; + len = end - tmpbuf; uni = TRUE; - *uvchr_to_utf8((U8 *)tmpbuf, PL_multi_close) = 0; } s = tmpbuf; } - q = strchr(s,'"') ? '\'' : '"'; - sv = sv_2mortal(newSVpv(s,0)); + q = memchr(s, '"', len) ? '\'' : '"'; + sv = sv_2mortal(newSVpvn(s, len)); if (uni) SvUTF8_on(sv); - Perl_croak(aTHX_ "Can't find string terminator %c%" SVf - "%c anywhere before EOF",q,SVfARG(sv),q); + Perl_croak(aTHX_ "Can't find string terminator %c%" SVf "%c" + " anywhere before EOF", q, SVfARG(sv), q); } #include "feature.h" @@ -1036,13 +1035,7 @@ Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags) SvCUR(PL_parser->linestr) + len+highhalf); PL_parser->bufend += len+highhalf; for (p = pv; p != e; p++) { - U8 c = (U8)*p; - if (! UTF8_IS_INVARIANT(c)) { - *bufptr++ = UTF8_TWO_BYTE_HI(c); - *bufptr++ = UTF8_TWO_BYTE_LO(c); - } else { - *bufptr++ = (char)c; - } + append_utf8_from_native_byte(*p, (U8 **) &bufptr); } } } else { @@ -1579,7 +1572,7 @@ Perl_lex_read_space(pTHX_ U32 flags) if (s == bufend) need_incline = 1; else - incline(s); + incline(s, bufend); } } else if (isSPACE(c)) { s++; @@ -1598,7 +1591,7 @@ Perl_lex_read_space(pTHX_ U32 flags) if (!got_more) break; if (can_incline && need_incline && PL_parser->rsfp) { - incline(s); + incline(s, bufend); need_incline = 0; } } else if (!c) { @@ -1630,7 +1623,7 @@ Note that C is a valid C and will always return C. */ bool -Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn) +Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn, bool curstash) { STRLEN len, origlen; char *p; @@ -1692,6 +1685,13 @@ Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn) origlen, UNI_DISPLAY_ISPRINT) : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII); + if (curstash && !memchr(SvPVX(name), ':', SvCUR(name))) { + SV *name2 = sv_2mortal(newSVsv(PL_curstname)); + sv_catpvs(name2, "::"); + sv_catsv(name2, (SV *)name); + name = name2; + } + if (proto_after_greedy_proto) Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO), "Prototype after '%c' for %" SVf " : %s", @@ -1724,7 +1724,7 @@ Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn) */ STATIC void -S_incline(pTHX_ const char *s) +S_incline(pTHX_ const char *s, const char *end) { const char *t; const char *n; @@ -1734,6 +1734,8 @@ S_incline(pTHX_ const char *s) PERL_ARGS_ASSERT_INCLINE; + assert(end >= s); + COPLINE_INC_WITH_HERELINES; if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL && s+1 == PL_bufend && *s == ';') { @@ -1745,8 +1747,8 @@ S_incline(pTHX_ const char *s) return; while (SPACE_OR_TAB(*s)) s++; - if (strEQs(s, "line")) - s += 4; + if (memBEGINs(s, (STRLEN) (end - s), "line")) + s += sizeof("line") - 1; else return; if (SPACE_OR_TAB(*s)) @@ -1765,7 +1767,7 @@ S_incline(pTHX_ const char *s) return; while (SPACE_OR_TAB(*s)) s++; - if (*s == '"' && (t = strchr(s+1, '"'))) { + if (*s == '"' && (t = (char *) memchr(s+1, '"', end - s))) { s++; e = t + 1; } @@ -1919,7 +1921,6 @@ STATIC void S_check_uni(pTHX) { const char *s; - const char *t; if (PL_oldoldbufptr != PL_last_uni) return; @@ -1928,7 +1929,7 @@ S_check_uni(pTHX) s = PL_last_uni; while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF) || *s == '-') s += UTF ? UTF8SKIP(s) : 1; - if ((t = strchr(s, '(')) && t < PL_bufptr) + if (s < PL_bufptr && memchr(s, '(', PL_bufptr - s)) return; Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS), @@ -2007,7 +2008,7 @@ S_force_next(pTHX_ I32 type) * S_postderef * * This subroutine handles postfix deref syntax after the arrow has already - * been emitted. @* $* etc. are emitted as two separate token right here. + * been emitted. @* $* etc. are emitted as two separate tokens right here. * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits * only the first, leaving yylex to find the next. */ @@ -2062,10 +2063,9 @@ STATIC SV * S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len) { SV * const sv = newSVpvn_utf8(start, len, - !IN_BYTES - && UTF - && !is_utf8_invariant_string((const U8*)start, len) - && is_utf8_string((const U8*)start, len)); + ! IN_BYTES + && UTF + && is_utf8_non_invariant_string((const U8*)start, len)); return sv; } @@ -2103,8 +2103,10 @@ S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack) if (check_keyword) { char *s2 = PL_tokenbuf; STRLEN len2 = len; - if (allow_pack && len > 6 && strEQs(s2, "CORE::")) - s2 += 6, len2 -= 6; + if (allow_pack && memBEGINPs(s2, len, "CORE::")) { + s2 += sizeof("CORE::") - 1; + len2 -= sizeof("CORE::") - 1; + } if (keyword(s2, len2, 0)) return start; } @@ -2388,6 +2390,8 @@ S_sublex_start(pTHX) PL_parser->lex_super_state = PL_lex_state; PL_parser->lex_sub_inwhat = (U16)op_type; PL_parser->lex_sub_op = PL_lex_op; + PL_parser->sub_no_recover = FALSE; + PL_parser->sub_error_count = PL_error_count; PL_lex_state = LEX_INTERPPUSH; PL_expect = XTERM; @@ -2567,6 +2571,20 @@ S_sublex_done(pTHX) else { const line_t l = CopLINE(PL_curcop); LEAVE; + if (PL_parser->sub_error_count != PL_error_count) { + const char * const name = OutCopFILE(PL_curcop); + if (PL_parser->sub_no_recover) { + const char * msg = ""; + if (PL_in_eval) { + SV *errsv = ERRSV; + if (SvCUR(ERRSV)) { + msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv)); + } + } + abort_execution(msg, name); + NOT_REACHED; + } + } if (PL_multi_close == '<') PL_parser->herelines += l - PL_multi_end; PL_bufend = SvPVX(PL_linestr); @@ -2595,8 +2613,10 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME; if (!SvCUR(res)) { - deprecate_fatal_in("5.28", "Unknown charname '' is deprecated"); - return res; + SvREFCNT_dec_NN(res); + /* diag_listed_as: Unknown charname '%s' */ + yyerror("Unknown charname ''"); + return NULL; } res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr, @@ -2616,8 +2636,7 @@ 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 (HvNAMELEN(stash) == sizeof("_charnames")-1 - && strEQ(name, "_charnames")) { + if (memEQs(name, HvNAMELEN(stash), "_charnames")) { return res; } } @@ -2708,6 +2727,9 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) } } if (*(s-1) == ' ') { + /* diag_listed_as: charnames alias definitions may not contain + trailing white-space; marked by <-- HERE in %s + */ yyerror_pv( Perl_form(aTHX_ "charnames alias definitions may not contain trailing " @@ -2730,6 +2752,8 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) (U8 *) PL_parser->bufend, 0, 0 /* 0 means don't die */ ); + /* diag_listed_as: Malformed UTF-8 returned by \N{%s} + immediately after '%s' */ yyerror_pv( Perl_form(aTHX_ "Malformed UTF-8 returned by %.*s immediately after '%.*s'", @@ -2747,6 +2771,8 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) /* The final %.*s makes sure that should the trailing NUL be missing * that this print won't run off the end of the string */ + /* diag_listed_as: Invalid character in \N{...}; marked by <-- HERE + in \N{%s} */ yyerror_pv( Perl_form(aTHX_ "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s", @@ -2758,6 +2784,9 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) } multi_spaces: + /* diag_listed_as: charnames alias definitions may not contain a + sequence of multiple spaces; marked by <-- HERE + in %s */ yyerror_pv( Perl_form(aTHX_ "charnames alias definitions may not contain a sequence of " @@ -2882,8 +2911,8 @@ S_scan_const(pTHX_ char *start) should we have to convert to UTF-8) */ SV *res; /* result from charnames */ - STRLEN offset_to_max; /* The offset in the output to where the range - high-end character is temporarily placed */ + STRLEN offset_to_max = 0; /* The offset in the output to where the range + high-end character is temporarily placed */ /* Does something require special handling in tr/// ? This avoids extra * work in a less likely case. As such, khw didn't feel it was worth @@ -2958,9 +2987,9 @@ S_scan_const(pTHX_ char *start) /* Here, we don't think we're in a range. If the new character * is not a hyphen; or if it is a hyphen, but it's too close to - * either edge to indicate a range, then it's a regular - * character. */ - if (*s != '-' || s >= send - 1 || s == start) { + * either edge to indicate a range, or if we haven't output any + * characters yet then it's a regular character. */ + if (*s != '-' || s >= send - 1 || s == start || d == SvPVX(sv)) { /* A regular character. Process like any other, but first * clear any flags */ @@ -3495,7 +3524,8 @@ S_scan_const(pTHX_ char *start) { const char* error; - bool valid = grok_bslash_o(&s, &uv, &error, + bool valid = grok_bslash_o(&s, PL_bufend, + &uv, &error, TRUE, /* Output warning */ FALSE, /* Not strict */ TRUE, /* Output warnings for @@ -3513,7 +3543,8 @@ S_scan_const(pTHX_ char *start) { const char* error; - bool valid = grok_bslash_x(&s, &uv, &error, + bool valid = grok_bslash_x(&s, PL_bufend, + &uv, &error, TRUE, /* Output warning */ FALSE, /* Not strict */ TRUE, /* Output warnings for @@ -3616,11 +3647,12 @@ S_scan_const(pTHX_ char *start) * For non-patterns, the named characters are converted to * their string equivalents. In patterns, named characters are * not converted to their ultimate forms for the same reasons - * that other escapes aren't. Instead, they are converted to - * the \N{U+...} form to get the value from the charnames that - * is in effect right now, while preserving the fact that it - * was a named character, so that the regex compiler knows - * this. + * that other escapes aren't (mainly that the ultimate + * character could be considered a meta-symbol by the regex + * compiler). Instead, they are converted to the \N{U+...} + * form to get the value from the charnames that is in effect + * right now, while preserving the fact that it was a named + * character, so that the regex compiler knows this. * * The structure of this section of code (besides checking for * errors and upgrading to utf8) is: @@ -3647,7 +3679,7 @@ S_scan_const(pTHX_ char *start) s++; /* If there is no matching '}', it is an error. */ - if (! (e = strchr(s, '}'))) { + if (! (e = (char *) memchr(s, '}', send - s))) { if (! PL_lex_inpat) { yyerror("Missing right brace on \\N{}"); } else { @@ -4126,7 +4158,7 @@ S_scan_const(pTHX_ char *start) /* This is the one truly awful dwimmer necessary to conflate C and sed. */ STATIC int -S_intuit_more(pTHX_ char *s) +S_intuit_more(pTHX_ char *s, char *e) { PERL_ARGS_ASSERT_INTUIT_MORE; @@ -4141,6 +4173,7 @@ S_intuit_more(pTHX_ char *s) return TRUE; if (*s != '{' && *s != '[') return FALSE; + PL_parser->sub_no_recover = TRUE; if (!PL_lex_inpat) return TRUE; @@ -4161,7 +4194,7 @@ S_intuit_more(pTHX_ char *s) /* this is terrifying, and it works */ int weight; char seen[256]; - const char * const send = strchr(s,']'); + const char * const send = (char *) memchr(s, ']', e - s); unsigned char un_char, last_un_char; char tmpbuf[sizeof PL_tokenbuf * 4]; @@ -4432,8 +4465,8 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) PL_parser->last_uni = buf + last_uni_pos; if (PL_parser->last_lop) PL_parser->last_lop = buf + last_lop_pos; - SvLEN(linestr) = SvCUR(linestr); - SvCUR(linestr) = s-SvPVX(linestr); + SvLEN_set(linestr, SvCUR(linestr)); + SvCUR_set(linestr, s - SvPVX(linestr)); PL_parser->filtered = 1; break; } @@ -4476,6 +4509,7 @@ I32 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) { filter_t funcp; + I32 ret; SV *datasv = NULL; /* This API is bad. It should have been using unsigned int for maxlen. Not sure if we want to change the API, but if not we should sanity @@ -4558,7 +4592,11 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ /* Return: <0:error, =0:eof, >0:not eof */ - return (*funcp)(aTHX_ idx, buf_sv, correct_length); + ENTER; + save_scalar(PL_errgv); + ret = (*funcp)(aTHX_ idx, buf_sv, correct_length); + LEAVE; + return ret; } STATIC char * @@ -4590,7 +4628,7 @@ S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len) PERL_ARGS_ASSERT_FIND_IN_MY_STASH; - if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__")) + if (memEQs(pkgname, len, "__PACKAGE__")) return PL_curstash; if (len > 2 @@ -4619,6 +4657,7 @@ S_tokenize_use(pTHX_ int is_use, char *s) { PERL_ARGS_ASSERT_TOKENIZE_USE; if (PL_expect != XSTATE) + /* diag_listed_as: "use" not allowed in expression */ yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression", is_use ? "use" : "no")); PL_expect = XTERM; @@ -4864,8 +4903,11 @@ Perl_yylex(pTHX) } else { I32 tmp; - if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) + if ( memBEGINs(s, (STRLEN) (PL_bufend - s), "L\\u") + || memBEGINs(s, (STRLEN) (PL_bufend - s), "U\\l")) + { tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */ + } if ((*s == 'L' || *s == 'U' || *s == 'F') && (strpbrk(PL_lex_casestack, "LUF"))) { @@ -4956,7 +4998,7 @@ Perl_yylex(pTHX) return yylex(); case LEX_INTERPENDMAYBE: - if (intuit_more(PL_bufptr)) { + if (intuit_more(PL_bufptr, PL_bufend)) { PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */ break; } @@ -5060,6 +5102,7 @@ Perl_yylex(pTHX) return yylex(); case LEX_FORMLINE: + assert(PL_lex_formbrack); s = scan_formline(PL_bufptr); if (!PL_lex_formbrack) { @@ -5110,15 +5153,46 @@ Perl_yylex(pTHX) /* read var name, including sigil, into PL_tokenbuf */ PL_tokenbuf[0] = sigil; parse_ident(&s, &dest, dest + sizeof(PL_tokenbuf) - 1, - 0, cBOOL(UTF), FALSE); + 0, cBOOL(UTF), FALSE, FALSE); *dest = '\0'; assert(PL_tokenbuf[1]); /* we have a variable name */ + } + else { + *PL_tokenbuf = 0; + PL_in_my = 0; + } + + s = skipspace(s); + /* parse the = for the default ourselves to avoid '+=' etc being accepted here + * as the ASSIGNOP, and exclude other tokens that start with = + */ + if (*s == '=' && (!s[1] || strchr("=~>", s[1]) == 0)) { + /* save now to report with the same context as we did when + * all ASSIGNOPS were accepted */ + PL_oldbufptr = s; + + ++s; + NEXTVAL_NEXTTOKE.ival = 0; + force_next(ASSIGNOP); + PL_expect = XTERM; + } + else if (*s == ',' || *s == ')') { + PL_expect = XOPERATOR; + } + else { + /* make sure the context shows the unexpected character and + * hopefully a bit more */ + if (*s) ++s; + while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')') + s++; + PL_bufptr = s; /* for error reporting */ + yyerror("Illegal operator following parameter in a subroutine signature"); + PL_in_my = 0; + } + if (*PL_tokenbuf) { NEXTVAL_NEXTTOKE.ival = sigil; force_next('p'); /* force a signature pending identifier */ } - else - PL_in_my = 0; - PL_expect = XOPERATOR; break; case ')': @@ -5164,12 +5238,23 @@ Perl_yylex(pTHX) else { c = Perl_form(aTHX_ "\\x%02X", (unsigned char)*s); } - len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart); - if (len > UNRECOGNIZED_PRECEDE_COUNT) { - d = UTF ? (char *) utf8_hop_back((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT, (U8 *)PL_linestart) : s - UNRECOGNIZED_PRECEDE_COUNT; - } else { + + if (s >= PL_linestart) { d = PL_linestart; } + else { + /* somehow (probably due to a parse failure), PL_linestart has advanced + * pass PL_bufptr, get a reasonable beginning of line + */ + d = s; + while (d > SvPVX(PL_linestr) && d[-1] && d[-1] != '\n') + --d; + } + len = UTF ? Perl_utf8_length(aTHX_ (U8 *) d, (U8 *) s) : (STRLEN) (s - d); + if (len > UNRECOGNIZED_PRECEDE_COUNT) { + d = UTF ? (char *) utf8_hop_back((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT, (U8 *)d) : s - UNRECOGNIZED_PRECEDE_COUNT; + } + Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %" UTF8f "<-- HERE near column %d", c, UTF8fARG(UTF, (s - d), d), (int) len + 1); @@ -5238,10 +5323,15 @@ Perl_yylex(pTHX) sv_catpvs(PL_linestr,"chomp;"); if (PL_minus_a) { if (PL_minus_F) { - if ((*PL_splitstr == '/' || *PL_splitstr == '\'' - || *PL_splitstr == '"') - && strchr(PL_splitstr + 1, *PL_splitstr)) + if ( ( *PL_splitstr == '/' + || *PL_splitstr == '\'' + || *PL_splitstr == '"') + && strchr(PL_splitstr + 1, *PL_splitstr)) + { + /* strchr is ok, because -F pattern can't contain + * embeddded NULs */ Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr); + } else { /* "q\0${splitstr}\0" is legal perl. Yes, even NUL bytes can be used as quoting characters. :-) */ @@ -5290,10 +5380,10 @@ Perl_yylex(pTHX) /* If it looks like the start of a BOM or raw UTF-16, * check if it in fact is. */ if (bof && PL_rsfp - && (*s == 0 + && ( *s == 0 || *(U8*)s == BOM_UTF8_FIRST_BYTE - || *(U8*)s >= 0xFE - || s[1] == 0)) + || *(U8*)s >= 0xFE + || s[1] == 0)) { Off_t offset = (IV)PerlIO_tell(PL_rsfp); bof = (offset == (Off_t)SvCUR(PL_linestr)); @@ -5309,7 +5399,9 @@ Perl_yylex(pTHX) } if (PL_parser->in_pod) { /* Incest with pod. */ - if (*s == '=' && strEQs(s, "=cut") && !isALPHA(s[4])) { + if ( memBEGINPs(s, (STRLEN) (PL_bufend - s), "=cut") + && !isALPHA(s[4])) + { SvPVCLEAR(PL_linestr); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); @@ -5318,7 +5410,7 @@ Perl_yylex(pTHX) } } if (PL_rsfp || PL_parser->filtered) - incline(s); + incline(s, PL_bufend); } while (PL_parser->in_pod); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); @@ -5396,8 +5488,6 @@ Perl_yylex(pTHX) d = instr(s,"perl -"); if (!d) { d = instr(s,"perl"); - if (d && d[4] == '6') - d = NULL; #if defined(DOSISH) /* avoid getting into infinite loops when shebang * line contains "Perl" rather than "perl" */ @@ -5545,24 +5635,20 @@ Perl_yylex(pTHX) && !PL_rsfp && !PL_parser->filtered) { /* handle eval qq[#line 1 "foo"\n ...] */ CopLINE_dec(PL_curcop); - incline(s); + incline(s, PL_bufend); } d = s; while (d < PL_bufend && *d != '\n') d++; if (d < PL_bufend) d++; - else if (d > PL_bufend) - /* Found by Ilya: feed random input to Perl. */ - Perl_croak(aTHX_ "panic: input overflow, %p > %p", - d, PL_bufend); s = d; if (in_comment && d == PL_bufend && PL_lex_state == LEX_INTERPNORMAL && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr && SvEVALED(PL_lex_repl) && d[-1] == '}') s--; else - incline(s); + incline(s, PL_bufend); if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { PL_lex_state = LEX_FORMLINE; force_next(FORMRBRACK); @@ -5576,11 +5662,8 @@ Perl_yylex(pTHX) { s++; if (s < PL_bufend) - incline(s); + incline(s, PL_bufend); } - else if (s > PL_bufend) - /* Found by Ilya: feed random input to Perl. */ - Perl_croak(aTHX_ "panic: input overflow"); } goto retry; case '-': @@ -5595,7 +5678,7 @@ Perl_yylex(pTHX) while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; - if (strEQs(s,"=>")) { + if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=>")) { s = force_word(PL_bufptr,BAREWORD,FALSE,FALSE); DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } ); OPERATOR('-'); /* unary minus */ @@ -5780,7 +5863,8 @@ Perl_yylex(pTHX) if (!PL_tokenbuf[1]) { PREREF('%'); } - if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { + if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) + && intuit_more(s, PL_bufend)) { if (*s == '[') PL_tokenbuf[0] = '@'; } @@ -5899,33 +5983,17 @@ Perl_yylex(pTHX) PL_lex_stuff = NULL; } else { - if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) { - sv_free(sv); - if (PL_in_my == KEY_our) { - deprecate_disappears_in("5.28", - "Attribute \"unique\" is deprecated"); - } - else - Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables"); - } - /* NOTE: any CV attrs applied here need to be part of the CVf_BUILTIN_ATTRS define in cv.h! */ - else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) { + if (!PL_in_my && memEQs(SvPVX(sv), len, "lvalue")) { sv_free(sv); CvLVALUE_on(PL_compcv); } - else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) { - sv_free(sv); - deprecate_disappears_in("5.28", - "Attribute \"locked\" is deprecated"); - } - else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) { + else if (!PL_in_my && memEQs(SvPVX(sv), len, "method")) { sv_free(sv); CvMETHOD_on(PL_compcv); } - else if (!PL_in_my && len == 5 - && strnEQ(SvPVX(sv), "const", len)) + else if (!PL_in_my && memEQs(SvPVX(sv), len, "const")) { sv_free(sv); Perl_ck_warner_d(aTHX_ @@ -6222,9 +6290,11 @@ Perl_yylex(pTHX) PL_expect = XTERM; break; } - if (strEQs(s, "sub")) { + if (memBEGINs(s, (STRLEN) (PL_bufend - s), "sub")) { + PL_bufptr = s; d = s + 3; d = skipspace(d); + s = PL_bufptr; if (*d == ':') { PL_expect = XTERM; break; @@ -6246,6 +6316,7 @@ Perl_yylex(pTHX) if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF) TOKEN(0); rightbracket: + assert(s != PL_bufend); s++; if (PL_lex_brackets <= 0) /* diag_listed_as: Unmatched right %s bracket */ @@ -6276,7 +6347,7 @@ Perl_yylex(pTHX) return yylex(); /* ignore fake brackets */ } force_next(formbrack ? '.' : '}'); - if (formbrack) LEAVE; + if (formbrack) LEAVE_with_name("lex_format"); if (formbrack == 2) { /* means . where arguments were expected */ force_next(';'); TOKEN(FORMRBRACK); @@ -6355,7 +6426,9 @@ Perl_yylex(pTHX) { const char tmp = *s++; if (tmp == '=') { - if ((s == PL_linestart+2 || s[-3] == '\n') && strEQs(s, "=====")) { + if ( (s == PL_linestart+2 || s[-3] == '\n') + && memBEGINs(s, (STRLEN) (PL_bufend - s), "=====")) + { s = vcs_conflict_marker(s + 5); goto retry; } @@ -6387,19 +6460,21 @@ Perl_yylex(pTHX) && isALPHA(tmp) && (s == PL_linestart+1 || s[-2] == '\n') ) { - if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered) - || PL_lex_state != LEX_NORMAL) { + if ( (PL_in_eval && !PL_rsfp && !PL_parser->filtered) + || PL_lex_state != LEX_NORMAL) + { d = PL_bufend; while (s < d) { if (*s++ == '\n') { - incline(s); - if (strEQs(s,"=cut")) { - s = strchr(s,'\n'); + incline(s, PL_bufend); + if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=cut")) + { + s = (char *) memchr(s,'\n', d - s); if (s) s++; else s = d; - incline(s); + incline(s, PL_bufend); goto retry; } } @@ -6421,7 +6496,7 @@ Perl_yylex(pTHX) t++; if (*t == '\n' || *t == '#') { formbrack = 1; - ENTER; + ENTER_with_name("lex_format"); SAVEI8(PL_parser->form_lex_state); SAVEI32(PL_lex_formbrack); PL_parser->form_lex_state = PL_lex_state; @@ -6471,10 +6546,12 @@ Perl_yylex(pTHX) OPERATOR('!'); case '<': if (PL_expect != XOPERATOR) { - if (s[1] != '<' && !strchr(s,'>')) + if (s[1] != '<' && !memchr(s,'>', PL_bufend - s)) check_uni(); if (s[1] == '<' && s[2] != '>') { - if ((s == PL_linestart || s[-1] == '\n') && strEQs(s+2, "<<<<<")) { + if ( (s == PL_linestart || s[-1] == '\n') + && memBEGINs(s+2, (STRLEN) (PL_bufend - (s+2)), "<<<<<")) + { s = vcs_conflict_marker(s + 7); goto retry; } @@ -6489,7 +6566,9 @@ Perl_yylex(pTHX) { char tmp = *s++; if (tmp == '<') { - if ((s == PL_linestart+2 || s[-3] == '\n') && strEQs(s, "<<<<<")) { + if ( (s == PL_linestart+2 || s[-3] == '\n') + && memBEGINs(s, (STRLEN) (PL_bufend - s), "<<<<<")) + { s = vcs_conflict_marker(s + 5); goto retry; } @@ -6533,7 +6612,9 @@ Perl_yylex(pTHX) { const char tmp = *s++; if (tmp == '>') { - if ((s == PL_linestart+2 || s[-3] == '\n') && strEQs(s, ">>>>>")) { + if ( (s == PL_linestart+2 || s[-3] == '\n') + && memBEGINs(s, (STRLEN) (PL_bufend - s), ">>>>>")) + { s = vcs_conflict_marker(s + 5); goto retry; } @@ -6565,12 +6646,7 @@ Perl_yylex(pTHX) case '$': CLINE; - if (PL_expect == XOPERATOR) { - if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { - return deprecate_commaless_var_list(); - } - } - else if (PL_expect == XPOSTDEREF) { + if (PL_expect == XPOSTDEREF) { if (s[1] == '#') { s++; POSTDEREF(DOLSHARP); @@ -6622,8 +6698,8 @@ Perl_yylex(pTHX) if (PL_lex_state == LEX_NORMAL || PL_lex_brackets) s = skipspace(s); - if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) - && intuit_more(s)) { + if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) + && intuit_more(s, PL_bufend)) { if (*s == '[') { PL_tokenbuf[0] = '@'; if (ckWARN(WARN_SYNTAX)) { @@ -6648,30 +6724,32 @@ Perl_yylex(pTHX) else if (*s == '{') { char *t; PL_tokenbuf[0] = '%'; - if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX) - && (t = strchr(s, '}')) && (t = strchr(t, '='))) - { - char tmpbuf[sizeof PL_tokenbuf]; - do { - t++; - } while (isSPACE(*t)); - if (isIDFIRST_lazy_if_safe(t, PL_bufend, UTF)) { - STRLEN len; - t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, - &len); - while (isSPACE(*t)) - t++; - if ( *t == ';' - && get_cvn_flags(tmpbuf, len, UTF - ? SVf_UTF8 - : 0)) - { - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "You need to quote \"%" UTF8f "\"", - UTF8fARG(UTF, len, tmpbuf)); - } - } - } + if ( strEQ(PL_tokenbuf+1, "SIG") + && ckWARN(WARN_SYNTAX) + && (t = (char *) memchr(s, '}', PL_bufend - s)) + && (t = (char *) memchr(t, '=', PL_bufend - t))) + { + char tmpbuf[sizeof PL_tokenbuf]; + do { + t++; + } while (isSPACE(*t)); + if (isIDFIRST_lazy_if_safe(t, PL_bufend, UTF)) { + STRLEN len; + t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, + &len); + while (isSPACE(*t)) + t++; + if ( *t == ';' + && get_cvn_flags(tmpbuf, len, UTF + ? SVf_UTF8 + : 0)) + { + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "You need to quote \"%" UTF8f "\"", + UTF8fARG(UTF, len, tmpbuf)); + } + } + } } } @@ -6751,7 +6829,9 @@ Perl_yylex(pTHX) } if (PL_lex_state == LEX_NORMAL) s = skipspace(s); - if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { + if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) + && intuit_more(s, PL_bufend)) + { if (*s == '{') PL_tokenbuf[0] = '%'; @@ -6860,13 +6940,9 @@ Perl_yylex(pTHX) TERM(THING); case '\'': - if ( PL_expect == XOPERATOR - && (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack)) - return deprecate_commaless_var_list(); - s = scan_str(s,FALSE,FALSE,FALSE,NULL); if (!s) - missingterm(NULL); + missingterm(NULL, 0); COPLINE_SET_FROM_MULTI_END; DEBUG_T( { printbuf("### Saw string before %s\n", s); } ); if (PL_expect == XOPERATOR) { @@ -6876,10 +6952,6 @@ Perl_yylex(pTHX) TERM(sublex_start()); case '"': - if ( PL_expect == XOPERATOR - && (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack)) - return deprecate_commaless_var_list(); - s = scan_str(s,FALSE,FALSE,FALSE,NULL); DEBUG_T( { if (s) @@ -6892,7 +6964,7 @@ Perl_yylex(pTHX) no_op("String",s); } if (!s) - missingterm(NULL); + missingterm(NULL, 0); pl_yylval.ival = OP_CONST; /* FIXME. I think that this can be const if char *d is replaced by more localised variables. */ @@ -6918,7 +6990,7 @@ Perl_yylex(pTHX) if (PL_expect == XOPERATOR) no_op("Backticks",s); if (!s) - missingterm(NULL); + missingterm(NULL, 0); pl_yylval.ival = OP_BACKTICK; TERM(sublex_start()); @@ -7023,7 +7095,7 @@ Perl_yylex(pTHX) /* x::* is just a word, unless x is "CORE" */ if (!anydelim && *s == ':' && s[1] == ':') { - if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE; + if (memEQs(PL_tokenbuf, len, "CORE")) goto case_KEY_CORE; goto just_a_word; } @@ -7205,12 +7277,26 @@ Perl_yylex(pTHX) orig_keyword = 0; lex = 0; off = 0; + /* FALLTHROUGH */ default: /* not a keyword */ just_a_word: { int pkgname = 0; const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); bool safebw; + bool no_op_error = FALSE; + if (PL_expect == XOPERATOR) { + if (PL_bufptr == PL_linestart) { + CopLINE_dec(PL_curcop); + Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi); + CopLINE_inc(PL_curcop); + } + else + /* We want to call no_op with s pointing after the + bareword, so defer it. But we want it to come + before the Bad name croak. */ + no_op_error = TRUE; + } /* Get the rest if it looks like a package qualifier */ @@ -7218,6 +7304,10 @@ Perl_yylex(pTHX) STRLEN morelen; s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len, TRUE, &morelen); + if (no_op_error) { + no_op("Bareword",s); + no_op_error = FALSE; + } if (!morelen) Perl_croak(aTHX_ "Bad name after %" UTF8f "%s", UTF8fARG(UTF, len, PL_tokenbuf), @@ -7226,15 +7316,8 @@ Perl_yylex(pTHX) pkgname = 1; } - if (PL_expect == XOPERATOR) { - if (PL_bufptr == PL_linestart) { - CopLINE_dec(PL_curcop); - Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi); - CopLINE_inc(PL_curcop); - } - else + if (no_op_error) no_op("Bareword",s); - } /* See if the name is "Foo::", in which case Foo is a bareword @@ -7545,10 +7628,10 @@ Perl_yylex(pTHX) if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0)) { /* PL_warn_reserved is constant */ - GCC_DIAG_IGNORE(-Wformat-nonliteral); + GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved, PL_tokenbuf); - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; } } } @@ -7603,14 +7686,6 @@ Perl_yylex(pTHX) if (!GvIO(gv)) GvIOp(gv) = newIO(); IoIFP(GvIOp(gv)) = PL_rsfp; -#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) - { - const int fd = PerlIO_fileno(PL_rsfp); - if (fd >= 3) { - fcntl(fd,F_SETFD, FD_CLOEXEC); - } - } -#endif /* Mark this internal pseudo-handle as clean */ IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT; if ((PerlIO*)PL_rsfp == PerlIO_stdin()) @@ -7795,7 +7870,7 @@ Perl_yylex(pTHX) *PL_tokenbuf = '&'; d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, 1, &len); - if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE")) + if (len && memNEs(PL_tokenbuf+1, len, "CORE") && !keyword(PL_tokenbuf + 1, len, 0)) { SSize_t off = s-SvPVX(PL_linestr); d = skipspace(d); @@ -7913,15 +7988,19 @@ Perl_yylex(pTHX) && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) { char *p = s; + SSize_t s_off = s - SvPVX(PL_linestr); - if ((PL_bufend - p) >= 3 - && strEQs(p, "my") && isSPACE(*(p + 2))) + if ( memBEGINPs(p, (STRLEN) (PL_bufend - p), "my") + && isSPACE(*(p + 2))) { - p += 2; + p += 2; + } + else if ( memBEGINPs(p, (STRLEN) (PL_bufend - p), "our") + && isSPACE(*(p + 3))) + { + p += 3; } - else if ((PL_bufend - p) >= 4 - && strEQs(p, "our") && isSPACE(*(p + 3))) - p += 3; + p = skipspace(p); /* skip optional package name, as in "for my abc $x (..)" */ if (isIDFIRST_lazy_if_safe(p, PL_bufend, UTF)) { @@ -7930,6 +8009,9 @@ Perl_yylex(pTHX) } if (*p != '$' && *p != '\\') Perl_croak(aTHX_ "Missing $ on loop variable"); + + /* The buffer may have been reallocated, update s */ + s = SvPVX(PL_linestr) + s_off; } OPERATOR(FOR); @@ -8169,7 +8251,7 @@ Perl_yylex(pTHX) s = skipspace(s); if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) { s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); - if (len == 3 && strEQs(PL_tokenbuf, "sub")) + if (memEQs(PL_tokenbuf, len, "sub")) goto really_sub; PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len); if (!PL_in_my_stash) { @@ -8286,7 +8368,7 @@ Perl_yylex(pTHX) case KEY_q: s = scan_str(s,FALSE,FALSE,FALSE,NULL); if (!s) - missingterm(NULL); + missingterm(NULL, 0); COPLINE_SET_FROM_MULTI_END; pl_yylval.ival = OP_CONST; TERM(sublex_start()); @@ -8298,7 +8380,7 @@ Perl_yylex(pTHX) OP *words = NULL; s = scan_str(s,FALSE,FALSE,FALSE,NULL); if (!s) - missingterm(NULL); + missingterm(NULL, 0); COPLINE_SET_FROM_MULTI_END; PL_expect = XOPERATOR; if (SvCUR(PL_lex_stuff)) { @@ -8347,7 +8429,7 @@ Perl_yylex(pTHX) case KEY_qq: s = scan_str(s,FALSE,FALSE,FALSE,NULL); if (!s) - missingterm(NULL); + missingterm(NULL, 0); pl_yylval.ival = OP_STRINGIFY; if (SvIVX(PL_lex_stuff) == '\'') SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */ @@ -8360,7 +8442,7 @@ Perl_yylex(pTHX) case KEY_qx: s = scan_str(s,FALSE,FALSE,FALSE,NULL); if (!s) - missingterm(NULL); + missingterm(NULL, 0); pl_yylval.ival = OP_BACKTICK; TERM(sublex_start()); @@ -8644,7 +8726,8 @@ Perl_yylex(pTHX) COPLINE_SET_FROM_MULTI_END; if (!s) Perl_croak(aTHX_ "Prototype not terminated"); - (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO)); + (void)validate_proto(PL_subname, PL_lex_stuff, + ckWARN(WARN_ILLEGALPROTO), 0); have_proto = TRUE; s = skipspace(s); @@ -8869,6 +8952,7 @@ S_pending_ident(pTHX) DEBUG_T({ PerlIO_printf(Perl_debug_log, "### Pending identifier '%s'\n", PL_tokenbuf); }); + assert(tokenbuf_len >= 2); /* if we're in a my(), we can't allow dynamics here. $foo'bar has already been turned into $foo::bar, so @@ -8879,8 +8963,11 @@ S_pending_ident(pTHX) if (PL_in_my) { if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */ if (has_colon) + /* diag_listed_as: No package name allowed for variable %s + in "our" */ yyerror_pv(Perl_form(aTHX_ "No package name allowed for " - "variable %s in \"our\"", + "%se %s in \"our\"", + *PL_tokenbuf=='&' ?"subroutin":"variabl", PL_tokenbuf), UTF ? SVf_UTF8 : 0); tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0); } @@ -8889,13 +8976,13 @@ S_pending_ident(pTHX) if (has_colon) { /* "my" variable %s can't be in a package */ /* PL_no_myglob is constant */ - GCC_DIAG_IGNORE(-Wformat-nonliteral); + GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); yyerror_pv(Perl_form(aTHX_ PL_no_myglob, PL_in_my == KEY_my ? "my" : "state", *PL_tokenbuf == '&' ? "subroutin" : "variabl", PL_tokenbuf), UTF ? SVf_UTF8 : 0); - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; } if (PL_in_my == KEY_sigvar) { @@ -9207,8 +9294,10 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, PERL_STATIC_INLINE void S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, - bool is_utf8, bool check_dollar) + bool is_utf8, bool check_dollar, bool tick_warn) { + int saw_tick = 0; + const char *olds = *s; PERL_ARGS_ASSERT_PARSE_IDENT; while (*s < PL_bufend) { @@ -9242,6 +9331,7 @@ S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, *(*d)++ = ':'; *(*d)++ = ':'; (*s)++; + saw_tick++; } else if (allow_package && **s == ':' && (*s)[1] == ':' /* Disallow things like Foo::$bar. For the curious, this is @@ -9255,6 +9345,30 @@ S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, else break; } + if (UNLIKELY(tick_warn && saw_tick && PL_lex_state == LEX_INTERPNORMAL + && !PL_lex_brackets && ckWARN(WARN_SYNTAX))) { + char *d; + char *d2; + Newx(d, *s - olds + saw_tick + 2, char); /* +2 for $# */ + d2 = d; + SAVEFREEPV(d); + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "Old package separator used in string"); + if (olds[-1] == '#') + *d2++ = olds[-2]; + *d2++ = olds[-1]; + while (olds < *s) { + if (*olds == '\'') { + *d2++ = '\\'; + *d2++ = *olds++; + } + else + *d2++ = *olds++; + } + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "\t(Did you mean \"%" UTF8f "\" instead?)\n", + UTF8fARG(is_utf8, d2-d, d)); + } return; } @@ -9270,7 +9384,7 @@ S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN PERL_ARGS_ASSERT_SCAN_WORD; - parse_ident(&s, &d, e, allow_package, is_utf8, TRUE); + parse_ident(&s, &d, e, allow_package, is_utf8, TRUE, FALSE); *d = '\0'; *slp = d - dest; return s; @@ -9318,7 +9432,7 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) } } else { /* See if it is a "normal" identifier */ - parse_ident(&s, &d, e, 1, is_utf8, FALSE); + parse_ident(&s, &d, e, 1, is_utf8, FALSE, TRUE); } *d = '\0'; d = dest; @@ -9337,7 +9451,7 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) || isDIGIT_A((U8)s[1]) || s[1] == '$' || s[1] == '{' - || strEQs(s+1,"::")) ) + || memBEGINs(s+1, (STRLEN) (PL_bufend - (s+1)), "::")) ) { /* Dereferencing a value in a scalar variable. The alternatives are different syntaxes for a scalar variable. @@ -9384,19 +9498,36 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) bool skip; char *s2; /* If we were processing {...} notation then... */ - if (isIDFIRST_lazy_if_safe(d, e, is_utf8)) { - /* if it starts as a valid identifier, assume that it is one. - (the later check for } being at the expected point will trap - cases where this doesn't pan out.) */ - d += is_utf8 ? UTF8SKIP(d) : 1; - parse_ident(&s, &d, e, 1, is_utf8, TRUE); - *d = '\0'; + if (isIDFIRST_lazy_if_safe(d, e, is_utf8) + || (!isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */ + && isWORDCHAR(*s)) + ) { + /* note we have to check for a normal identifier first, + * as it handles utf8 symbols, and only after that has + * been ruled out can we look at the caret words */ + if (isIDFIRST_lazy_if_safe(d, e, is_utf8) ) { + /* if it starts as a valid identifier, assume that it is one. + (the later check for } being at the expected point will trap + cases where this doesn't pan out.) */ + d += is_utf8 ? UTF8SKIP(d) : 1; + parse_ident(&s, &d, e, 1, is_utf8, TRUE, TRUE); + *d = '\0'; + } + else { /* caret word: ${^Foo} ${^CAPTURE[0]} */ + d++; + while (isWORDCHAR(*s) && d < e) { + *d++ = *s++; + } + if (d >= e) + Perl_croak(aTHX_ "%s", ident_too_long); + *d = '\0'; + } tmp_copline = CopLINE(PL_curcop); if (s < PL_bufend && isSPACE(*s)) { s = skipspace(s); } if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { - /* ${foo[0]} and ${foo{bar}} notation. */ + /* ${foo[0]} and ${foo{bar}} and ${^CAPTURE[0]} notation. */ if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) { const char * const brack = (const char *) @@ -9415,26 +9546,16 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) return s; } } - /* Handle extended ${^Foo} variables - * 1999-02-27 mjd-perl-patch@plover.com */ - else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */ - && isWORDCHAR(*s)) - { - d++; - while (isWORDCHAR(*s) && d < e) { - *d++ = *s++; - } - if (d >= e) - Perl_croak(aTHX_ "%s", ident_too_long); - *d = '\0'; - } if ( !tmp_copline ) tmp_copline = CopLINE(PL_curcop); - if ((skip = s < PL_bufend && isSPACE(*s))) + if ((skip = s < PL_bufend && isSPACE(*s))) { /* Avoid incrementing line numbers or resetting PL_linestart, in case we have to back up. */ + STRLEN s_off = s - SvPVX(PL_linestr); s2 = peekspace(s); + s = SvPVX(PL_linestr) + s_off; + } else s2 = s; @@ -9476,9 +9597,12 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) CopLINE_set(PL_curcop, orig_copline); PL_parser->herelines = herelines; *dest = '\0'; + PL_parser->sub_no_recover = TRUE; } } - else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s)) + else if ( PL_lex_state == LEX_INTERPNORMAL + && !PL_lex_brackets + && !intuit_more(s, PL_bufend)) PL_lex_state = LEX_INTERPEND; return s; } @@ -9711,18 +9835,14 @@ S_scan_subst(pTHX_ char *start) PL_multi_end = 0; pm->op_pmflags |= PMf_EVAL; - while (es-- > 0) { - if (es) - sv_catpvs(repl, "eval "); - else - sv_catpvs(repl, "do "); - } - sv_catpvs(repl, "{"); + for (; es > 1; es--) { + sv_catpvs(repl, "eval "); + } + sv_catpvs(repl, "do {"); sv_catsv(repl, PL_parser->lex_sub_repl); sv_catpvs(repl, "}"); SvREFCNT_dec(PL_parser->lex_sub_repl); PL_parser->lex_sub_repl = repl; - es = 1; } @@ -9878,11 +9998,9 @@ S_scan_heredoc(pTHX_ char *s) else term = '"'; if (! isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF)) - deprecate_fatal_in("5.28", "Use of bare << to mean <<\"\" is deprecated"); + Perl_croak(aTHX_ "Use of bare << to mean <<\"\" is forbidden"); peek = s; - while ( - isWORDCHAR_lazy_if_safe(peek, PL_bufend, UTF)) - { + while (isWORDCHAR_lazy_if_safe(peek, PL_bufend, UTF)) { peek += UTF ? UTF8SKIP(peek) : 1; } len = (peek - s >= e - d) ? (e - d) : (peek - s); @@ -9897,7 +10015,7 @@ S_scan_heredoc(pTHX_ char *s) len = d - PL_tokenbuf; #ifndef PERL_STRICT_CR - d = strchr(s, '\r'); + d = (char *) memchr(s, '\r', PL_bufend - s); if (d) { char * const olds = s; s = d; @@ -10006,8 +10124,9 @@ S_scan_heredoc(pTHX_ char *s) /* No whitespace or all! */ if (backup == s || *backup == '\n') { - Newxz(indent, indent_len + 1, char); + Newx(indent, indent_len + 1, char); memcpy(indent, backup + 1, indent_len); + indent[indent_len] = 0; s--; /* before our delimiter */ PL_parser->herelines--; /* this line doesn't count */ break; @@ -10141,8 +10260,9 @@ S_scan_heredoc(pTHX_ char *s) /* All whitespace or none! */ if (backup == found || SPACE_OR_TAB(*backup)) { - Newxz(indent, indent_len + 1, char); + Newx(indent, indent_len + 1, char); memcpy(indent, backup, indent_len); + indent[indent_len] = 0; SvREFCNT_dec(PL_linestr); PL_linestr = linestr_save; PL_linestart = SvPVX(linestr_save); @@ -10233,7 +10353,7 @@ S_scan_heredoc(pTHX_ char *s) interminable: SvREFCNT_dec(tmpstr); CopLINE_set(PL_curcop, origline); - missingterm(PL_tokenbuf + 1); + missingterm(PL_tokenbuf + 1, sizeof(PL_tokenbuf) - 1); } /* scan_inputsymbol @@ -10266,7 +10386,7 @@ S_scan_inputsymbol(pTHX_ char *start) PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL; - end = strchr(s, '\n'); + end = (char *) memchr(s, '\n', PL_bufend - s); if (!end) end = PL_bufend; if (s[1] == '<' && s[2] == '>' && s[3] == '>') { @@ -10461,7 +10581,7 @@ S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re I32 brackets = 1; /* bracket nesting level */ bool has_utf8 = FALSE; /* is there any utf8 content? */ IV termcode; /* terminating char. code */ - U8 termstr[UTF8_MAXBYTES]; /* terminating string */ + U8 termstr[UTF8_MAXBYTES+1]; /* terminating string */ STRLEN termlen; /* length of terminating string */ line_t herelines; @@ -10888,6 +11008,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) digit: just_zero = FALSE; if (!overflowed) { + assert(shift >= 0); x = u << shift; /* make room for the digit */ total_bits += shift; @@ -10968,19 +11089,22 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) NV nv_mult = 1.0; #endif bool accumulate = TRUE; - for (h++; (isXDIGIT(*h) || *h == '_'); h++) { + U8 b; + int lim = 1 << shift; + for (h++; ((isXDIGIT(*h) && (b = XDIGIT_VALUE(*h)) < lim) || + *h == '_'); h++) { if (isXDIGIT(*h)) { - U8 b = XDIGIT_VALUE(*h); significant_bits += shift; #ifdef HEXFP_UQUAD if (accumulate) { if (significant_bits < NV_MANT_DIG) { /* We are in the long "run" of xdigits, * accumulate the full four bits. */ + assert(shift >= 0); hexfp_uquad <<= shift; hexfp_uquad |= b; hexfp_frac_bits += shift; - } else { + } else if (significant_bits - shift < NV_MANT_DIG) { /* We are at a hexdigit either at, * or straddling, the edge of mantissa. * We will try grabbing as many as @@ -10989,7 +11113,9 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) significant_bits - NV_MANT_DIG; if (tail <= 0) tail += shift; + assert(tail >= 0); hexfp_uquad <<= tail; + assert((shift - tail) >= 0); hexfp_uquad |= b >> (shift - tail); hexfp_frac_bits += tail; @@ -11028,7 +11154,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) } #else /* HEXFP_NV */ if (accumulate) { - nv_mult /= 16.0; + nv_mult /= nvshift[shift]; if (nv_mult > 0.0) hexfp_nv += b * nv_mult; else @@ -11209,9 +11335,11 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p'))) && strchr("+-0123456789_", s[1])) { - floatit = TRUE; + int exp_digits = 0; + const char *save_s = s; + char * save_d = d; - /* regardless of whether user said 3E5 or 3e5, use lower 'e', + /* regardless of whether user said 3E5 or 3e5, use lower 'e', ditto for p (hexfloats) */ if ((isALPHA_FOLD_EQ(*s, 'e'))) { /* At least some Mach atof()s don't grok 'E' */ @@ -11243,6 +11371,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) /* read digits of exponent */ while (isDIGIT(*s) || *s == '_') { if (isDIGIT(*s)) { + ++exp_digits; if (d >= e) Perl_croak(aTHX_ "%s", number_too_long); *d++ = *s++; @@ -11254,6 +11383,20 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) lastub = s++; } } + + if (!exp_digits) { + /* no exponent digits, the [eEpP] could be for something else, + * though in practice we don't get here for p since that's preparsed + * earlier, and results in only the 0xX being consumed, so behave similarly + * for decimal floats and consume only the D.DD, leaving the [eE] to the + * next token. + */ + s = save_s; + d = save_d; + } + else { + floatit = TRUE; + } } @@ -11280,7 +11423,6 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) floatit = TRUE; } if (floatit) { - STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD(); /* terminate the string */ *d = '\0'; if (UNLIKELY(hexfp)) { @@ -11297,7 +11439,6 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) } else { nv = Atof(PL_tokenbuf); } - RESTORE_LC_NUMERIC_UNDERLYING(); sv = newSVnv(nv); } @@ -11396,7 +11537,7 @@ S_scan_formline(pTHX_ char *s) if (!got_some) break; } - incline(s); + incline(s, PL_bufend); } enough: if (!SvCUR(stuff) || needargs) @@ -11644,7 +11785,9 @@ S_swallow_bom(pTHX_ U8 *s) /* diag_listed_as: Unsupported script encoding %s */ Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE"); #ifndef PERL_NO_UTF16_FILTER +#ifdef DEBUGGING if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n"); +#endif s += 2; if (PL_bufend > (char*)s) { s = add_utf16_textfilter(s, TRUE); @@ -11658,7 +11801,9 @@ S_swallow_bom(pTHX_ U8 *s) case 0xFE: if (s[1] == 0xFF) { /* UTF-16 big-endian? */ #ifndef PERL_NO_UTF16_FILTER +#ifdef DEBUGGING if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n"); +#endif s += 2; if (PL_bufend > (char *)s) { s = add_utf16_textfilter(s, FALSE); @@ -11670,10 +11815,11 @@ S_swallow_bom(pTHX_ U8 *s) } break; case BOM_UTF8_FIRST_BYTE: { - const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */ - if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) { + if (memBEGINs(s+1, slen - 1, BOM_UTF8_TAIL)) { +#ifdef DEBUGGING if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n"); - s += len + 1; /* UTF-8 */ +#endif + s += sizeof(BOM_UTF8) - 1; /* UTF-8 */ } break; } @@ -11691,7 +11837,9 @@ S_swallow_bom(pTHX_ U8 *s) * 00 xx 00 xx * are a good indicator of UTF-16BE. */ #ifndef PERL_NO_UTF16_FILTER +#ifdef DEBUGGING if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n"); +#endif s = add_utf16_textfilter(s, FALSE); #else /* diag_listed_as: Unsupported script encoding %s */ @@ -11707,7 +11855,9 @@ S_swallow_bom(pTHX_ U8 *s) * xx 00 xx 00 * are a good indicator of UTF-16LE. */ #ifndef PERL_NO_UTF16_FILTER +#ifdef DEBUGGING if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n"); +#endif s = add_utf16_textfilter(s, TRUE); #else /* diag_listed_as: Unsupported script encoding %s */ @@ -11808,9 +11958,14 @@ S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) } } + /* 'chars' isn't quite the right name, as code points above 0xFFFF + * require 4 bytes per char */ chars = SvCUR(utf16_buffer) >> 1; have = SvCUR(utf8_buffer); - SvGROW(utf8_buffer, have + chars * 3 + 1); + + /* Assume the worst case size as noted by the functions: twice the + * number of input bytes */ + SvGROW(utf8_buffer, have + chars * 4 + 1); if (reverse) { end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer), @@ -11969,6 +12124,79 @@ Perl_keyword_plugin_standard(pTHX_ return KEYWORD_PLUGIN_DECLINE; } +/* +=for apidoc Amx|void|wrap_keyword_plugin|Perl_keyword_plugin_t new_plugin|Perl_keyword_plugin_t *old_plugin_p + +Puts a C function into the chain of keyword plugins. This is the +preferred way to manipulate the L variable. +C is a pointer to the C function that is to be added to the +keyword plugin chain, and C points to the storage location +where a pointer to the next function in the chain will be stored. The +value of C is written into the L variable, +while the value previously stored there is written to C<*old_plugin_p>. + +L is global to an entire process, and a module wishing +to hook keyword parsing may find itself invoked more than once per +process, typically in different threads. To handle that situation, this +function is idempotent. The location C<*old_plugin_p> must initially +(once per process) contain a null pointer. A C variable of static +duration (declared at file scope, typically also marked C to give +it internal linkage) will be implicitly initialised appropriately, if it +does not have an explicit initialiser. This function will only actually +modify the plugin chain if it finds C<*old_plugin_p> to be null. This +function is also thread safe on the small scale. It uses appropriate +locking to avoid race conditions in accessing L. + +When this function is called, the function referenced by C +must be ready to be called, except for C<*old_plugin_p> being unfilled. +In a threading situation, C may be called immediately, even +before this function has returned. C<*old_plugin_p> will always be +appropriately set before C is called. If C +decides not to do anything special with the identifier that it is given +(which is the usual case for most calls to a keyword plugin), it must +chain the plugin function referenced by C<*old_plugin_p>. + +Taken all together, XS code to install a keyword plugin should typically +look something like this: + + static Perl_keyword_plugin_t next_keyword_plugin; + static OP *my_keyword_plugin(pTHX_ + char *keyword_plugin, STRLEN keyword_len, OP **op_ptr) + { + if (memEQs(keyword_ptr, keyword_len, + "my_new_keyword")) { + ... + } else { + return next_keyword_plugin(aTHX_ + keyword_ptr, keyword_len, op_ptr); + } + } + BOOT: + wrap_keyword_plugin(my_keyword_plugin, + &next_keyword_plugin); + +Direct access to L should be avoided. + +=cut +*/ + +void +Perl_wrap_keyword_plugin(pTHX_ + Perl_keyword_plugin_t new_plugin, Perl_keyword_plugin_t *old_plugin_p) +{ + dVAR; + + PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_WRAP_KEYWORD_PLUGIN; + if (*old_plugin_p) return; + KEYWORD_PLUGIN_MUTEX_LOCK; + if (!*old_plugin_p) { + *old_plugin_p = PL_keyword_plugin; + PL_keyword_plugin = new_plugin; + } + KEYWORD_PLUGIN_MUTEX_UNLOCK; +} + #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p) static void S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)