X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/c96809061c2def2e6554bf2f122c294e7396fb98..93cd6fca2453b14be3c49ba8708aa01b7dab5829:/toke.c?ds=sidebyside diff --git a/toke.c b/toke.c index 8cebad1..f94c0d5 100644 --- a/toke.c +++ b/toke.c @@ -464,13 +464,6 @@ S_printbuf(pTHX_ const char *const fmt, const char *const s) #endif -static int -S_deprecate_commaless_var_list(pTHX) { - PL_expect = XTERM; - deprecate("comma-less variable list"); - 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" @@ -669,7 +668,7 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) Creates and initialises a new lexer/parser state object, supplying a context in which to lex and parse from a new source of Perl code. A pointer to the new state object is placed in L. An entry -is made on the save stack so that upon unwinding the new state object +is made on the save stack so that upon unwinding, the new state object will be destroyed and the former value of L will be restored. Nothing else need be done to clean up the parsing context. @@ -701,6 +700,7 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags) { const char *s = NULL; yy_parser *parser, *oparser; + if (flags && flags & ~LEX_START_FLAGS) Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start"); @@ -726,6 +726,7 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags) parser->lex_state = LEX_NORMAL; parser->expect = XSTATE; parser->rsfp = rsfp; + parser->recheck_utf8_validity = FALSE; parser->rsfp_filters = !(flags & LEX_START_SAME_FILTER) || !oparser ? NULL @@ -742,7 +743,22 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags) if (line) { STRLEN len; + const U8* first_bad_char_loc; + s = SvPV_const(line, len); + + if ( SvUTF8(line) + && UNLIKELY(! is_utf8_string_loc((U8 *) s, + SvCUR(line), + &first_bad_char_loc))) + { + _force_out_malformed_utf8_message(first_bad_char_loc, + (U8 *) s + SvCUR(line), + 0, + 1 /* 1 means die */ ); + NOT_REACHED; /* NOTREACHED */ + } + parser->linestr = flags & LEX_START_COPIED ? SvREFCNT_inc_simple_NN(line) : newSVpvn_flags(s, len, SvUTF8(line)); @@ -751,6 +767,7 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags) } else { parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2); } + parser->oldoldbufptr = parser->oldbufptr = parser->bufptr = @@ -1039,12 +1056,7 @@ Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags) } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) { p++; highhalf++; - } else if (! UTF8_IS_INVARIANT(c)) { - _force_out_malformed_utf8_message((U8 *) p, (U8 *) e, - 0, - 1 /* 1 means die */ ); - NOT_REACHED; /* NOTREACHED */ - } + } else assert(UTF8_IS_INVARIANT(c)); } if (!highhalf) goto plain_copy; @@ -1258,6 +1270,24 @@ Perl_lex_discard_to(pTHX_ char *ptr) PL_parser->last_lop -= discard_len; } +void +Perl_notify_parser_that_changed_to_utf8(pTHX) +{ + /* Called when $^H is changed to indicate that HINT_UTF8 has changed from + * off to on. At compile time, this has the effect of entering a 'use + * utf8' section. This means that any input was not previously checked for + * UTF-8 (because it was off), but now we do need to check it, or our + * assumptions about the input being sane could be wrong, and we could + * segfault. This routine just sets a flag so that the next time we look + * at the input we do the well-formed UTF-8 check. If we aren't in the + * proper phase, there may not be a parser object, but if there is, setting + * the flag is harmless */ + + if (PL_parser) { + PL_parser->recheck_utf8_validity = TRUE; + } +} + /* =for apidoc Amx|bool|lex_next_chunk|U32 flags @@ -1293,7 +1323,6 @@ Perl_lex_next_chunk(pTHX_ U32 flags) STRLEN linestart_pos, last_uni_pos, last_lop_pos; bool got_some_for_debugger = 0; bool got_some; - const U8* first_bad_char_loc; if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM)) Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk"); @@ -1360,15 +1389,19 @@ Perl_lex_next_chunk(pTHX_ U32 flags) PL_parser->bufend = buf + new_bufend_pos; PL_parser->bufptr = buf + bufptr_pos; - if (UTF && ! is_utf8_string_loc((U8 *) PL_parser->bufptr, - PL_parser->bufend - PL_parser->bufptr, - &first_bad_char_loc)) - { - _force_out_malformed_utf8_message(first_bad_char_loc, - (U8 *) PL_parser->bufend, - 0, - 1 /* 1 means die */ ); - NOT_REACHED; /* NOTREACHED */ + if (UTF) { + const U8* first_bad_char_loc; + if (UNLIKELY(! is_utf8_string_loc( + (U8 *) PL_parser->bufptr, + PL_parser->bufend - PL_parser->bufptr, + &first_bad_char_loc))) + { + _force_out_malformed_utf8_message(first_bad_char_loc, + (U8 *) PL_parser->bufend, + 0, + 1 /* 1 means die */ ); + NOT_REACHED; /* NOTREACHED */ + } } PL_parser->oldbufptr = buf + oldbufptr_pos; @@ -1545,7 +1578,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++; @@ -1564,7 +1597,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) { @@ -1596,7 +1629,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; @@ -1658,6 +1691,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", @@ -1690,7 +1730,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; @@ -1700,6 +1740,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 == ';') { @@ -1711,8 +1753,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)) @@ -1731,7 +1773,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; } @@ -1885,7 +1927,6 @@ STATIC void S_check_uni(pTHX) { const char *s; - const char *t; if (PL_oldoldbufptr != PL_last_uni) return; @@ -1894,7 +1935,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), @@ -2069,8 +2110,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; } @@ -2143,7 +2186,7 @@ Perl_str_to_version(pTHX_ SV *sv) STRLEN len; const char *start = SvPV_const(sv,len); const char * const end = start + len; - const bool utf = SvUTF8(sv) ? TRUE : FALSE; + const bool utf = cBOOL(SvUTF8(sv)); PERL_ARGS_ASSERT_STR_TO_VERSION; @@ -2249,10 +2292,9 @@ S_force_strict_version(pTHX_ char *s) /* * S_tokeq - * Tokenize a quoted string passed in as an SV. It finds the next - * chunk, up to end of string or a backslash. It may make a new - * SV containing that chunk (if HINT_NEW_STRING is on). It also - * turns \\ into \. + * Turns any \\ into \ in a quoted string passed in in 'sv', returning 'sv', + * modified as necessary. However, if HINT_NEW_STRING is on, 'sv' is + * unchanged, and a new SV containing the modified input is returned. */ STATIC SV * @@ -2557,30 +2599,15 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) SV *cv; SV *rv; HV *stash; - const U8* first_bad_char_loc; const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */ PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME; if (!SvCUR(res)) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Unknown charname '' is deprecated"); - return res; - } - - if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr, - e - backslash_ptr, - &first_bad_char_loc)) - { - _force_out_malformed_utf8_message(first_bad_char_loc, - (U8 *) PL_parser->bufend, - 0, - 0 /* 0 means don't die */ ); - yyerror_pv(Perl_form(aTHX_ - "Malformed UTF-8 character immediately after '%.*s'", - (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr), - SVf_UTF8); - return NULL; + 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, @@ -2600,8 +2627,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; } } @@ -2692,6 +2718,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 " @@ -2707,11 +2736,15 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) const U8* first_bad_char_loc; STRLEN len; const char* const str = SvPV_const(res, len); - if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) { + if (UNLIKELY(! is_utf8_string_loc((U8 *) str, len, + &first_bad_char_loc))) + { _force_out_malformed_utf8_message(first_bad_char_loc, (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'", @@ -2729,6 +2762,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", @@ -2740,6 +2775,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 " @@ -2838,7 +2876,7 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) } (end if backslash) handle regular character } (end while character to read) - + */ STATIC char * @@ -2853,8 +2891,6 @@ S_scan_const(pTHX_ char *start) bool didrange = FALSE; /* did we just finish a range? */ bool in_charclass = FALSE; /* within /[...]/ */ bool has_utf8 = FALSE; /* Output constant is UTF8 */ - bool has_above_latin1 = FALSE; /* does something require special - handling in tr/// ? */ bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be UTF8? But, this can show as true when the source isn't utf8, as for @@ -2869,6 +2905,14 @@ S_scan_const(pTHX_ char *start) STRLEN offset_to_max; /* 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 + * adding any branches to the more mainline code to handle this, which + * means that this doesn't get set in some circumstances when things like + * \x{100} get expanded out. As a result there needs to be extra testing + * done in the tr code */ + bool has_above_latin1 = FALSE; + /* Note on sizing: The scanned constant is placed into sv, which is * initialized by newSV() assuming one byte of output for every byte of * input. This routine expects newSV() to allocate an extra byte for a @@ -2913,8 +2957,8 @@ S_scan_const(pTHX_ char *start) * range, so for most cases we just drop down and handle the value * as any other. There are two exceptions. * - * 1. A minus sign indicates that we are actually going to have - * a range. In this case, skip the '-', set a flag, then drop + * 1. A hyphen indicates that we are actually going to have a + * range. In this case, skip the '-', set a flag, then drop * down to handle what should be the end range value. * 2. After we've handled that value, the next time through, that * flag is set and we fix up the range. @@ -2932,12 +2976,11 @@ S_scan_const(pTHX_ char *start) if (! dorange) { - /* Here, we don't think we're in a range. If we've processed - * at least one character, then see if this next one is a '-', - * indicating the previous one was the start of a range. But - * don't bother if we're too close to the end for the minus to - * mean that. */ - if (*s != '-' || s >= send - 1 || s == 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, 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 */ @@ -2947,25 +2990,26 @@ S_scan_const(pTHX_ char *start) non_portable_endpoint = 0; backslash_N = 0; #endif - /* The tests here and the following 'else' for being above - * Latin1 suffice to find all such occurences in the - * constant, except those added by a backslash escape - * sequence, like \x{100}. And all those set - * 'has_above_latin1' as appropriate */ + /* The tests here for being above Latin1 and similar ones + * in the following 'else' suffice to find all such + * occurences in the constant, except those added by a + * backslash escape sequence, like \x{100}. Mostly, those + * set 'has_above_latin1' as appropriate */ if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) { has_above_latin1 = TRUE; } /* Drops down to generic code to process current byte */ } - else { + else { /* Is a '-' in the context where it means a range */ if (didrange) { /* Something like y/A-C-Z// */ - Perl_croak(aTHX_ "Ambiguous range in transliteration operator"); + Perl_croak(aTHX_ "Ambiguous range in transliteration" + " operator"); } dorange = TRUE; - s++; /* Skip past the minus */ + s++; /* Skip past the hyphen */ /* d now points to where the end-range character will be * placed. Save it so won't have to go finding it later, @@ -2979,6 +3023,8 @@ S_scan_const(pTHX_ char *start) if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) { has_above_latin1 = TRUE; } + + /* Drops down to generic code to process current byte */ } } /* End of not a range */ else { @@ -2990,26 +3036,33 @@ S_scan_const(pTHX_ char *start) * 'd' points to just beyond the range end in the 'sv' string, * where we would next place something * 'offset_to_max' is the offset in 'sv' at which the character - * before 'd' begins. + * (the range's maximum end point) before 'd' begins. */ - const char * max_ptr = SvPVX_const(sv) + offset_to_max; - const char * min_ptr; + char * max_ptr = SvPVX(sv) + offset_to_max; + char * min_ptr; IV range_min; IV range_max; /* last character in range */ - STRLEN save_offset; STRLEN grow; + Size_t offset_to_min = 0; + Size_t extras = 0; #ifdef EBCDIC bool convert_unicode; IV real_range_max = 0; #endif - - /* Get the range-ends code point values. */ + /* Get the code point values of the range ends. */ if (has_utf8) { /* We know the utf8 is valid, because we just constructed * it ourselves in previous loop iterations */ min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1); range_min = valid_utf8_to_uvchr( (U8*) min_ptr, NULL); range_max = valid_utf8_to_uvchr( (U8*) max_ptr, NULL); + + /* This compensates for not all code setting + * 'has_above_latin1', so that we don't skip stuff that + * should be executed */ + if (range_max > 255) { + has_above_latin1 = TRUE; + } } else { min_ptr = max_ptr - 1; @@ -3017,6 +3070,23 @@ S_scan_const(pTHX_ char *start) range_max = * (U8*) max_ptr; } + /* If the range is just a single code point, like tr/a-a/.../, + * that code point is already in the output, twice. We can + * just back up over the second instance and avoid all the rest + * of the work. But if it is a variant character, it's been + * counted twice, so decrement. (This unlikely scenario is + * special cased, like the one for a range of 2 code points + * below, only because the main-line code below needs a range + * of 3 or more to work without special casing. Might as well + * get it out of the way now.) */ + if (UNLIKELY(range_max == range_min)) { + d = max_ptr; + if (! has_utf8 && ! UVCHR_IS_INVARIANT(range_max)) { + utf8_variant_count--; + } + goto range_done; + } + #ifdef EBCDIC /* On EBCDIC platforms, we may have to deal with portable * ranges. These happen if at least one range endpoint is a @@ -3024,16 +3094,16 @@ S_scan_const(pTHX_ char *start) * [A-Z] or [a-z], and both ends are literal characters, * like 'A', and not like \x{C1} */ convert_unicode = - cBOOL(backslash_N) /* \N{} forces Unicode, hence - portable range */ - || ( ! non_portable_endpoint - && (( isLOWER_A(range_min) && isLOWER_A(range_max)) - || (isUPPER_A(range_min) && isUPPER_A(range_max)))); + cBOOL(backslash_N) /* \N{} forces Unicode, + hence portable range */ + || ( ! non_portable_endpoint + && (( isLOWER_A(range_min) && isLOWER_A(range_max)) + || (isUPPER_A(range_min) && isUPPER_A(range_max)))); if (convert_unicode) { /* Special handling is needed for these portable ranges. - * They are defined to all be in Unicode terms, which - * include all Unicode code points between the end points. + * They are defined to be in Unicode terms, which includes + * all the Unicode code points between the end points. * Convert to Unicode to get the Unicode range. Later we * will convert each code point in the range back to * native. */ @@ -3051,7 +3121,6 @@ S_scan_const(pTHX_ char *start) range_max = UNI_TO_NATIVE(range_max); } #endif - /* Use the characters themselves for the error message if * ASCII printables; otherwise some visible representation * of them */ @@ -3062,32 +3131,40 @@ S_scan_const(pTHX_ char *start) } #ifdef EBCDIC else if (convert_unicode) { - /* diag_listed_as: Invalid range "%s" in transliteration operator */ + /* diag_listed_as: Invalid range "%s" in transliteration operator */ Perl_croak(aTHX_ - "Invalid range \"\\N{U+%04" UVXf "}-\\N{U+%04" UVXf "}\"" - " in transliteration operator", - range_min, range_max); + "Invalid range \"\\N{U+%04" UVXf "}-\\N{U+%04" + UVXf "}\" in transliteration operator", + range_min, range_max); } #endif else { - /* diag_listed_as: Invalid range "%s" in transliteration operator */ + /* diag_listed_as: Invalid range "%s" in transliteration operator */ Perl_croak(aTHX_ - "Invalid range \"\\x{%04" UVXf "}-\\x{%04" UVXf "}\"" - " in transliteration operator", - range_min, range_max); + "Invalid range \"\\x{%04" UVXf "}-\\x{%04" UVXf "}\"" + " in transliteration operator", + range_min, range_max); } } + /* If the range is exactly two code points long, they are + * already both in the output */ + if (UNLIKELY(range_min + 1 == range_max)) { + goto range_done; + } + + /* Here the range contains at least 3 code points */ + if (has_utf8) { /* If everything in the transliteration is below 256, we * can avoid special handling later. A translation table - * of each of those bytes is created. And so we expand out - * all ranges to their constituent code points. But if - * we've encountered something above 255, the expanding - * won't help, so skip doing that. But if it's EBCDIC, we - * may have to look at each character below 256 if we have - * to convert to/from Unicode values */ + * for each of those bytes is created by op.c. So we + * expand out all ranges to their constituent code points. + * But if we've encountered something above 255, the + * expanding won't help, so skip doing that. But if it's + * EBCDIC, we may have to look at each character below 256 + * if we have to convert to/from Unicode values */ if ( has_above_latin1 #ifdef EBCDIC && (range_min > 255 || ! convert_unicode) @@ -3096,7 +3173,7 @@ S_scan_const(pTHX_ char *start) /* Move the high character one byte to the right; then * insert between it and the range begin, an illegal * byte which serves to indicate this is a range (using - * a '-' could be ambiguous). */ + * a '-' would be ambiguous). */ char *e = d++; while (e-- > max_ptr) { *(e + 1) = *e; @@ -3118,51 +3195,94 @@ S_scan_const(pTHX_ char *start) } /* Here we need to expand out the string to contain each - * character in the range. Grow the output to handle this */ + * character in the range. Grow the output to handle this. + * For non-UTF8, we need a byte for each code point in the + * range, minus the three that we've already allocated for: the + * hyphen, the min, and the max. For UTF-8, we need this + * plus an extra byte for each code point that occupies two + * bytes (is variant) when in UTF-8 (except we've already + * allocated for the end points, including if they are + * variants). For ASCII platforms and Unicode ranges on EBCDIC + * platforms, it's easy to calculate a precise number. To + * start, we count the variants in the range, which we need + * elsewhere in this function anyway. (For the case where it + * isn't easy to calculate, 'extras' has been initialized to 0, + * and the calculation is done in a loop further down.) */ +#ifdef EBCDIC + if (convert_unicode) +#endif + { + /* This is executed unconditionally on ASCII, and for + * Unicode ranges on EBCDIC. Under these conditions, all + * code points above a certain value are variant; and none + * under that value are. We just need to find out how much + * of the range is above that value. We don't count the + * end points here, as they will already have been counted + * as they were parsed. */ + if (range_min >= UTF_CONTINUATION_MARK) { + + /* The whole range is made up of variants */ + extras = (range_max - 1) - (range_min + 1) + 1; + } + else if (range_max >= UTF_CONTINUATION_MARK) { - save_offset = min_ptr - SvPVX_const(sv); + /* Only the higher portion of the range is variants */ + extras = (range_max - 1) - UTF_CONTINUATION_MARK + 1; + } - /* The base growth is the number of code points in the range */ - grow = range_max - range_min + 1; - if (has_utf8) { + utf8_variant_count += extras; + } + + /* The base growth is the number of code points in the range, + * not including the endpoints, which have already been sized + * for (and output). We don't subtract for the hyphen, as it + * has been parsed but not output, and the SvGROW below is + * based only on what's been output plus what's left to parse. + * */ + grow = (range_max - 1) - (range_min + 1) + 1; - /* But if the output is UTF-8, some of those characters may - * need two bytes (since the maximum range value here is - * 255, the max bytes per character is two). On ASCII - * platforms, it's not much trouble to get an accurate - * count of what's needed. But on EBCDIC, the ones that - * need 2 bytes are scattered around, so just use a worst - * case value instead of calculating for that platform. */ + if (has_utf8) { #ifdef EBCDIC - grow *= 2; -#else - /* Only those above 127 require 2 bytes. This may be - * everything in the range, or not */ - if (range_min > 127) { + /* In some cases in EBCDIC, we haven't yet calculated a + * precise amount needed for the UTF-8 variants. Just + * assume the worst case, that everything will expand by a + * byte */ + if (! convert_unicode) { grow *= 2; } - else if (range_max > 127) { - grow += range_max - 127; - } + else #endif + { + /* Otherwise we know exactly how many variants there + * are in the range. */ + grow += extras; + } } - /* Subtract 3 for the bytes that were already accounted for - * (min, max, and the hyphen) */ - d = save_offset + SvGROW(sv, SvLEN(sv) + grow - 3); + /* Grow, but position the output to overwrite the range min end + * point, because in some cases we overwrite that */ + SvCUR_set(sv, d - SvPVX_const(sv)); + offset_to_min = min_ptr - SvPVX_const(sv); + + /* See Note on sizing above. */ + d = offset_to_min + SvGROW(sv, SvCUR(sv) + + (send - s) + + grow + + 1 /* Trailing NUL */ ); + /* Now, we can expand out the range. */ #ifdef EBCDIC - /* Here, we expand out the range. */ if (convert_unicode) { - IV i; + SSize_t i; /* Recall that the min and max are now in Unicode terms, so * we have to convert each character to its native * equivalent */ if (has_utf8) { for (i = range_min; i <= range_max; i++) { - append_utf8_from_native_byte(LATIN1_TO_NATIVE((U8) i), - (U8 **) &d); + append_utf8_from_native_byte( + LATIN1_TO_NATIVE((U8) i), + (U8 **) &d); } } else { @@ -3175,34 +3295,51 @@ S_scan_const(pTHX_ char *start) #endif /* Always gets run for ASCII, and sometimes for EBCDIC. */ { - IV i; - /* Here, no conversions are necessary, which means that the * first character in the range is already in 'd' and * valid, so we can skip overwriting it */ if (has_utf8) { + SSize_t i; d += UTF8SKIP(d); for (i = range_min + 1; i <= range_max; i++) { append_utf8_from_native_byte((U8) i, (U8 **) &d); } } else { + SSize_t i; d++; - for (i = range_min + 1; i <= range_max; i++) { + assert(range_min + 1 <= range_max); + for (i = range_min + 1; i < range_max; i++) { +#ifdef EBCDIC + /* In this case on EBCDIC, we haven't calculated + * the variants. Do it here, as we go along */ + if (! UVCHR_IS_INVARIANT(i)) { + utf8_variant_count++; + } +#endif *d++ = (char)i; } + + /* The range_max is done outside the loop so as to + * avoid having to special case not incrementing + * 'utf8_variant_count' on EBCDIC (it's already been + * counted when originally parsed) */ + *d++ = (char) range_max; } } #ifdef EBCDIC - /* If the original range extended above 255, add in that portion. */ + /* If the original range extended above 255, add in that + * portion. */ if (real_range_max) { *d++ = (char) UTF8_TWO_BYTE_HI(0x100); *d++ = (char) UTF8_TWO_BYTE_LO(0x100); - if (real_range_max > 0x101) - *d++ = (char) ILLEGAL_UTF8_BYTE; - if (real_range_max > 0x100) + if (real_range_max > 0x100) { + if (real_range_max > 0x101) { + *d++ = (char) ILLEGAL_UTF8_BYTE; + } d = (char*)uvchr_to_utf8((U8*)d, real_range_max); + } } #endif @@ -3233,11 +3370,9 @@ S_scan_const(pTHX_ char *start) if (!esc) in_charclass = FALSE; } - - /* skip for regexp comments /(?#comment)/, except for the last - * char, which will be done separately. - * Stop on (?{..}) and friends */ - + /* skip for regexp comments /(?#comment)/, except for the last + * char, which will be done separately. Stop on (?{..}) and + * friends */ else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) { if (s[2] == '#') { while (s+1 < send && *s != ')') @@ -3250,8 +3385,7 @@ S_scan_const(pTHX_ char *start) break; } } - - /* likewise skip #-initiated comments in //x patterns */ + /* likewise skip #-initiated comments in //x patterns */ else if (*s == '#' && PL_lex_inpat && !in_charclass @@ -3260,14 +3394,13 @@ S_scan_const(pTHX_ char *start) while (s < send && *s != '\n') *d++ = *s++; } - - /* no further processing of single-quoted regex */ + /* no further processing of single-quoted regex */ else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') goto default_action; - /* check for embedded arrays - (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-) - */ + /* check for embedded arrays + * (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-) + */ else if (*s == '@' && s[1]) { if (UTF ? isIDFIRST_utf8_safe(s+1, send) @@ -3280,10 +3413,8 @@ S_scan_const(pTHX_ char *start) if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-')) break; /* in regexp, neither @+ nor @- are interpolated */ } - - /* check for embedded scalars. only stop if we're sure it's a - variable. - */ + /* check for embedded scalars. only stop if we're sure it's a + * variable. */ else if (*s == '$') { if (!PL_lex_inpat) /* not a regexp, so $ must be var */ break; @@ -3384,7 +3515,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 @@ -3392,7 +3524,7 @@ S_scan_const(pTHX_ char *start) UTF); if (! valid) { yyerror(error); - continue; + uv = 0; /* drop through to ensure range ends are set */ } goto NUM_ESCAPE_INSERT; } @@ -3402,7 +3534,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 @@ -3410,13 +3543,13 @@ S_scan_const(pTHX_ char *start) UTF); if (! valid) { yyerror(error); - continue; + uv = 0; /* drop through to ensure range ends are set */ } } NUM_ESCAPE_INSERT: /* Insert oct or hex escaped character. */ - + /* Here uv is the ordinal of the next character being added */ if (UVCHR_IS_INVARIANT(uv)) { *d++ = (char) uv; @@ -3505,11 +3638,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: @@ -3530,18 +3664,19 @@ S_scan_const(pTHX_ char *start) s++; if (*s != '{') { yyerror("Missing braces on \\N{}"); + *d++ = '\0'; continue; } 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 { yyerror("Missing right brace on \\N{} or unescaped left brace after \\N"); } - continue; + yyquit(); /* Have exhausted the input. */ } /* Here it looks like a named character */ @@ -3560,6 +3695,7 @@ S_scan_const(pTHX_ char *start) "Invalid hexadecimal number in \\N{U+...}" ); s = e + 1; + *d++ = '\0'; continue; } while (++s < e) { @@ -3758,6 +3894,7 @@ S_scan_const(pTHX_ char *start) " in transliteration operator", /* +1 to include the "}" */ (int) (e + 1 - start), start)); + *d++ = '\0'; goto end_backslash_N; } @@ -3823,15 +3960,16 @@ S_scan_const(pTHX_ char *start) case 'c': s++; if (s < send) { - *d++ = grok_bslash_c(*s++, 1); + *d++ = grok_bslash_c(*s, 1); } else { yyerror("Missing control char name in \\c"); + yyquit(); /* Are at end of input, no sense continuing */ } #ifdef EBCDIC non_portable_endpoint++; #endif - continue; + break; /* printf-style backslashes, formfeeds, newlines, etc */ case 'b': @@ -4011,7 +4149,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; @@ -4046,7 +4184,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]; @@ -4076,10 +4214,7 @@ S_intuit_more(pTHX_ char *s) weight -= seen[un_char] * 10; if (isWORDCHAR_lazy_if_safe(s+1, PL_bufend, UTF)) { int len; - char *tmp = PL_bufend; - PL_bufend = (char*)send; - scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE); - PL_bufend = tmp; + scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE); len = (int)strlen(tmpbuf); if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0, SVt_PV)) @@ -4200,11 +4335,14 @@ S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv) } if (*start == '$') { + SSize_t start_off = start - SvPVX(PL_linestr); if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY || isUPPER(*PL_tokenbuf)) return 0; - s = skipspace(s); - PL_bufptr = start; + /* this could be $# */ + if (isSPACE(*s)) + s = skipspace(s); + PL_bufptr = SvPVX(PL_linestr) + start_off; PL_expect = XREF; return *s == '(' ? FUNCMETH : METHOD; } @@ -4317,8 +4455,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; } @@ -4361,6 +4499,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 @@ -4443,7 +4582,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 * @@ -4475,7 +4618,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 @@ -4504,6 +4647,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; @@ -4649,6 +4793,20 @@ Perl_yylex(pTHX) GV *gv = NULL; GV **gvp = NULL; + if (UNLIKELY(PL_parser->recheck_utf8_validity)) { + const U8* first_bad_char_loc; + if (UTF && UNLIKELY(! is_utf8_string_loc((U8 *) PL_bufptr, + PL_bufend - PL_bufptr, + &first_bad_char_loc))) + { + _force_out_malformed_utf8_message(first_bad_char_loc, + (U8 *) PL_bufend, + 0, + 1 /* 1 means die */ ); + NOT_REACHED; /* NOTREACHED */ + } + PL_parser->recheck_utf8_validity = FALSE; + } DEBUG_T( { SV* tmp = newSVpvs(""); PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n", @@ -4735,8 +4893,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"))) { @@ -4827,7 +4988,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; } @@ -4896,7 +5057,16 @@ Perl_yylex(pTHX) s = PL_bufend; } else { + int save_error_count = PL_error_count; + s = scan_const(PL_bufptr); + + /* Set flag if this was a pattern and there were errors. op.c will + * refuse to compile a pattern with this flag set. Otherwise, we + * could get segfaults, etc. */ + if (PL_lex_inpat && PL_error_count > save_error_count) { + ((PMOP*)PL_lex_inpat)->op_pmflags |= PMf_HAS_ERROR; + } if (*s == '\\') PL_lex_state = LEX_INTERPCASEMOD; else @@ -4922,6 +5092,7 @@ Perl_yylex(pTHX) return yylex(); case LEX_FORMLINE: + assert(PL_lex_formbrack); s = scan_formline(PL_bufptr); if (!PL_lex_formbrack) { @@ -4947,7 +5118,7 @@ Perl_yylex(pTHX) * as a var; e.g. ($, ...) would be seen as the var '$,' */ - char sigil; + U8 sigil; s = skipspace(s); sigil = *s++; @@ -4975,12 +5146,43 @@ Perl_yylex(pTHX) 0, cBOOL(UTF), 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 ')': @@ -5005,12 +5207,6 @@ Perl_yylex(pTHX) switch (*s) { default: if (UTF) { - if (! isUTF8_CHAR((U8 *) s, (U8 *) PL_bufend)) { - _force_out_malformed_utf8_message((U8 *) s, (U8 *) PL_bufend, - 0, - 1 /* 1 means die */ ); - NOT_REACHED; /* NOTREACHED */ - } if (isIDFIRST_utf8_safe(s, PL_bufend)) { goto keylookup; } @@ -5032,12 +5228,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); @@ -5106,10 +5313,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. :-) */ @@ -5141,7 +5353,7 @@ Perl_yylex(pTHX) } do { fake_eof = 0; - bof = PL_rsfp ? TRUE : FALSE; + bof = cBOOL(PL_rsfp); if (0) { fake_eof: fake_eof = LEX_FAKE_EOF; @@ -5158,10 +5370,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)); @@ -5177,7 +5389,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); @@ -5186,7 +5400,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); @@ -5264,8 +5478,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" */ @@ -5413,24 +5625,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); @@ -5444,11 +5652,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 '-': @@ -5463,7 +5668,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 */ @@ -5643,13 +5848,13 @@ Perl_yylex(pTHX) } else if (PL_expect == XPOSTDEREF) POSTDEREF('%'); PL_tokenbuf[0] = '%'; - s = scan_ident(s, PL_tokenbuf + 1, - sizeof PL_tokenbuf - 1, FALSE); + s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); pl_yylval.ival = 0; 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] = '@'; } @@ -5768,33 +5973,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_ @@ -6091,9 +6280,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; @@ -6115,6 +6306,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 */ @@ -6145,7 +6337,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); @@ -6190,8 +6382,7 @@ Perl_yylex(pTHX) } PL_tokenbuf[0] = '&'; - s = scan_ident(s - 1, PL_tokenbuf + 1, - sizeof PL_tokenbuf - 1, TRUE); + s = scan_ident(s - 1, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE); pl_yylval.ival = (OPpENTERSUB_AMPER<<8); if (PL_tokenbuf[1]) { force_ident_maybe_lex('&'); @@ -6225,7 +6416,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; } @@ -6257,19 +6450,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; } } @@ -6291,7 +6486,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; @@ -6341,10 +6536,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; } @@ -6359,7 +6556,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; } @@ -6403,7 +6602,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; } @@ -6435,12 +6636,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); @@ -6471,8 +6667,7 @@ Perl_yylex(pTHX) } PL_tokenbuf[0] = '$'; - s = scan_ident(s, PL_tokenbuf + 1, - sizeof PL_tokenbuf - 1, FALSE); + s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); if (PL_expect == XOPERATOR) { d = s; if (PL_bufptr > s) { @@ -6493,8 +6688,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)) { @@ -6519,30 +6714,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)); + } + } + } } } @@ -6622,7 +6819,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] = '%'; @@ -6731,13 +6930,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) { @@ -6747,10 +6942,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) @@ -6763,7 +6954,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. */ @@ -6789,7 +6980,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()); @@ -6894,7 +7085,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; } @@ -7030,8 +7221,10 @@ Perl_yylex(pTHX) else { /* no override */ tmp = -tmp; if (tmp == KEY_dump) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), - "dump() better written as CORE::dump()"); + Perl_ck_warner_d(aTHX_ packWARN2(WARN_MISC,WARN_DEPRECATED), + "dump() better written as CORE::dump(). " + "dump() will no longer be available " + "in Perl 5.30"); } gv = NULL; gvp = 0; @@ -7074,6 +7267,7 @@ Perl_yylex(pTHX) orig_keyword = 0; lex = 0; off = 0; + /* FALLTHROUGH */ default: /* not a keyword */ just_a_word: { int pkgname = 0; @@ -7182,17 +7376,24 @@ Perl_yylex(pTHX) == OA_FILEREF)) { bool immediate_paren = *s == '('; + SSize_t s_off; /* (Now we can afford to cross potential line boundary.) */ s = skipspace(s); + /* intuit_method() can indirectly call lex_next_chunk(), + * invalidating s + */ + s_off = s - SvPVX(PL_linestr); /* Two barewords in a row may indicate method call. */ if ( ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF) || *s == '$') && (tmp = intuit_method(s, lex ? NULL : sv, cv))) { + /* the code at method: doesn't use s */ goto method; } + s = SvPVX(PL_linestr) + s_off; /* If not a declared subroutine, it's an indirect object. */ /* (But it's an indir obj regardless for sort.) */ @@ -7657,7 +7858,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); @@ -7716,7 +7917,7 @@ Perl_yylex(pTHX) case KEY_exists: UNI(OP_EXISTS); - + case KEY_exit: UNI(OP_EXIT); @@ -7775,15 +7976,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)) { @@ -7792,6 +7997,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); @@ -7952,7 +8160,7 @@ Perl_yylex(pTHX) case KEY_last: LOOPX(OP_LAST); - + case KEY_lc: UNI(OP_LC); @@ -8031,7 +8239,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) { @@ -8132,7 +8340,7 @@ Perl_yylex(pTHX) case KEY_pos: UNIDOR(OP_POS); - + case KEY_pack: LOP(OP_PACK,XTERM); @@ -8148,7 +8356,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()); @@ -8160,7 +8368,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)) { @@ -8209,7 +8417,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 */ @@ -8222,7 +8430,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()); @@ -8320,7 +8528,7 @@ Perl_yylex(pTHX) case KEY_chomp: UNI(OP_CHOMP); - + case KEY_scalar: UNI(OP_SCALAR); @@ -8506,7 +8714,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); @@ -8741,8 +8950,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); } @@ -8902,7 +9114,6 @@ S_checkcomma(pTHX_ const char *s, const char *name, const char *what) s++; if (*s == ',') { GV* gv; - PADOFFSET off; if (keyword(w, s - w, 0)) return; @@ -8910,6 +9121,7 @@ S_checkcomma(pTHX_ const char *s, const char *name, const char *what) if (gv && GvCVu(gv)) return; if (s - w <= 254) { + PADOFFSET off; char tmpbuf[256]; Copy(w, tmpbuf+1, s - w, char); *tmpbuf = '&'; @@ -8960,7 +9172,7 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, || ! SvOK(*cvp)) { char *msg; - + /* Here haven't found what we're looking for. If it is charnames, * perhaps it needs to be loaded. Try doing that before giving up */ if (*key == 'c') { @@ -9199,7 +9411,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. @@ -9246,19 +9458,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); + *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 *) @@ -9277,26 +9506,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; @@ -9340,7 +9559,9 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) *dest = '\0'; } } - 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; } @@ -9573,18 +9794,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; } @@ -9740,11 +9957,9 @@ S_scan_heredoc(pTHX_ char *s) else term = '"'; if (! isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF)) - deprecate("bare << to mean <<\"\""); + 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); @@ -9759,7 +9974,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; @@ -9868,8 +10083,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; @@ -10003,8 +10219,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); @@ -10095,7 +10312,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 @@ -10128,7 +10345,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] == '>') { @@ -10290,7 +10507,7 @@ S_scan_inputsymbol(pTHX_ char *start) ($*@) sub prototypes sub foo ($) (stuff) sub attr parameters sub foo : attr(stuff) <> readline or globs , <>, <$fh>, or <*.c> - + In most of these cases (all but <>, patterns and transliterate) yylex() calls scan_str(). m// makes yylex() call scan_pat() which calls scan_str(). s/// makes yylex() call scan_subst() which calls @@ -10334,7 +10551,7 @@ S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re const char * non_grapheme_msg = "Use of unassigned code point or" " non-standalone grapheme for a delimiter" " will be a fatal error starting in Perl" - " v5.30"; + " 5.30"; /* The only non-UTF character that isn't a stand alone grapheme is * white-space, hence can't be a delimiter. So can skip for non-UTF-8 */ bool check_grapheme = UTF && ckWARN_d(WARN_DEPRECATED); @@ -10433,10 +10650,15 @@ S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re } /* terminate when run out of buffer (the for() condition), or have found the terminator */ - else if (*s == term) { - if (termlen == 1) + else if (*s == term) { /* First byte of terminator matches */ + if (termlen == 1) /* If is the only byte, are done */ break; - if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen)) + + /* If the remainder of the terminator matches, also are + * done, after checking that is a separate grapheme */ + if ( s + termlen <= PL_bufend + && memEQ(s + 1, (char*)termstr + 1, termlen - 1)) + { if ( check_grapheme && UNLIKELY(! _is_grapheme((U8 *) start, (U8 *) s, @@ -10447,13 +10669,16 @@ S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re "%s", non_grapheme_msg); } break; + } } - else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) + else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) { has_utf8 = TRUE; + } + *to = *s; } } - + /* if the terminator isn't the same as the start character (e.g., matched brackets), we have to allow more in the quoting, and be prepared for nested brackets. @@ -10511,7 +10736,7 @@ S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r') to[-1] = '\n'; #endif - + /* if we're out of file, or a read fails, bail and reset the current line marker so we can report where the unterminated string began */ @@ -10590,6 +10815,15 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) bool floatit; /* boolean: int or float? */ const char *lastub = NULL; /* position of last underbar */ static const char* const number_too_long = "Number too long"; + bool warned_about_underscore = 0; +#define WARN_ABOUT_UNDERSCORE() \ + do { \ + if (!warned_about_underscore) { \ + warned_about_underscore = 1; \ + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), \ + "Misplaced _ in number"); \ + } \ + } while(0) /* Hexadecimal floating point. * * In many places (where we have quads and NV is IEEE 754 double) @@ -10674,8 +10908,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) } if (*s == '_') { - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); + WARN_ABOUT_UNDERSCORE(); lastub = s++; } @@ -10698,8 +10931,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) /* _ are ignored -- but warned about if consecutive */ case '_': if (lastub && s == lastub + 1) - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); + WARN_ABOUT_UNDERSCORE(); lastub = s++; break; @@ -10784,9 +11016,8 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) out: /* final misplaced underbar check */ - if (s[-1] == '_') { - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); - } + if (s[-1] == '_') + WARN_ABOUT_UNDERSCORE(); if (UNLIKELY(HEXFP_PEEK(s))) { /* Do sloppy (on the underbars) but quick detection @@ -10995,8 +11226,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) */ if (*s == '_') { if (lastub && s == lastub + 1) - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); + WARN_ABOUT_UNDERSCORE(); lastub = s++; } else { @@ -11009,9 +11239,8 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) } /* final misplaced underbar check */ - if (lastub && s == lastub + 1) { - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); - } + if (lastub && s == lastub + 1) + WARN_ABOUT_UNDERSCORE(); /* read a decimal portion if there is one. avoid 3..5 being interpreted as the number 3. followed @@ -11022,8 +11251,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) *d++ = *s++; if (*s == '_') { - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); + WARN_ABOUT_UNDERSCORE(); lastub = s; } @@ -11039,18 +11267,15 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) Perl_croak(aTHX_ "%s", number_too_long); if (*s == '_') { if (lastub && s == lastub + 1) - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); + WARN_ABOUT_UNDERSCORE(); lastub = s; } else *d++ = *s; } /* fractional part ending in underbar? */ - if (s[-1] == '_') { - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); - } + if (s[-1] == '_') + WARN_ABOUT_UNDERSCORE(); if (*s == '.' && isDIGIT(s[1])) { /* oops, it's really a v-string, but without the "v" */ s = start; @@ -11063,9 +11288,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' */ @@ -11080,8 +11307,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) /* stray preinitial _ */ if (*s == '_') { - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); + WARN_ABOUT_UNDERSCORE(); lastub = s++; } @@ -11091,14 +11317,14 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) /* stray initial _ */ if (*s == '_') { - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); + WARN_ABOUT_UNDERSCORE(); lastub = s++; } /* 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++; @@ -11106,11 +11332,24 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) else { if (((lastub && s == lastub + 1) || (!isDIGIT(s[1]) && s[1] != '_'))) - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); + WARN_ABOUT_UNDERSCORE(); 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; + } } @@ -11192,8 +11431,6 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) STATIC char * S_scan_formline(pTHX_ char *s) { - char *eol; - char *t; SV * const stuff = newSVpvs(""); bool needargs = FALSE; bool eofmt = FALSE; @@ -11201,8 +11438,9 @@ S_scan_formline(pTHX_ char *s) PERL_ARGS_ASSERT_SCAN_FORMLINE; while (!needargs) { + char *eol; if (*s == '.') { - t = s+1; + char *t = s+1; #ifdef PERL_STRICT_CR while (SPACE_OR_TAB(*t)) t++; @@ -11219,6 +11457,7 @@ S_scan_formline(pTHX_ char *s) if (!eol++) eol = PL_bufend; if (*s != '#') { + char *t; for (t = s; t < eol; t++) { if (*t == '~' && t[1] == '~' && SvCUR(stuff)) { needargs = FALSE; @@ -11253,7 +11492,7 @@ S_scan_formline(pTHX_ char *s) if (!got_some) break; } - incline(s); + incline(s, PL_bufend); } enough: if (!SvCUR(stuff) || needargs) @@ -11320,6 +11559,29 @@ S_yywarn(pTHX_ const char *const s, U32 flags) return 0; } +void +Perl_abort_execution(pTHX_ const char * const msg, const char * const name) +{ + PERL_ARGS_ASSERT_ABORT_EXECUTION; + + if (PL_minus_c) + Perl_croak(aTHX_ "%s%s had compilation errors.\n", msg, name); + else { + Perl_croak(aTHX_ + "%sExecution of %s aborted due to compilation errors.\n", msg, name); + } + NOT_REACHED; /* NOTREACHED */ +} + +void +Perl_yyquit(pTHX) +{ + /* Called, after at least one error has been found, to abort the parse now, + * instead of trying to forge ahead */ + + yyerror_pvn(NULL, 0, 0); +} + int Perl_yyerror(pTHX_ const char *const s) { @@ -11343,100 +11605,120 @@ Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags) SV * const where_sv = newSVpvs_flags("", SVs_TEMP); int yychar = PL_parser->yychar; - PERL_ARGS_ASSERT_YYERROR_PVN; - - if (!yychar || (yychar == ';' && !PL_rsfp)) - sv_catpvs(where_sv, "at EOF"); - else if ( PL_oldoldbufptr - && PL_bufptr > PL_oldoldbufptr - && PL_bufptr - PL_oldoldbufptr < 200 - && PL_oldoldbufptr != PL_oldbufptr - && PL_oldbufptr != PL_bufptr) - { - /* - Only for NetWare: - The code below is removed for NetWare because it abends/crashes on NetWare - when the script has error such as not having the closing quotes like: - if ($var eq "value) - Checking of white spaces is anyway done in NetWare code. - */ + /* Output error message 's' with length 'len'. 'flags' are SV flags that + * apply. If the number of errors found is large enough, it abandons + * parsing. If 's' is NULL, there is no message, and it abandons + * processing unconditionally */ + + if (s != NULL) { + if (!yychar || (yychar == ';' && !PL_rsfp)) + sv_catpvs(where_sv, "at EOF"); + else if ( PL_oldoldbufptr + && PL_bufptr > PL_oldoldbufptr + && PL_bufptr - PL_oldoldbufptr < 200 + && PL_oldoldbufptr != PL_oldbufptr + && PL_oldbufptr != PL_bufptr) + { + /* + Only for NetWare: + The code below is removed for NetWare because it + abends/crashes on NetWare when the script has error such as + not having the closing quotes like: + if ($var eq "value) + Checking of white spaces is anyway done in NetWare code. + */ #ifndef NETWARE - while (isSPACE(*PL_oldoldbufptr)) - PL_oldoldbufptr++; + while (isSPACE(*PL_oldoldbufptr)) + PL_oldoldbufptr++; #endif - context = PL_oldoldbufptr; - contlen = PL_bufptr - PL_oldoldbufptr; - } - else if ( PL_oldbufptr - && PL_bufptr > PL_oldbufptr - && PL_bufptr - PL_oldbufptr < 200 - && PL_oldbufptr != PL_bufptr) { - /* - Only for NetWare: - The code below is removed for NetWare because it abends/crashes on NetWare - when the script has error such as not having the closing quotes like: - if ($var eq "value) - Checking of white spaces is anyway done in NetWare code. - */ + context = PL_oldoldbufptr; + contlen = PL_bufptr - PL_oldoldbufptr; + } + else if ( PL_oldbufptr + && PL_bufptr > PL_oldbufptr + && PL_bufptr - PL_oldbufptr < 200 + && PL_oldbufptr != PL_bufptr) { + /* + Only for NetWare: + The code below is removed for NetWare because it + abends/crashes on NetWare when the script has error such as + not having the closing quotes like: + if ($var eq "value) + Checking of white spaces is anyway done in NetWare code. + */ #ifndef NETWARE - while (isSPACE(*PL_oldbufptr)) - PL_oldbufptr++; + while (isSPACE(*PL_oldbufptr)) + PL_oldbufptr++; #endif - context = PL_oldbufptr; - contlen = PL_bufptr - PL_oldbufptr; - } - else if (yychar > 255) - sv_catpvs(where_sv, "next token ???"); - else if (yychar == YYEMPTY) { - if (PL_lex_state == LEX_NORMAL) - sv_catpvs(where_sv, "at end of line"); - else if (PL_lex_inpat) - sv_catpvs(where_sv, "within pattern"); - else - sv_catpvs(where_sv, "within string"); - } - else { - sv_catpvs(where_sv, "next char "); - if (yychar < 32) - Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar)); - else if (isPRINT_LC(yychar)) { - const char string = yychar; - sv_catpvn(where_sv, &string, 1); - } - else - Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255); - } - msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP); - Perl_sv_catpvf(aTHX_ msg, " at %s line %" IVdf ", ", - OutCopFILE(PL_curcop), - (IV)(PL_parser->preambling == NOLINE - ? CopLINE(PL_curcop) - : PL_parser->preambling)); - if (context) - Perl_sv_catpvf(aTHX_ msg, "near \"%" UTF8f "\"\n", - UTF8fARG(UTF, contlen, context)); - else - Perl_sv_catpvf(aTHX_ msg, "%" SVf "\n", SVfARG(where_sv)); - if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) { - Perl_sv_catpvf(aTHX_ msg, - " (Might be a runaway multi-line %c%c string starting on line %" IVdf ")\n", - (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start); - PL_multi_end = 0; - } - if (PL_in_eval & EVAL_WARNONLY) { - PL_in_eval &= ~EVAL_WARNONLY; - Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%" SVf, SVfARG(msg)); + context = PL_oldbufptr; + contlen = PL_bufptr - PL_oldbufptr; + } + else if (yychar > 255) + sv_catpvs(where_sv, "next token ???"); + else if (yychar == YYEMPTY) { + if (PL_lex_state == LEX_NORMAL) + sv_catpvs(where_sv, "at end of line"); + else if (PL_lex_inpat) + sv_catpvs(where_sv, "within pattern"); + else + sv_catpvs(where_sv, "within string"); + } + else { + sv_catpvs(where_sv, "next char "); + if (yychar < 32) + Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar)); + else if (isPRINT_LC(yychar)) { + const char string = yychar; + sv_catpvn(where_sv, &string, 1); + } + else + Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255); + } + msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP); + Perl_sv_catpvf(aTHX_ msg, " at %s line %" IVdf ", ", + OutCopFILE(PL_curcop), + (IV)(PL_parser->preambling == NOLINE + ? CopLINE(PL_curcop) + : PL_parser->preambling)); + if (context) + Perl_sv_catpvf(aTHX_ msg, "near \"%" UTF8f "\"\n", + UTF8fARG(UTF, contlen, context)); + else + Perl_sv_catpvf(aTHX_ msg, "%" SVf "\n", SVfARG(where_sv)); + if ( PL_multi_start < PL_multi_end + && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) + { + Perl_sv_catpvf(aTHX_ msg, + " (Might be a runaway multi-line %c%c string starting on" + " line %" IVdf ")\n", + (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start); + PL_multi_end = 0; + } + if (PL_in_eval & EVAL_WARNONLY) { + PL_in_eval &= ~EVAL_WARNONLY; + Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%" SVf, SVfARG(msg)); + } + else { + qerror(msg); + } } - else - qerror(msg); - if (PL_error_count >= 10) { - SV * errsv; - if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv))) - Perl_croak(aTHX_ "%" SVf "%s has too many errors.\n", - SVfARG(errsv), OutCopFILE(PL_curcop)); - else - Perl_croak(aTHX_ "%s has too many errors.\n", - OutCopFILE(PL_curcop)); + if (s == NULL || PL_error_count >= 10) { + const char * msg = ""; + const char * const name = OutCopFILE(PL_curcop); + + if (PL_in_eval) { + SV * errsv = ERRSV; + if (SvCUR(errsv)) { + msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv)); + } + } + + if (s == NULL) { + abort_execution(msg, name); + } + else { + Perl_croak(aTHX_ "%s%s has too many errors.\n", msg, name); + } } PL_in_my = 0; PL_in_my_stash = NULL; @@ -11458,7 +11740,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); @@ -11472,7 +11756,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); @@ -11484,10 +11770,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; } @@ -11505,7 +11792,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 */ @@ -11521,7 +11810,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 */ @@ -11622,9 +11913,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), @@ -11783,6 +12079,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)