X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/956be2d47c8be1238119303e892c672d5de736ad..40f316a72b14619d13e83acddaab24c95cb0c03c:/toke.c diff --git a/toke.c b/toke.c index 0a74efe..e9a06eb 100644 --- a/toke.c +++ b/toke.c @@ -66,7 +66,6 @@ Individual members of C have their own documentation. #define PL_multi_start (PL_parser->multi_start) #define PL_multi_open (PL_parser->multi_open) #define PL_multi_close (PL_parser->multi_close) -#define PL_pending_ident (PL_parser->pending_ident) #define PL_preambled (PL_parser->preambled) #define PL_sublex_info (PL_parser->sublex_info) #define PL_linestr (PL_parser->linestr) @@ -111,11 +110,6 @@ Individual members of C have their own documentation. # define PL_nextval (PL_parser->nextval) #endif -/* This can't be done with embed.fnc, because struct yy_parser contains a - member named pending_ident, which clashes with the generated #define */ -static int -S_pending_ident(pTHX); - static const char ident_too_long[] = "Identifier too long"; #ifdef PERL_MAD @@ -373,7 +367,6 @@ static struct debug_tokens { { METHOD, TOKENTYPE_OPVAL, "METHOD" }, { MULOP, TOKENTYPE_OPNUM, "MULOP" }, { MY, TOKENTYPE_IVAL, "MY" }, - { MYSUB, TOKENTYPE_NONE, "MYSUB" }, { NOAMP, TOKENTYPE_NONE, "NOAMP" }, { NOTOP, TOKENTYPE_NONE, "NOTOP" }, { OROP, TOKENTYPE_IVAL, "OROP" }, @@ -433,7 +426,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"); @@ -930,8 +923,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); @@ -944,8 +937,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; } @@ -2157,6 +2150,14 @@ S_force_ident(pTHX_ register const char *s, int kind) } } +static void +S_force_ident_maybe_lex(pTHX_ char pit) +{ + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.ival = pit; + force_next('p'); +} + NV Perl_str_to_version(pTHX_ SV *sv) { @@ -2471,8 +2472,6 @@ S_sublex_push(pTHX) SAVEI32(PL_lex_starts); SAVEI8(PL_lex_state); SAVESPTR(PL_lex_repl); - SAVEPPTR(PL_sublex_info.re_eval_start); - SAVESPTR(PL_sublex_info.re_eval_str); SAVEVPTR(PL_lex_inpat); SAVEI16(PL_lex_inwhat); SAVECOPLINE(PL_curcop); @@ -2499,8 +2498,6 @@ S_sublex_push(pTHX) PL_lex_repl = PL_sublex_info.repl; PL_lex_stuff = NULL; PL_sublex_info.repl = NULL; - PL_sublex_info.re_eval_start = NULL; - PL_sublex_info.re_eval_str = NULL; PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); @@ -4187,10 +4184,6 @@ Perl_madlex(pTHX) PL_thiswhite = 0; PL_thismad = 0; - /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */ - if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident) - return S_pending_ident(aTHX); - /* previous token ate up our whitespace? */ if (!PL_lasttoke && PL_nextwhite) { PL_thiswhite = PL_nextwhite; @@ -4455,11 +4448,6 @@ Perl_yylex(pTHX) pv_display(tmp, s, strlen(s), 0, 60)); SvREFCNT_dec(tmp); } ); - /* check if there's an identifier for us to look at */ - if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident) - return REPORT(S_pending_ident(aTHX)); - - /* no identifier pending identification */ switch (PL_lex_state) { #ifdef COMMENTARY @@ -4521,7 +4509,7 @@ Perl_yylex(pTHX) } if (S_is_opval_token(next_type) && pl_yylval.opval) pl_yylval.opval->op_savefree = 0; /* release */ - return REPORT(next_type); + return REPORT(next_type == 'p' ? pending_ident() : next_type); } /* interpolated case modifiers like \L \U, including \Q and \E. @@ -4683,7 +4671,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++; @@ -4742,28 +4730,30 @@ Perl_yylex(pTHX) 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_sublex_info.re_eval_start || PL_sublex_info.re_eval_str) { + 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_sublex_info.re_eval_str) { - sv = PL_sublex_info.re_eval_str; - PL_sublex_info.re_eval_str = NULL; - SvCUR_set(sv, PL_bufptr - PL_sublex_info.re_eval_start); + 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_sublex_info.re_eval_start, - PL_bufptr - PL_sublex_info.re_eval_start); + 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, sv); force_next(THING); - PL_sublex_info.re_eval_start = NULL; + PL_parser->lex_shared->re_eval_start = NULL; PL_expect = XTERM; return REPORT(','); } @@ -5265,6 +5255,7 @@ Perl_yylex(pTHX) incline(s); } else { + const bool in_comment = *s == '#'; d = s; while (d < PL_bufend && *d != '\n') d++; @@ -5278,7 +5269,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; @@ -5500,7 +5495,8 @@ Perl_yylex(pTHX) if (!PL_tokenbuf[1]) { PREREF('%'); } - PL_pending_ident = '%'; + PL_expect = XOPERATOR; + force_ident_maybe_lex('%'); TERM('%'); case '^': @@ -5750,10 +5746,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: @@ -5929,7 +5922,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; @@ -5984,10 +5980,12 @@ Perl_yylex(pTHX) BAop(OP_BIT_AND); } - s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE); - if (*PL_tokenbuf) { + PL_tokenbuf[0] = '&'; + s = scan_ident(s - 1, PL_bufend, PL_tokenbuf + 1, + sizeof PL_tokenbuf - 1, TRUE); + if (PL_tokenbuf[1]) { PL_expect = XOPERATOR; - force_ident(PL_tokenbuf, '&'); + force_ident_maybe_lex('&'); } else PREREF('&'); @@ -6223,7 +6221,7 @@ Perl_yylex(pTHX) if (!PL_tokenbuf[1]) PREREF(DOLSHARP); PL_expect = XOPERATOR; - PL_pending_ident = '#'; + force_ident_maybe_lex('#'); TOKEN(DOLSHARP); } @@ -6341,7 +6339,7 @@ Perl_yylex(pTHX) PL_expect = XTERM; /* print $fh <<"EOF" */ } } - PL_pending_ident = '$'; + force_ident_maybe_lex('$'); TOKEN('$'); case '@': @@ -6378,7 +6376,8 @@ Perl_yylex(pTHX) } } } - PL_pending_ident = '@'; + PL_expect = XOPERATOR; + force_ident_maybe_lex('@'); TERM('@'); case '/': /* may be division, defined-or, or pattern */ @@ -6554,8 +6553,16 @@ Perl_yylex(pTHX) s = scan_num(s, &pl_yylval); TERM(THING); } + else if ((*start == ':' && start[1] == ':') + || (PL_expect == XSTATE && *start == ':')) + goto keylookup; + else if (PL_expect == XSTATE) { + d = start; + while (d < PL_bufend && isSPACE(*d)) d++; + if (*d == ':') goto keylookup; + } /* avoid v123abc() or $h{v1}, allow C */ - else if (!isALPHA(*start) && (PL_expect == XTERM + if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE || PL_expect == XTERMORDORDOR)) { GV *const gv = gv_fetchpvn_flags(s, start - s, @@ -6604,11 +6611,21 @@ Perl_yylex(pTHX) keylookup: { bool anydelim; + bool lex; I32 tmp; + SV *sv; + CV *cv; + PADOFFSET off; + OP *rv2cv_op; + lex = FALSE; orig_keyword = 0; + off = 0; + sv = NULL; + cv = NULL; gv = NULL; gvp = NULL; + rv2cv_op = NULL; PL_bufptr = s; s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); @@ -6675,6 +6692,37 @@ Perl_yylex(pTHX) TOKEN(LABEL); } + /* Check for lexical sub */ + if (PL_expect != XOPERATOR) { + char tmpbuf[sizeof PL_tokenbuf + 1]; + *tmpbuf = '&'; + Copy(PL_tokenbuf, tmpbuf+1, len, char); + off = pad_findmy_pvn(tmpbuf, len+1, UTF ? SVf_UTF8 : 0); + if (off != NOT_IN_PAD) { + assert(off); /* we assume this is boolean-true below */ + if (PAD_COMPNAME_FLAGS_isOUR(off)) { + HV * const stash = PAD_COMPNAME_OURSTASH(off); + HEK * const stashname = HvNAME_HEK(stash); + sv = newSVhek(stashname); + sv_catpvs(sv, "::"); + sv_catpvn_flags(sv, PL_tokenbuf, len, + (UTF ? SV_CATUTF8 : SV_CATBYTES)); + gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv), + SVt_PVCV); + off = 0; + } + else { + rv2cv_op = newOP(OP_PADANY, 0); + rv2cv_op->op_targ = off; + rv2cv_op = (OP*)newCVREF(0, rv2cv_op); + cv = (CV *)PAD_SV(off); + } + lex = TRUE; + goto just_a_word; + } + off = 0; + } + if (tmp < 0) { /* second-class keyword? */ GV *ogv = NULL; /* override (winner) */ GV *hgv = NULL; /* hidden (loser) */ @@ -6734,16 +6782,22 @@ Perl_yylex(pTHX) earlier ':' case doesn't bypass the initialisation. */ if (0) { just_a_word_zero_gv: + sv = NULL; + cv = NULL; gv = NULL; gvp = NULL; + rv2cv_op = NULL; orig_keyword = 0; + lex = 0; + off = 0; } just_a_word: { - SV *sv; int pkgname = 0; const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); - OP *rv2cv_op; - CV *cv; + const char penultchar = + lastchar && PL_bufptr - 2 >= PL_linestart + ? PL_bufptr[-2] + : 0; #ifdef PERL_MAD SV *nextPL_nextwhite = 0; #endif @@ -6775,7 +6829,8 @@ Perl_yylex(pTHX) } /* Look for a subroutine with this name in current package, - unless name is "Foo::", in which case Foo is a bareword + unless this is a lexical sub, or name is "Foo::", + in which case Foo is a bareword (and a package name). */ if (len > 2 && !PL_madskills && @@ -6793,7 +6848,7 @@ Perl_yylex(pTHX) gvp = 0; } else { - if (!gv) { + if (!lex && !gv) { /* Mustn't actually add anything to a symbol table. But also don't want to "initialise" any placeholder constants that might already be there into full @@ -6807,7 +6862,8 @@ Perl_yylex(pTHX) /* if we saw a global override before, get the right name */ - sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, + if (!sv) + sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len ? len : strlen(PL_tokenbuf)); if (gvp) { SV * const tmp_sv = sv; @@ -6833,12 +6889,13 @@ Perl_yylex(pTHX) if (len) goto safe_bareword; + if (!off) { OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv)); const_op->op_private = OPpCONST_BARE; rv2cv_op = newCVREF(0, const_op); + cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0); } - cv = rv2cv_op_cv(rv2cv_op, 0); /* See if it's the indirect object for a list operator. */ @@ -6925,7 +6982,8 @@ Perl_yylex(pTHX) } start_force(PL_curforce); #endif - NEXTVAL_NEXTTOKE.opval = pl_yylval.opval; + NEXTVAL_NEXTTOKE.opval = + off ? rv2cv_op : pl_yylval.opval; PL_expect = XOPERATOR; #ifdef PERL_MAD if (PL_madskills) { @@ -6934,8 +6992,9 @@ Perl_yylex(pTHX) PL_thistoken = newSVpvs(""); } #endif - op_free(rv2cv_op); - force_next(WORD); + if (off) + op_free(pl_yylval.opval), force_next(PRIVATEREF); + else op_free(rv2cv_op), force_next(WORD); pl_yylval.ival = 0; TOKEN('&'); } @@ -6967,7 +7026,7 @@ Perl_yylex(pTHX) /* Not a method, so call it a subroutine (if defined) */ if (cv) { - if (lastchar == '-') { + if (lastchar == '-' && penultchar != '-') { const SV *tmpsv = newSVpvn_flags( PL_tokenbuf, len ? len : strlen(PL_tokenbuf), (UTF ? SVf_UTF8 : 0) | SVs_TEMP ); Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of -%"SVf" resolved as -&%"SVf"()", @@ -7050,7 +7109,7 @@ Perl_yylex(pTHX) curmad('X', PL_thistoken); PL_thistoken = newSVpvs(""); } - force_next(WORD); + force_next(off ? PRIVATEREF : WORD); if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; @@ -7093,7 +7152,7 @@ Perl_yylex(pTHX) PL_nextwhite = nextPL_nextwhite; curmad('X', PL_thistoken); PL_thistoken = newSVpvs(""); - force_next(WORD); + force_next(off ? PRIVATEREF : WORD); if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; @@ -7102,7 +7161,7 @@ Perl_yylex(pTHX) #else NEXTVAL_NEXTTOKE.opval = pl_yylval.opval; PL_expect = XTERM; - force_next(WORD); + force_next(off ? PRIVATEREF : WORD); if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; @@ -7418,10 +7477,15 @@ Perl_yylex(pTHX) if (*s == '{') PRETERMBLOCK(DO); if (*s != '\'') { - d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, 1, &len); - if (len) { + *PL_tokenbuf = '&'; + d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, + 1, &len); + if (len && !keyword(PL_tokenbuf + 1, len, 0)) { d = SKIPSPACE1(d); - if (*d == '(') s = force_word(s,WORD,TRUE,TRUE,FALSE); + if (*d == '(') { + force_ident_maybe_lex('&'); + s = d; + } } } if (orig_keyword == KEY_do) { @@ -7456,6 +7520,7 @@ Perl_yylex(pTHX) UNI(OP_DBMCLOSE); case KEY_dump: + PL_expect = XOPERATOR; s = force_word(s,WORD,TRUE,FALSE,FALSE); LOOPX(OP_DUMP); @@ -7588,6 +7653,7 @@ Perl_yylex(pTHX) LOP(OP_GREPSTART, XREF); case KEY_goto: + PL_expect = XOPERATOR; s = force_word(s,WORD,TRUE,FALSE,FALSE); LOOPX(OP_GOTO); @@ -7710,6 +7776,7 @@ Perl_yylex(pTHX) LOP(OP_KILL,XTERM); case KEY_last: + PL_expect = XOPERATOR; s = force_word(s,WORD,TRUE,FALSE,FALSE); LOOPX(OP_LAST); @@ -7787,7 +7854,14 @@ Perl_yylex(pTHX) #endif s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3)) + { + if (!FEATURE_LEXSUBS_IS_ENABLED) + Perl_croak(aTHX_ + "Experimental \"%s\" subs not enabled", + tmp == KEY_my ? "my" : + tmp == KEY_state ? "state" : "our"); goto really_sub; + } PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len); if (!PL_in_my_stash) { char tmpbuf[1024]; @@ -7807,6 +7881,7 @@ Perl_yylex(pTHX) OPERATOR(MY); case KEY_next: + PL_expect = XOPERATOR; s = force_word(s,WORD,TRUE,FALSE,FALSE); LOOPX(OP_NEXT); @@ -7992,6 +8067,7 @@ Perl_yylex(pTHX) case KEY_require: s = SKIPSPACE1(s); + PL_expect = XOPERATOR; if (isDIGIT(*s)) { s = force_version(s, FALSE); } @@ -8023,6 +8099,7 @@ Perl_yylex(pTHX) UNI(OP_RESET); case KEY_redo: + PL_expect = XOPERATOR; s = force_word(s,WORD,TRUE,FALSE,FALSE); LOOPX(OP_REDO); @@ -8195,7 +8272,7 @@ Perl_yylex(pTHX) case KEY_sub: really_sub: { - char tmpbuf[sizeof PL_tokenbuf]; + char * const tmpbuf = PL_tokenbuf + 1; SSize_t tboffset = 0; expectation attrful; bool have_name, have_proto; @@ -8211,6 +8288,7 @@ Perl_yylex(pTHX) d = s; s = SKIPSPACE2(s,tmpwhite); #else + d = s; s = skipspace(s); #endif @@ -8225,12 +8303,17 @@ Perl_yylex(pTHX) attrful = XATTRBLOCK; /* remember buffer pos'n for later force_word */ tboffset = s - PL_oldbufptr; - d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); + d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE, + &len); #ifdef PERL_MAD if (PL_madskills) nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr)); #endif - if (memchr(tmpbuf, ':', len)) + *PL_tokenbuf = '&'; + if (memchr(tmpbuf, ':', len) || key != KEY_sub + || pad_findmy_pvn( + PL_tokenbuf, len + 1, UTF ? SVf_UTF8 : 0 + ) != NOT_IN_PAD) sv_setpvn(PL_subname, tmpbuf, len); else { sv_setsv(PL_subname,PL_curstname); @@ -8241,13 +8324,12 @@ Perl_yylex(pTHX) SvUTF8_on(PL_subname); have_name = TRUE; -#ifdef PERL_MAD +#ifdef PERL_MAD start_force(0); CURMAD('X', nametoke); CURMAD('_', tmpwhite); - (void) force_word(PL_oldbufptr + tboffset, WORD, - FALSE, TRUE, TRUE); + force_ident_maybe_lex('&'); s = SKIPSPACE2(d,tmpwhite); #else @@ -8255,8 +8337,13 @@ Perl_yylex(pTHX) #endif } else { - if (key == KEY_my) - Perl_croak(aTHX_ "Missing name in \"my sub\""); + if (key == KEY_my || key == KEY_our || key==KEY_state) + { + *d = '\0'; + /* diag_listed_as: Missing name in "%s sub" */ + Perl_croak(aTHX_ + "Missing name in \"%s\"", PL_bufptr); + } PL_expect = XTERMBLOCK; attrful = XATTRTERM; sv_setpvs(PL_subname,"?"); @@ -8405,11 +8492,8 @@ Perl_yylex(pTHX) TOKEN(ANONSUB); } #ifndef PERL_MAD - (void) force_word(PL_oldbufptr + tboffset, WORD, - FALSE, TRUE, TRUE); + force_ident_maybe_lex('&'); #endif - if (key == KEY_my) - TOKEN(MYSUB); TOKEN(SUB); } @@ -8575,14 +8659,11 @@ S_pending_ident(pTHX) { dVAR; PADOFFSET tmp = 0; - /* pit holds the identifier we read and pending_ident is reset */ - char pit = PL_pending_ident; + const char pit = (char)pl_yylval.ival; const STRLEN tokenbuf_len = strlen(PL_tokenbuf); /* All routes through this function want to know if there is a colon. */ const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len); - PL_pending_ident = 0; - /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */ DEBUG_T({ PerlIO_printf(Perl_debug_log, "### Pending identifier '%s'\n", PL_tokenbuf); }); @@ -8609,7 +8690,7 @@ S_pending_ident(pTHX) pl_yylval.opval = newOP(OP_PADANY, 0); pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0); - return PRIVATEREF; + return PRIVATEREF; } } @@ -8632,7 +8713,8 @@ S_pending_ident(pTHX) sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES )); pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym); pl_yylval.opval->op_private = OPpCONST_ENTERED; - gv_fetchsv(sym, + if (pit != '&') + gv_fetchsv(sym, (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADDMULTI @@ -8673,11 +8755,13 @@ S_pending_ident(pTHX) } /* build ops for a bareword */ - pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(PL_tokenbuf + 1, + pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, + newSVpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1, UTF ? SVf_UTF8 : 0 )); pl_yylval.opval->op_private = OPpCONST_ENTERED; - gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1, + if (pit != '&') + gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1, (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ), ((PL_tokenbuf[0] == '$') ? SVt_PV @@ -9363,8 +9447,6 @@ S_scan_subst(pTHX_ char *start) } sv_catpvs(repl, "{"); sv_catsv(repl, PL_sublex_info.repl); - if (strchr(SvPVX(PL_sublex_info.repl), '#')) - sv_catpvs(repl, "\n"); sv_catpvs(repl, "}"); SvEVALED_on(repl); SvREFCNT_dec(PL_sublex_info.repl); @@ -9480,36 +9562,28 @@ S_scan_trans(pTHX_ char *start) a whole string being evalled, or the contents of the current quote- like operator. - The three methods are: - - Steal lines from the input stream (stream) - - Scan the heredoc in PL_linestr and remove it therefrom (linestr) - - Peek at the PL_linestr of outer lexing scopes (peek) - - They are used in these cases: - file scope or filtered eval stream - string eval linestr - multiline quoted construct linestr - single-line quoted construct in file stream - single-line quoted construct in eval or quote peek + The two basic methods are: + - Steal lines from the input stream + - Scan the heredoc in PL_linestr and remove it therefrom - Single-line also applies to heredocs that begin on the last line of a - quote-like operator. + In a file scope or filtered eval, the first method is used; in a + string eval, the second. - Peeking within a quote also involves falling back to the stream method, - if the outer quote-like operators are all on one line (or the heredoc - marker is on the last line). + In a quote-like operator, we have to choose between the two, + depending on where we can find a newline. We peek into outer lex- + ing scopes until we find one with a newline in it. If we reach the + outermost lexing scope and it is a file, we use the stream method. + Otherwise it is treated as an eval. */ STATIC char * S_scan_heredoc(pTHX_ register char *s) { dVAR; - SV *herewas; I32 op_type = OP_SCALAR; I32 len; SV *tmpstr; char term; - const char *found_newline = 0; char *d; char *e; char *peek; @@ -9592,18 +9666,6 @@ S_scan_heredoc(pTHX_ register char *s) s = olds; } #endif - if ((infile && !PL_lex_inwhat) - || !(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; @@ -9612,14 +9674,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); @@ -9635,18 +9691,26 @@ S_scan_heredoc(pTHX_ register char *s) PL_multi_start = CopLINE(PL_curcop) + 1; PL_multi_open = PL_multi_close = '<'; - if (PL_lex_inwhat && !found_newline) { - /* 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. See the comments in sublex_push for how IVX and NVX - are abused. - */ + /* inside a string eval or quote-like operator */ + if (!infile || PL_lex_inwhat) { SV *linestr; - char *bufptr, *bufend; - char * const olds = s - SvCUR(herewas); - char * const real_olds = s; + char *bufend; + char * const olds = s; PERL_CONTEXT * const cx = &cxstack[cxstack_ix]; - do { + /* 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 @@ -9658,14 +9722,14 @@ S_scan_heredoc(pTHX_ register char *s) 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 = real_olds; + s = olds; goto streaming; } - } while (!(s = (char *)memchr( - (void *)shared->ls_bufptr, '\n', - SvEND(shared->ls_linestr)-shared->ls_bufptr - ))); - bufptr = shared->ls_bufptr; + } + else { /* eval */ + s = (char*)memchr((void*)s, '\n', PL_bufend - s); + assert(s); + } linestr = shared->ls_linestr; bufend = SvEND(linestr); d = s; @@ -9675,42 +9739,7 @@ S_scan_heredoc(pTHX_ register char *s) ++shared->herelines; } if (s >= bufend) { - SvREFCNT_dec(herewas); - SvREFCNT_dec(tmpstr); - CopLINE_set(PL_curcop, (line_t)PL_multi_start-1); - missingterm(PL_tokenbuf + 1); - } - 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); - } - 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); - SvCUR_set(linestr, - bufptr-SvPVX_const(linestr) - + SvCUR(herewas)); - - s = olds; - goto retval; - } - else if (!infile || found_newline) { - char * const olds = s - SvCUR(herewas); - PERL_CONTEXT * const cx = &cxstack[cxstack_ix]; - d = s; - while (s < PL_bufend && - (*s != '\n' || memNE(s,PL_tokenbuf,len)) ) { - if (*s++ == '\n') - ++shared->herelines; - } - if (s >= PL_bufend) { - SvREFCNT_dec(herewas); - SvREFCNT_dec(tmpstr); - CopLINE_set(PL_curcop, (line_t)PL_multi_start-1); - missingterm(PL_tokenbuf + 1); + goto interminable; } sv_setpvn(tmpstr,d+1,s-d); #ifdef PERL_MAD @@ -9729,33 +9758,46 @@ S_scan_heredoc(pTHX_ register char *s) /* 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 PL_sublex_info.re_eval_str. */ - if (PL_sublex_info.re_eval_start || PL_sublex_info.re_eval_str) { + check shared->re_eval_str. */ + if (shared->re_eval_start || shared->re_eval_str) { /* Set aside the rest of the regexp */ - if (!PL_sublex_info.re_eval_str) - PL_sublex_info.re_eval_str = - newSVpvn(PL_sublex_info.re_eval_start, - PL_bufend - PL_sublex_info.re_eval_start); - PL_sublex_info.re_eval_start -= s-d; + 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 == PL_linestr) { - cx->blk_eval.cur_text = newSVsv(PL_linestr); + && 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,PL_bufend-s + 1,char); - SvCUR_set(PL_linestr, SvCUR(PL_linestr) - (s-d)); - PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + 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 - streaming: - sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */ - term = PL_tokenbuf[1]; - len--; - 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; @@ -9765,15 +9807,13 @@ S_scan_heredoc(pTHX_ register char *s) PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart); } #endif - PL_bufptr = s; + 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(herewas); - SvREFCNT_dec(tmpstr); - CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1); - missingterm(PL_tokenbuf + 1); + SvREFCNT_dec(linestr_save); + goto interminable; } CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1); if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') { @@ -9785,7 +9825,6 @@ S_scan_heredoc(pTHX_ register char *s) stuffstart = s - SvPVX(PL_linestr); #endif shared->herelines++; - PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = NULL; #ifndef PERL_STRICT_CR if (PL_bufend - PL_linestart >= 2) { @@ -9803,25 +9842,22 @@ S_scan_heredoc(pTHX_ register char *s) PL_bufend[-1] = '\n'; #endif if (*s == term && memEQ(s,PL_tokenbuf + 1,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); + 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); @@ -9831,6 +9867,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