X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/5c9ae74dcaf4a16d67145fc3ea876a42aeb5c0b3..b71c54b89aa7c965d23cc7cfdb7dff179d8f4163:/toke.c?ds=sidebyside diff --git a/toke.c b/toke.c index 2ecebad..d6ac752 100644 --- a/toke.c +++ b/toke.c @@ -306,6 +306,15 @@ static const char* const lex_state_names[] = { return (int)LSTOP; \ } while(0) +#define COPLINE_INC_WITH_HERELINES \ + STMT_START { \ + CopLINE_inc(PL_curcop); \ + if (PL_parser->lex_shared->herelines) \ + CopLINE(PL_curcop) += PL_parser->lex_shared->herelines, \ + PL_parser->lex_shared->herelines = 0; \ + } STMT_END + + #ifdef DEBUGGING /* how to interpret the pl_yylval associated with the token */ @@ -424,7 +433,7 @@ S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp) } if (name) Perl_sv_catpv(aTHX_ report, name); - else if ((char)rv > ' ' && (char)rv < '~') + else if ((char)rv > ' ' && (char)rv <= '~') Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv); else if (!rv) sv_catpvs(report, "EOF"); @@ -629,8 +638,8 @@ Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen) static void strip_return(SV *sv) { - register const char *s = SvPVX_const(sv); - register const char * const e = s + SvCUR(sv); + const char *s = SvPVX_const(sv); + const char * const e = s + SvCUR(sv); PERL_ARGS_ASSERT_STRIP_RETURN; @@ -638,7 +647,7 @@ strip_return(SV *sv) while (s < e) { if (*s++ == '\r' && *s == '\n') { /* hit a CR-LF, need to copy the rest */ - register char *d = s - 1; + char *d = s - 1; *d++ = *s++; while (s < e) { if (*s == '\r' && s[1] == '\n') @@ -741,6 +750,7 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags) Newx(parser->lex_brackstack, 120, char); Newx(parser->lex_casestack, 12, char); *parser->lex_casestack = '\0'; + Newxz(parser->lex_shared, 1, LEXSHARED); if (line) { STRLEN len; @@ -748,8 +758,7 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags) parser->linestr = flags & LEX_START_COPIED ? SvREFCNT_inc_simple_NN(line) : newSVpvn_flags(s, len, SvUTF8(line)); - if (!len || s[len-1] != ';') - sv_catpvs(parser->linestr, "\n;"); + sv_catpvs(parser->linestr, "\n;"); } else { parser->linestr = newSVpvs("\n;"); } @@ -785,6 +794,7 @@ Perl_parser_free(pTHX_ const yy_parser *parser) Safefree(parser->lex_brackstack); Safefree(parser->lex_casestack); + Safefree(parser->lex_shared); PL_parser = parser->old_parser; Safefree(parser); } @@ -920,8 +930,8 @@ Perl_lex_grow_linestr(pTHX_ STRLEN len) linestart_pos = PL_parser->linestart - buf; last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0; last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0; - re_eval_start_pos = PL_sublex_info.re_eval_start ? - PL_sublex_info.re_eval_start - buf : 0; + re_eval_start_pos = PL_parser->lex_shared->re_eval_start ? + PL_parser->lex_shared->re_eval_start - buf : 0; buf = sv_grow(linestr, len); @@ -934,8 +944,8 @@ Perl_lex_grow_linestr(pTHX_ STRLEN len) PL_parser->last_uni = buf + last_uni_pos; if (PL_parser->last_lop) PL_parser->last_lop = buf + last_lop_pos; - if (PL_sublex_info.re_eval_start) - PL_sublex_info.re_eval_start = buf + re_eval_start_pos; + if (PL_parser->lex_shared->re_eval_start) + PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos; return buf; } @@ -1166,7 +1176,7 @@ Perl_lex_read_to(pTHX_ char *ptr) Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to"); for (; s != ptr; s++) if (*s == '\n') { - CopLINE_inc(PL_curcop); + COPLINE_INC_WITH_HERELINES; PL_parser->linestart = s+1; } PL_parser->bufptr = ptr; @@ -1249,6 +1259,7 @@ buffer has reached the end of the input text. */ #define LEX_FAKE_EOF 0x80000000 +#define LEX_NO_TERM 0x40000000 bool Perl_lex_next_chunk(pTHX_ U32 flags) @@ -1260,7 +1271,7 @@ 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; - if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF)) + if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM)) Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk"); linestr = PL_parser->linestr; buf = SvPVX(linestr); @@ -1291,6 +1302,8 @@ Perl_lex_next_chunk(pTHX_ U32 flags) } else if (filter_gets(linestr, old_bufend_pos)) { got_some = 1; got_some_for_debugger = 1; + } else if (flags & LEX_NO_TERM) { + got_some = 0; } else { if (!SvPOK(linestr)) /* can get undefined by filter_gets */ sv_setpvs(linestr, ""); @@ -1440,7 +1453,7 @@ Perl_lex_read_unichar(pTHX_ U32 flags) c = lex_peek_unichar(flags); if (c != -1) { if (c == '\n') - CopLINE_inc(PL_curcop); + COPLINE_INC_WITH_HERELINES; if (UTF) PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr); else @@ -1509,7 +1522,7 @@ Perl_lex_read_space(pTHX_ U32 flags) if (flags & LEX_NO_NEXT_CHUNK) break; PL_parser->bufptr = s; - CopLINE_inc(PL_curcop); + COPLINE_INC_WITH_HERELINES; got_more = lex_next_chunk(flags); CopLINE_dec(PL_curcop); s = PL_parser->bufptr; @@ -1552,7 +1565,7 @@ S_incline(pTHX_ const char *s) PERL_ARGS_ASSERT_INCLINE; - CopLINE_inc(PL_curcop); + COPLINE_INC_WITH_HERELINES; if (*s++ != '#') return; while (SPACE_OR_TAB(*s)) @@ -2068,7 +2081,7 @@ STATIC char * S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick) { dVAR; - register char *s; + char *s; STRLEN len; PERL_ARGS_ASSERT_FORCE_WORD; @@ -2313,9 +2326,9 @@ STATIC SV * S_tokeq(pTHX_ SV *sv) { dVAR; - register char *s; - register char *send; - register char *d; + char *s; + char *send; + char *d; STRLEN len = 0; SV *pv = sv; @@ -2384,7 +2397,7 @@ STATIC I32 S_sublex_start(pTHX) { dVAR; - register const I32 op_type = pl_yylval.ival; + const I32 op_type = pl_yylval.ival; if (op_type == OP_NULL) { pl_yylval.opval = PL_lex_op; @@ -2445,6 +2458,7 @@ STATIC I32 S_sublex_push(pTHX) { dVAR; + LEXSHARED *shared; ENTER; PL_lex_state = PL_sublex_info.super_state; @@ -2456,7 +2470,7 @@ S_sublex_push(pTHX) SAVEI32(PL_lex_casemods); SAVEI32(PL_lex_starts); SAVEI8(PL_lex_state); - SAVEPPTR(PL_sublex_info.re_eval_start); + SAVESPTR(PL_lex_repl); SAVEVPTR(PL_lex_inpat); SAVEI16(PL_lex_inwhat); SAVECOPLINE(PL_curcop); @@ -2470,16 +2484,26 @@ S_sublex_push(pTHX) SAVESPTR(PL_linestr); SAVEGENERICPV(PL_lex_brackstack); SAVEGENERICPV(PL_lex_casestack); + SAVEGENERICPV(PL_parser->lex_shared); + + /* The here-doc parser needs to be able to peek into outer lexing + scopes to find the body of the here-doc. So we put PL_linestr and + PL_bufptr into lex_shared, to ‘share’ those values. + */ + PL_parser->lex_shared->ls_linestr = PL_linestr; + PL_parser->lex_shared->ls_bufptr = PL_bufptr; PL_linestr = PL_lex_stuff; + PL_lex_repl = PL_sublex_info.repl; PL_lex_stuff = NULL; - PL_sublex_info.re_eval_start = NULL; + PL_sublex_info.repl = NULL; PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); PL_bufend += SvCUR(PL_linestr); PL_last_lop = PL_last_uni = NULL; SAVEFREESV(PL_linestr); + if (PL_lex_repl) SAVEFREESV(PL_lex_repl); PL_lex_dojoin = FALSE; PL_lex_brackets = PL_lex_formbrack = 0; @@ -2492,6 +2516,10 @@ S_sublex_push(pTHX) PL_lex_starts = 0; PL_lex_state = LEX_INTERPCONCAT; CopLINE_set(PL_curcop, (line_t)PL_multi_start); + + Newxz(shared, 1, LEXSHARED); + shared->ls_prev = PL_parser->lex_shared; + PL_parser->lex_shared = shared; PL_lex_inwhat = PL_sublex_info.sub_inwhat; if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS; @@ -2534,7 +2562,6 @@ S_sublex_done(pTHX) PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); PL_bufend += SvCUR(PL_linestr); PL_last_lop = PL_last_uni = NULL; - SAVEFREESV(PL_linestr); PL_lex_dojoin = FALSE; PL_lex_brackets = 0; PL_lex_allbrackets = 0; @@ -2672,11 +2699,11 @@ STATIC char * S_scan_const(pTHX_ char *start) { dVAR; - register char *send = PL_bufend; /* end of the constant */ + char *send = PL_bufend; /* end of the constant */ SV *sv = newSV(send - start); /* sv for the constant. See note below on sizing. */ - register char *s = start; /* start of the constant */ - register char *d = SvPVX(sv); /* destination for copies */ + char *s = start; /* start of the constant */ + char *d = SvPVX(sv); /* destination for copies */ bool dorange = FALSE; /* are we in a translit range? */ bool didrange = FALSE; /* did we just finish a range? */ bool in_charclass = FALSE; /* within /[...]/ */ @@ -2786,6 +2813,7 @@ S_scan_const(pTHX_ char *start) #endif if (min > max) { + SvREFCNT_dec(sv); Perl_croak(aTHX_ "Invalid range \"%c-%c\" in transliteration operator", (char)min, (char)max); @@ -2844,6 +2872,7 @@ S_scan_const(pTHX_ char *start) /* range begins (ignore - as first or last char) */ else if (*s == '-' && s+1 < send && s != start) { if (didrange) { + SvREFCNT_dec(sv); Perl_croak(aTHX_ "Ambiguous range in transliteration operator"); } if (has_utf8 @@ -4399,8 +4428,8 @@ int Perl_yylex(pTHX) { dVAR; - register char *s = PL_bufptr; - register char *d; + char *s = PL_bufptr; + char *d; STRLEN len; bool bof = FALSE; U8 formbrack = 0; @@ -4488,12 +4517,7 @@ Perl_yylex(pTHX) } if (S_is_opval_token(next_type) && pl_yylval.opval) pl_yylval.opval->op_savefree = 0; /* release */ -#ifdef PERL_MAD - /* FIXME - can these be merged? */ - return next_type; -#else return REPORT(next_type); -#endif } /* interpolated case modifiers like \L \U, including \Q and \E. @@ -4655,7 +4679,7 @@ Perl_yylex(pTHX) } /* Convert (?{...}) and friends to 'do {...}' */ if (PL_lex_inpat && *PL_bufptr == '(') { - PL_sublex_info.re_eval_start = PL_bufptr; + PL_parser->lex_shared->re_eval_start = PL_bufptr; PL_bufptr += 2; if (*PL_bufptr != '{') PL_bufptr++; @@ -4710,20 +4734,34 @@ Perl_yylex(pTHX) Perl_croak(aTHX_ "Bad evalled substitution pattern"); PL_lex_repl = NULL; } - if (PL_sublex_info.re_eval_start) { + /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets + re_eval_str. If the here-doc body’s length equals the previous + value of re_eval_start, re_eval_start will now be null. So + check re_eval_str as well. */ + if (PL_parser->lex_shared->re_eval_start + || PL_parser->lex_shared->re_eval_str) { + SV *sv; if (*PL_bufptr != ')') Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'"); PL_bufptr++; /* having compiled a (?{..}) expression, return the original * text too, as a const */ + if (PL_parser->lex_shared->re_eval_str) { + sv = PL_parser->lex_shared->re_eval_str; + PL_parser->lex_shared->re_eval_str = NULL; + SvCUR_set(sv, + PL_bufptr - PL_parser->lex_shared->re_eval_start); + SvPV_shrink_to_cur(sv); + } + else sv = newSVpvn(PL_parser->lex_shared->re_eval_start, + PL_bufptr - PL_parser->lex_shared->re_eval_start); start_force(PL_curforce); /* XXX probably need a CURMAD(something) here */ NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, - newSVpvn(PL_sublex_info.re_eval_start, - PL_bufptr - PL_sublex_info.re_eval_start)); + sv); force_next(THING); - PL_sublex_info.re_eval_start = NULL; + PL_parser->lex_shared->re_eval_start = NULL; PL_expect = XTERM; return REPORT(','); } @@ -4938,7 +4976,7 @@ Perl_yylex(pTHX) fake_eof = LEX_FAKE_EOF; } PL_bufptr = PL_bufend; - CopLINE_inc(PL_curcop); + COPLINE_INC_WITH_HERELINES; if (!lex_next_chunk(fake_eof)) { CopLINE_dec(PL_curcop); s = PL_bufptr; @@ -5225,6 +5263,7 @@ Perl_yylex(pTHX) incline(s); } else { + const bool in_comment = *s == '#'; d = s; while (d < PL_bufend && *d != '\n') d++; @@ -5238,7 +5277,11 @@ Perl_yylex(pTHX) PL_thiswhite = newSVpvn(s, d - s); #endif s = d; - incline(s); + 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); } if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { PL_lex_state = LEX_FORMLINE; @@ -5710,10 +5753,7 @@ Perl_yylex(pTHX) } switch (PL_expect) { case XTERM: - if (PL_oldoldbufptr == PL_last_lop) - PL_lex_brackstack[PL_lex_brackets++] = XTERM; - else - PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; + PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; PL_lex_allbrackets++; OPERATOR(HASHBRACK); case XOPERATOR: @@ -5889,7 +5929,10 @@ Perl_yylex(pTHX) #endif return yylex(); /* ignore fake brackets */ } - if (*s == '-' && s[1] == '>') + if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr + && SvEVALED(PL_lex_repl)) + PL_lex_state = LEX_INTERPEND; + else if (*s == '-' && s[1] == '>') PL_lex_state = LEX_INTERPENDMAYBE; else if (*s != '[' && *s != '{') PL_lex_state = LEX_INTERPEND; @@ -6001,7 +6044,8 @@ Perl_yylex(pTHX) if (PL_expect == XSTATE && isALPHA(tmp) && (s == PL_linestart+1 || s[-2] == '\n') ) { - if (PL_in_eval && !PL_rsfp && !PL_parser->filtered) { + if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered) + || PL_lex_state != LEX_NORMAL) { d = PL_bufend; while (s < d) { if (*s++ == '\n') { @@ -6097,7 +6141,8 @@ Perl_yylex(pTHX) s = scan_heredoc(s); else s = scan_inputsymbol(s); - TERM(sublex_start()); + PL_expect = XOPERATOR; + TOKEN(sublex_start()); } s++; { @@ -8393,6 +8438,7 @@ Perl_yylex(pTHX) LOP(OP_SYSWRITE,XTERM); case KEY_tr: + case KEY_y: s = scan_trans(s); TERM(sublex_start()); @@ -8520,10 +8566,6 @@ Perl_yylex(pTHX) return REPORT(0); pl_yylval.ival = OP_XOR; OPERATOR(OROP); - - case KEY_y: - s = scan_trans(s); - TERM(sublex_start()); } }} } @@ -8830,8 +8872,8 @@ STATIC char * S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) { dVAR; - register char *d = dest; - register char * const e = d + destlen - 3; /* two-character token, ending NUL */ + char *d = dest; + char * const e = d + destlen - 3; /* two-character token, ending NUL */ PERL_ARGS_ASSERT_SCAN_WORD; @@ -8875,8 +8917,8 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL dVAR; char *bracket = NULL; char funny = *s++; - register char *d = dest; - register char * const e = d + destlen - 3; /* two-character token, ending NUL */ + char *d = dest; + char * const e = d + destlen - 3; /* two-character token, ending NUL */ PERL_ARGS_ASSERT_SCAN_IDENT; @@ -9237,7 +9279,7 @@ S_scan_subst(pTHX_ char *start) { dVAR; char *s; - register PMOP *pm; + PMOP *pm; I32 first_start; I32 es = 0; char charset = '\0'; /* character set modifier */ @@ -9314,8 +9356,6 @@ S_scan_subst(pTHX_ char *start) if (es) { SV * const repl = newSVpvs(""); - PL_sublex_info.super_bufptr = s; - PL_sublex_info.super_bufend = PL_bufend; PL_multi_end = 0; pm->op_pmflags |= PMf_EVAL; while (es-- > 0) { @@ -9325,13 +9365,11 @@ S_scan_subst(pTHX_ char *start) sv_catpvs(repl, "do "); } sv_catpvs(repl, "{"); - sv_catsv(repl, PL_lex_repl); - if (strchr(SvPVX(PL_lex_repl), '#')) - sv_catpvs(repl, "\n"); + sv_catsv(repl, PL_sublex_info.repl); sv_catpvs(repl, "}"); SvEVALED_on(repl); - SvREFCNT_dec(PL_lex_repl); - PL_lex_repl = repl; + SvREFCNT_dec(PL_sublex_info.repl); + PL_sublex_info.repl = repl; } PL_lex_op = (OP*)pm; @@ -9343,7 +9381,7 @@ STATIC char * S_scan_trans(pTHX_ char *start) { dVAR; - register char* s; + char* s; OP *o; U8 squash; U8 del; @@ -9416,7 +9454,7 @@ S_scan_trans(pTHX_ char *start) o->op_private &= ~OPpTRANS_ALL; o->op_private |= del|squash|complement| (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)| - (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0); + (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0); PL_lex_op = o; pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS; @@ -9433,21 +9471,43 @@ S_scan_trans(pTHX_ char *start) return s; } +/* scan_heredoc + Takes a pointer to the first < in <filtered) - && !(PL_lex_inwhat == OP_SCALAR); + const bool infile = PL_rsfp || PL_parser->filtered; + LEXSHARED *shared = PL_parser->lex_shared; #ifdef PERL_MAD I32 stuffstart = s - SvPVX(PL_linestr); char *tstart; @@ -9458,10 +9518,9 @@ S_scan_heredoc(pTHX_ register char *s) PERL_ARGS_ASSERT_SCAN_HEREDOC; s += 2; - d = PL_tokenbuf; + d = PL_tokenbuf + 1; e = PL_tokenbuf + sizeof PL_tokenbuf - 1; - if (!outer) - *d++ = '\n'; + *PL_tokenbuf = '\n'; peek = s; while (SPACE_OR_TAB(*peek)) peek++; @@ -9476,6 +9535,7 @@ S_scan_heredoc(pTHX_ register char *s) } else { if (*s == '\\') + /* <<\FOO is equivalent to <<'FOO' */ s++, term = '\''; else term = '"'; @@ -9494,8 +9554,8 @@ S_scan_heredoc(pTHX_ register char *s) #ifdef PERL_MAD if (PL_madskills) { - tstart = PL_tokenbuf + !outer; - PL_thisclose = newSVpvn(tstart, len - !outer); + tstart = PL_tokenbuf + 1; + PL_thisclose = newSVpvn(tstart, len - 1); tstart = SvPVX(PL_linestr) + stuffstart; PL_thisopen = newSVpvn(tstart, s - tstart); stuffstart = s - SvPVX(PL_linestr); @@ -9526,20 +9586,6 @@ S_scan_heredoc(pTHX_ register char *s) } #endif #ifdef PERL_MAD - found_newline = 0; -#endif - if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) { - herewas = newSVpvn(s,PL_bufend-s); - } - else { -#ifdef PERL_MAD - herewas = newSVpvn(s-1,found_newline-s+1); -#else - s--; - herewas = newSVpvn(s,found_newline-s); -#endif - } -#ifdef PERL_MAD if (PL_madskills) { tstart = SvPVX(PL_linestr) + stuffstart; if (PL_thisstuff) @@ -9547,14 +9593,8 @@ S_scan_heredoc(pTHX_ register char *s) else PL_thisstuff = newSVpvn(tstart, s - tstart); } -#endif - s += SvCUR(herewas); -#ifdef PERL_MAD stuffstart = s - SvPVX(PL_linestr); - - if (found_newline) - s--; #endif tmpstr = newSV_type(SVt_PVIV); @@ -9568,47 +9608,57 @@ S_scan_heredoc(pTHX_ register char *s) SvIV_set(tmpstr, '\\'); } - CLINE; - PL_multi_start = CopLINE(PL_curcop); + PL_multi_start = CopLINE(PL_curcop) + 1; PL_multi_open = PL_multi_close = '<'; - term = *PL_tokenbuf; - if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp - && !PL_parser->filtered) { - char * const bufptr = PL_sublex_info.super_bufptr; - char * const bufend = PL_sublex_info.super_bufend; - char * const olds = s - SvCUR(herewas); - s = strchr(bufptr, '\n'); - if (!s) - s = bufend; + /* inside a string eval or quote-like operator */ + if (!infile || PL_lex_inwhat) { + SV *linestr; + char *bufend; + char * const olds = s; + PERL_CONTEXT * const cx = &cxstack[cxstack_ix]; + /* These two fields are not set until an inner lexing scope is + entered. But we need them set here. */ + shared->ls_bufptr = s; + shared->ls_linestr = PL_linestr; + if (PL_lex_inwhat) + /* Look for a newline. If the current buffer does not have one, + peek into the line buffer of the parent lexing scope, going + up as many levels as necessary to find one with a newline + after bufptr. + */ + while (!(s = (char *)memchr( + (void *)shared->ls_bufptr, '\n', + SvEND(shared->ls_linestr)-shared->ls_bufptr + ))) { + shared = shared->ls_prev; + /* shared is only null if we have gone beyond the outermost + lexing scope. In a file, we will have broken out of the + loop in the previous iteration. In an eval, the string buf- + fer ends with "\n;", so the while condition below will have + evaluated to false. So shared can never be null. */ + assert(shared); + /* A LEXSHARED struct with a null ls_prev pointer is the outer- + most lexing scope. In a file, shared->ls_linestr at that + level is just one line, so there is no body to steal. */ + if (infile && !shared->ls_prev) { + s = olds; + goto streaming; + } + } + else { /* eval */ + s = (char*)memchr((void*)s, '\n', PL_bufend - s); + assert(s); + } + linestr = shared->ls_linestr; + bufend = SvEND(linestr); d = s; while (s < bufend && - (*s != term || memNE(s,PL_tokenbuf,len)) ) { + (*s != '\n' || memNE(s,PL_tokenbuf,len)) ) { if (*s++ == '\n') - CopLINE_inc(PL_curcop); + ++shared->herelines; } if (s >= bufend) { - CopLINE_set(PL_curcop, (line_t)PL_multi_start); - missingterm(PL_tokenbuf); - } - sv_setpvn(herewas,bufptr,d-bufptr+1); - sv_setpvn(tmpstr,d+1,s-d); - s += len - 1; - sv_catpvn(herewas,s,bufend-s); - Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char); - - s = olds; - goto retval; - } - else if (!outer) { - d = s; - while (s < PL_bufend && - (*s != term || memNE(s,PL_tokenbuf,len)) ) { - if (*s++ == '\n') - CopLINE_inc(PL_curcop); - } - if (s >= PL_bufend) { - CopLINE_set(PL_curcop, (line_t)PL_multi_start); - missingterm(PL_tokenbuf); + goto interminable; } sv_setpvn(tmpstr,d+1,s-d); #ifdef PERL_MAD @@ -9621,17 +9671,52 @@ S_scan_heredoc(pTHX_ register char *s) } #endif s += len - 1; - CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */ + /* the preceding stmt passes a newline */ + shared->herelines++; - sv_catpvn(herewas,s,PL_bufend-s); - sv_setsv(PL_linestr,herewas); - PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr); - PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = NULL; + /* s now points to the newline after the heredoc terminator. + d points to the newline before the body of the heredoc. + */ + + /* We are going to modify linestr in place here, so set + aside copies of the string if necessary for re-evals or + (caller $n)[6]. */ + /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we + check shared->re_eval_str. */ + if (shared->re_eval_start || shared->re_eval_str) { + /* Set aside the rest of the regexp */ + if (!shared->re_eval_str) + shared->re_eval_str = + newSVpvn(shared->re_eval_start, + bufend - shared->re_eval_start); + shared->re_eval_start -= s-d; + } + if (CxTYPE(cx) == CXt_EVAL && CxOLD_OP_TYPE(cx) == OP_ENTEREVAL + && cx->blk_eval.cur_text == linestr) { + cx->blk_eval.cur_text = newSVsv(linestr); + SvSCREAM_on(cx->blk_eval.cur_text); + } + /* Copy everything from s onwards back to d. */ + Move(s,d,bufend-s + 1,char); + SvCUR_set(linestr, SvCUR(linestr) - (s-d)); + /* Setting PL_bufend only applies when we have not dug deeper + into other scopes, because sublex_done sets PL_bufend to + SvEND(PL_linestr). */ + if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr); + s = olds; } else - sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */ - while (s >= PL_bufend) { /* multiple line string? */ + { + SV *linestr_save; + streaming: + sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */ + term = PL_tokenbuf[1]; + len--; + linestr_save = PL_linestr; /* must restore this afterwards */ + d = s; /* and this */ + PL_linestr = newSVpvs(""); + PL_bufend = SvPVX(PL_linestr); + while (1) { #ifdef PERL_MAD if (PL_madskills) { tstart = SvPVX(PL_linestr) + stuffstart; @@ -9641,19 +9726,24 @@ S_scan_heredoc(pTHX_ register char *s) PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart); } #endif - PL_bufptr = s; - CopLINE_inc(PL_curcop); - if (!outer || !lex_next_chunk(0)) { - CopLINE_set(PL_curcop, (line_t)PL_multi_start); - missingterm(PL_tokenbuf); + PL_bufptr = PL_bufend; + CopLINE_set(PL_curcop, + PL_multi_start + shared->herelines); + if (!lex_next_chunk(LEX_NO_TERM) + && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) { + SvREFCNT_dec(linestr_save); + goto interminable; + } + CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1); + if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') { + lex_grow_linestr(SvCUR(PL_linestr) + 2); + sv_catpvs(PL_linestr, "\n\0"); } - CopLINE_dec(PL_curcop); s = PL_bufptr; #ifdef PERL_MAD stuffstart = s - SvPVX(PL_linestr); #endif - CopLINE_inc(PL_curcop); - PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + shared->herelines++; PL_last_lop = PL_last_uni = NULL; #ifndef PERL_STRICT_CR if (PL_bufend - PL_linestart >= 2) { @@ -9670,26 +9760,23 @@ S_scan_heredoc(pTHX_ register char *s) else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r') PL_bufend[-1] = '\n'; #endif - if (*s == term && memEQ(s,PL_tokenbuf,len)) { - STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr); - *(SvPVX(PL_linestr) + off ) = ' '; - lex_grow_linestr(SvCUR(PL_linestr) + SvCUR(herewas) + 1); - sv_catsv(PL_linestr,herewas); + if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) { + SvREFCNT_dec(PL_linestr); + PL_linestr = linestr_save; + PL_linestart = SvPVX(linestr_save); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */ + s = d; + break; } else { - s = PL_bufend; sv_catsv(tmpstr,PL_linestr); } + } } - s++; -retval: PL_multi_end = CopLINE(PL_curcop); if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) { SvPV_shrink_to_cur(tmpstr); } - SvREFCNT_dec(herewas); if (!IN_BYTES) { if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr))) SvUTF8_on(tmpstr); @@ -9699,6 +9786,11 @@ retval: PL_lex_stuff = tmpstr; pl_yylval.ival = op_type; return s; + + interminable: + SvREFCNT_dec(tmpstr); + CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1); + missingterm(PL_tokenbuf + 1); } /* scan_inputsymbol @@ -9721,7 +9813,7 @@ STATIC char * S_scan_inputsymbol(pTHX_ char *start) { dVAR; - register char *s = start; /* current position in buffer */ + char *s = start; /* current position in buffer */ char *end; I32 len; char *d = PL_tokenbuf; /* start of temp holding space */ @@ -9913,9 +10005,9 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse) dVAR; SV *sv; /* scalar value: string */ const char *tmps; /* temp string, used for delimiter matching */ - register char *s = start; /* current position in the buffer */ - register char term; /* terminating character */ - register char *to; /* current position in the sv's data */ + char *s = start; /* current position in the buffer */ + char term; /* terminating character */ + char *to; /* current position in the sv's data */ I32 brackets = 1; /* bracket nesting level */ bool has_utf8 = FALSE; /* is there any utf8 content? */ I32 termcode; /* terminating char. code */ @@ -9999,7 +10091,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse) for (; s < ns; s++) { if (*s == '\n' && !PL_rsfp && !PL_parser->filtered) - CopLINE_inc(PL_curcop); + COPLINE_INC_WITH_HERELINES; } if (!found) goto read_more_line; @@ -10066,7 +10158,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse) for (; s < PL_bufend; s++,to++) { /* embedded newlines increment the current line number */ if (*s == '\n' && !PL_rsfp && !PL_parser->filtered) - CopLINE_inc(PL_curcop); + COPLINE_INC_WITH_HERELINES; /* handle quoted delimiters */ if (*s == '\\' && s+1 < PL_bufend && term != '\\') { if (!keep_quoted @@ -10101,7 +10193,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse) for (; s < PL_bufend; s++,to++) { /* embedded newlines increment the line count */ if (*s == '\n' && !PL_rsfp && !PL_parser->filtered) - CopLINE_inc(PL_curcop); + COPLINE_INC_WITH_HERELINES; /* backslashes can escape the open or closing characters */ if (*s == '\\' && s+1 < PL_bufend) { if (!keep_quoted && @@ -10160,7 +10252,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse) PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart); } #endif - CopLINE_inc(PL_curcop); + COPLINE_INC_WITH_HERELINES; PL_bufptr = PL_bufend; if (!lex_next_chunk(0)) { sv_free(sv); @@ -10223,7 +10315,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse) */ if (PL_lex_stuff) - PL_lex_repl = sv; + PL_sublex_info.repl = sv; else PL_lex_stuff = sv; return s; @@ -10255,9 +10347,9 @@ char * Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) { dVAR; - register const char *s = start; /* current position in buffer */ - register char *d; /* destination in temp buffer */ - register char *e; /* end of temp buffer */ + const char *s = start; /* current position in buffer */ + char *d; /* destination in temp buffer */ + char *e; /* end of temp buffer */ NV nv; /* number read, as a double */ SV *sv = NULL; /* place to put the converted number */ bool floatit; /* boolean: int or float? */ @@ -10628,8 +10720,8 @@ STATIC char * S_scan_formline(pTHX_ register char *s) { dVAR; - register char *eol; - register char *t; + char *eol; + char *t; SV * const stuff = newSVpvs(""); bool needargs = FALSE; bool eofmt = FALSE; @@ -10699,7 +10791,7 @@ S_scan_formline(pTHX_ register char *s) } #endif PL_bufptr = PL_bufend; - CopLINE_inc(PL_curcop); + COPLINE_INC_WITH_HERELINES; got_some = lex_next_chunk(0); CopLINE_dec(PL_curcop); s = PL_bufptr; @@ -10735,7 +10827,6 @@ S_scan_formline(pTHX_ register char *s) SvREFCNT_dec(stuff); if (eofmt) PL_lex_formbrack = 0; - PL_bufptr = s; } #ifdef PERL_MAD if (PL_madskills) { @@ -10767,6 +10858,8 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB); CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv)); CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax; + if (outsidecv && CvPADLIST(outsidecv)) + CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id; return oldsavestack_ix; }