X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/fbdd83da9d18c8503ae64943ae75be034fecb787..3328ab5af72319f76fe9be3910a8e07d38b14de2:/toke.c diff --git a/toke.c b/toke.c index 6cc0336..c628a21 100644 --- a/toke.c +++ b/toke.c @@ -148,6 +148,9 @@ static const char ident_too_long[] = "Identifier too long"; /* LEX_* are values for PL_lex_state, the state of the lexer. * They are arranged oddly so that the guard on the switch statement * can get by with a single comparison (if the compiler is smart enough). + * + * These values refer to the various states within a sublex parse, + * i.e. within a double quotish string */ /* #define LEX_NOTPARSING 11 is done in perl.h. */ @@ -272,9 +275,9 @@ static const char* const lex_state_names[] = { * The UNIDOR macro is for unary functions that can be followed by the // * operator (such as C). */ -#define UNI2(f,x) { \ +#define UNI3(f,x,have_x) { \ pl_yylval.ival = f; \ - PL_expect = x; \ + if (have_x) PL_expect = x; \ PL_bufptr = s; \ PL_last_uni = PL_oldbufptr; \ PL_last_lop_op = f; \ @@ -283,22 +286,14 @@ static const char* const lex_state_names[] = { s = PEEKSPACE(s); \ return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \ } -#define UNI(f) UNI2(f,XTERM) -#define UNIDOR(f) UNI2(f,XTERMORDORDOR) +#define UNI(f) UNI3(f,XTERM,1) +#define UNIDOR(f) UNI3(f,XTERMORDORDOR,1) #define UNIPROTO(f,optional) { \ if (optional) PL_last_uni = PL_oldbufptr; \ OPERATOR(f); \ } -#define UNIBRACK(f) { \ - pl_yylval.ival = f; \ - PL_bufptr = s; \ - PL_last_uni = PL_oldbufptr; \ - if (*s == '(') \ - return REPORT( (int)FUNC1 ); \ - s = PEEKSPACE(s); \ - return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \ - } +#define UNIBRACK(f) UNI3(f,0,0) /* grandfather return to old style */ #define OLDLOP(f) \ @@ -311,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 */ @@ -319,8 +323,7 @@ enum token_type { TOKENTYPE_IVAL, TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */ TOKENTYPE_PVAL, - TOKENTYPE_OPVAL, - TOKENTYPE_GVVAL + TOKENTYPE_OPVAL }; static struct debug_tokens { @@ -350,6 +353,8 @@ static struct debug_tokens { { EQOP, TOKENTYPE_OPNUM, "EQOP" }, { FOR, TOKENTYPE_IVAL, "FOR" }, { FORMAT, TOKENTYPE_NONE, "FORMAT" }, + { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" }, + { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" }, { FUNC, TOKENTYPE_OPNUM, "FUNC" }, { FUNC0, TOKENTYPE_OPNUM, "FUNC0" }, { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" }, @@ -374,6 +379,7 @@ static struct debug_tokens { { OROP, TOKENTYPE_IVAL, "OROP" }, { OROR, TOKENTYPE_NONE, "OROR" }, { PACKAGE, TOKENTYPE_NONE, "PACKAGE" }, + { PEG, TOKENTYPE_NONE, "PEG" }, { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" }, { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" }, { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" }, @@ -383,8 +389,10 @@ static struct debug_tokens { { PREDEC, TOKENTYPE_NONE, "PREDEC" }, { PREINC, TOKENTYPE_NONE, "PREINC" }, { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" }, + { QWLIST, TOKENTYPE_OPVAL, "QWLIST" }, { REFGEN, TOKENTYPE_NONE, "REFGEN" }, { RELOP, TOKENTYPE_OPNUM, "RELOP" }, + { REQUIRE, TOKENTYPE_NONE, "REQUIRE" }, { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" }, { SUB, TOKENTYPE_NONE, "SUB" }, { THING, TOKENTYPE_OPVAL, "THING" }, @@ -433,7 +441,6 @@ S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp) Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv); switch (type) { case TOKENTYPE_NONE: - case TOKENTYPE_GVVAL: /* doesn't appear to be used */ break; case TOKENTYPE_IVAL: Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival); @@ -631,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; @@ -640,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') @@ -743,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; @@ -750,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;"); } @@ -787,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); } @@ -910,7 +918,7 @@ Perl_lex_grow_linestr(pTHX_ STRLEN len) SV *linestr; char *buf; STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos; - STRLEN linestart_pos, last_uni_pos, last_lop_pos; + STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos; linestr = PL_parser->linestr; buf = SvPVX(linestr); if (len <= SvLEN(linestr)) @@ -922,7 +930,11 @@ 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_parser->lex_shared->re_eval_start ? + PL_parser->lex_shared->re_eval_start - buf : 0; + buf = sv_grow(linestr, len); + PL_parser->bufend = buf + bufend_pos; PL_parser->bufptr = buf + bufptr_pos; PL_parser->oldbufptr = buf + oldbufptr_pos; @@ -932,6 +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_parser->lex_shared->re_eval_start) + PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos; return buf; } @@ -1162,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; @@ -1245,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) @@ -1256,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); @@ -1287,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, ""); @@ -1436,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 @@ -1505,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; @@ -1548,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)) @@ -1984,6 +2001,11 @@ S_force_next(pTHX_ I32 type) tokereport(type, &NEXTVAL_NEXTTOKE); } #endif + /* Don’t let opslab_force_free snatch it */ + if (S_is_opval_token(type & 0xffff) && NEXTVAL_NEXTTOKE.opval) { + assert(!NEXTVAL_NEXTTOKE.opval->op_savefree); + NEXTVAL_NEXTTOKE.opval->op_savefree = 1; + } #ifdef PERL_MAD if (PL_curforce < 0) start_force(PL_lasttoke); @@ -2059,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; @@ -2304,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; @@ -2349,14 +2371,10 @@ S_tokeq(pTHX_ SV *sv) * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They * interact with PL_lex_state, and create fake ( ... ) argument lists * to handle functions and concatenation. - * They assume that whoever calls them will be setting up a fake - * join call, because each subthing puts a ',' after it. This lets - * "lower \luPpEr" - * become - * join($, , 'lower ', lcfirst( 'uPpEr', ) ,) - * - * (I'm not sure whether the spurious commas at the end of lcfirst's - * arguments and join's arguments are created or not). + * For example, + * "foo\lbar" + * is tokenised as + * stringify ( const[foo] concat lcfirst ( const[bar] ) ) */ /* @@ -2379,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; @@ -2440,16 +2458,19 @@ STATIC I32 S_sublex_push(pTHX) { dVAR; + LEXSHARED *shared; ENTER; PL_lex_state = PL_sublex_info.super_state; SAVEBOOL(PL_lex_dojoin); SAVEI32(PL_lex_brackets); SAVEI32(PL_lex_allbrackets); + SAVEI32(PL_lex_formbrack); SAVEI8(PL_lex_fakeeof); SAVEI32(PL_lex_casemods); SAVEI32(PL_lex_starts); SAVEI8(PL_lex_state); + SAVESPTR(PL_lex_repl); SAVEVPTR(PL_lex_inpat); SAVEI16(PL_lex_inwhat); SAVECOPLINE(PL_curcop); @@ -2463,18 +2484,29 @@ 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.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 = 0; + PL_lex_brackets = PL_lex_formbrack = 0; PL_lex_allbrackets = 0; PL_lex_fakeeof = LEX_FAKEEOF_NEVER; Newx(PL_lex_brackstack, 120, char); @@ -2484,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; @@ -2526,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; @@ -2575,8 +2610,11 @@ S_sublex_done(pTHX) /* scan_const - Extracts a pattern, double-quoted string, or transliteration. This - is terrifying code. + Extracts the next constant part of a pattern, double-quoted string, + or transliteration. This is terrifying code. + + For example, in parsing the double-quoted string "ab\x63$d", it would + stop at the '$' and return an OP_CONST containing 'abc'. It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's processing a pattern (PL_lex_inpat is true), a transliteration @@ -2584,15 +2622,22 @@ S_sublex_done(pTHX) Returns a pointer to the character scanned up to. If this is advanced from the start pointer supplied (i.e. if anything was - successfully parsed), will leave an OP for the substring scanned + successfully parsed), will leave an OP_CONST for the substring scanned in pl_yylval. Caller must intuit reason for not parsing further by looking at the next characters herself. In patterns: - backslashes: - constants: \N{NAME} only - case and quoting: \U \Q \E - stops on @ and $, but not for $ as tail anchor + expand: + \N{ABC} => \N{U+41.42.43} + + pass through: + all other \-char, including \N and \N{ apart from \N{ABC} + + stops on: + @ and $ where it appears to be a var, but not for $ as tail anchor + \l \L \u \U \Q \E + (?{ or (??{ + In transliterations: characters are VERY literal, except for - not at the start or end @@ -2622,7 +2667,7 @@ S_sublex_done(pTHX) it's a tail anchor if $ is the last thing in the string, or if it's followed by one of "()| \r\n\t" - \1 (backreferences) are turned into $1 + \1 (backreferences) are turned into $1 in substitutions The structure of the code is while (there's a character to process) { @@ -2654,13 +2699,14 @@ 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 /[...]/ */ bool has_utf8 = FALSE; /* Output constant is UTF8 */ bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be UTF8? But, this can @@ -2767,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); @@ -2825,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 @@ -2850,33 +2898,38 @@ S_scan_const(pTHX_ char *start) /* if we get here, we're not doing a transliteration */ - /* skip for regexp comments /(?#comment)/ and code /(?{code})/, - except for the last char, which will be done separately. */ + else if (*s == '[' && PL_lex_inpat && !in_charclass) { + char *s1 = s-1; + int esc = 0; + while (s1 >= start && *s1-- == '\\') + esc = !esc; + if (!esc) + in_charclass = TRUE; + } + + else if (*s == ']' && PL_lex_inpat && in_charclass) { + char *s1 = s-1; + int esc = 0; + while (s1 >= start && *s1-- == '\\') + esc = !esc; + if (!esc) + in_charclass = FALSE; + } + + /* 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] == '?') { if (s[2] == '#') { while (s+1 < send && *s != ')') *d++ = NATIVE_TO_NEED(has_utf8,*s++); } - else if (s[2] == '{' /* This should match regcomp.c */ - || (s[2] == '?' && s[3] == '{')) + else if (!PL_lex_casemods && !in_charclass && + ( s[2] == '{' /* This should match regcomp.c */ + || (s[2] == '?' && s[3] == '{'))) { - I32 count = 1; - char *regparse = s + (s[2] == '{' ? 3 : 4); - char c; - - while (count && (c = *regparse)) { - if (c == '\\' && regparse[1]) - regparse++; - else if (c == '{') - count++; - else if (c == '}') - count--; - regparse++; - } - if (*regparse != ')') - regparse--; /* Leave one char for continuation. */ - while (s < regparse) - *d++ = NATIVE_TO_NEED(has_utf8,*s++); + break; } } @@ -2887,6 +2940,10 @@ S_scan_const(pTHX_ char *start) *d++ = NATIVE_TO_NEED(has_utf8,*s++); } + /* 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, @+, @-) */ @@ -2970,7 +3027,7 @@ S_scan_const(pTHX_ char *start) /* FALL THROUGH */ default: { - if ((isALPHA(*s) || isDIGIT(*s))) + if ((isALNUMC(*s))) Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Unrecognized escape \\%c passed through", *s); @@ -3006,29 +3063,16 @@ S_scan_const(pTHX_ char *start) /* eg. \x24 indicates the hex constant 0x24 */ case 'x': - ++s; - if (*s == '{') { - char* const e = strchr(s, '}'); - I32 flags = PERL_SCAN_ALLOW_UNDERSCORES | - PERL_SCAN_DISALLOW_PREFIX; + { STRLEN len; + const char* error; - ++s; - if (!e) { - yyerror("Missing right brace on \\x{}"); + bool valid = grok_bslash_x(s, &uv, &len, &error, 1); + s += len; + if (! valid) { + yyerror(error); continue; } - len = e - s; - uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL)); - s = e + 1; - } - else { - { - STRLEN len = 2; - I32 flags = PERL_SCAN_DISALLOW_PREFIX; - uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL)); - s += len; - } } NUM_ESCAPE_INSERT: @@ -3556,6 +3600,9 @@ S_scan_const(pTHX_ char *start) } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) { type = "s"; typelen = 1; + } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') { + type = "q"; + typelen = 1; } else { type = "qq"; typelen = 2; @@ -3732,7 +3779,7 @@ S_intuit_more(pTHX_ register char *s) * * First argument is the stuff after the first token, e.g. "bar". * - * Not a method if bar is a filehandle. + * Not a method if foo is a filehandle. * Not a method if foo is a subroutine prototyped to take a filehandle. * Not a method if it's really "Foo $bar" * Method if it's "foo $bar" @@ -3757,11 +3804,9 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) PERL_ARGS_ASSERT_INTUIT_METHOD; - if (gv) { - if (SvTYPE(gv) == SVt_PVGV && GvIO(gv)) + if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv)) return 0; - if (cv) { - if (SvPOK(cv)) { + if (cv && SvPOK(cv)) { const char *proto = CvPROTO(cv); if (proto) { if (*proto == ';') @@ -3769,9 +3814,6 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) if (*proto == '*') return 0; } - } - } else - gv = NULL; } s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); /* start is the beginning of the possible filehandle/object, @@ -3780,7 +3822,7 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) */ if (*start == '$') { - if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY || + if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY || isUPPER(*PL_tokenbuf)) return 0; #ifdef PERL_MAD @@ -3807,7 +3849,7 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) if (indirgv && GvCVu(indirgv)) return 0; /* filehandle or package name makes it a method */ - if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) { + if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) { #ifdef PERL_MAD soff = s - SvPVX(PL_linestr); #endif @@ -4314,6 +4356,7 @@ S_tokenize_use(pTHX_ int is_use, char *s) { if (PL_expect != XSTATE) yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression", is_use ? "use" : "no")); + PL_expect = XTERM; s = SKIPSPACE1(s); if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { s = force_version(s, TRUE); @@ -4385,10 +4428,11 @@ 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; U32 fake_eof = 0; /* orig_keyword, gvp, and gv are initialized here because @@ -4471,12 +4515,9 @@ Perl_yylex(pTHX) PL_lex_allbrackets--; next_type &= 0xffff; } -#ifdef PERL_MAD - /* FIXME - can these be merged? */ - return next_type; -#else + if (S_is_opval_token(next_type) && pl_yylval.opval) + pl_yylval.opval->op_savefree = 0; /* release */ return REPORT(next_type); -#endif } /* interpolated case modifiers like \L \U, including \Q and \E. @@ -4615,7 +4656,7 @@ Perl_yylex(pTHX) case LEX_INTERPSTART: if (PL_bufptr == PL_bufend) return REPORT(sublex_done()); - DEBUG_T({ PerlIO_printf(Perl_debug_log, + DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log, "### Interpolated variable\n"); }); PL_expect = XTERM; PL_lex_dojoin = (*PL_bufptr == '@'); @@ -4636,6 +4677,18 @@ Perl_yylex(pTHX) NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */ force_next(FUNC); } + /* Convert (?{...}) and friends to 'do {...}' */ + if (PL_lex_inpat && *PL_bufptr == '(') { + PL_parser->lex_shared->re_eval_start = PL_bufptr; + PL_bufptr += 2; + if (*PL_bufptr != '{') + PL_bufptr++; + start_force(PL_curforce); + /* XXX probably need a CURMAD(something) here */ + PL_expect = XTERMBLOCK; + force_next(DO); + } + if (PL_lex_starts++) { s = PL_bufptr; #ifdef PERL_MAD @@ -4681,6 +4734,38 @@ Perl_yylex(pTHX) Perl_croak(aTHX_ "Bad evalled substitution pattern"); PL_lex_repl = NULL; } + /* 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, + sv); + force_next(THING); + PL_parser->lex_shared->re_eval_start = NULL; + PL_expect = XTERM; + return REPORT(','); + } + /* FALLTHROUGH */ case LEX_INTERPCONCAT: #ifdef DEBUGGING @@ -4691,12 +4776,10 @@ Perl_yylex(pTHX) if (PL_bufptr == PL_bufend) return REPORT(sublex_done()); - if (SvIVX(PL_linestr) == '\'') { + /* m'foo' still needs to be parsed for possible (?{...}) */ + if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) { SV *sv = newSVsv(PL_linestr); - if (!PL_lex_inpat) - sv = tokeq(sv); - else if ( PL_hints & HINT_NEW_RE ) - sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1); + sv = tokeq(sv); pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); s = PL_bufend; } @@ -4738,11 +4821,14 @@ Perl_yylex(pTHX) return yylex(); case LEX_FORMLINE: - PL_lex_state = LEX_NORMAL; s = scan_formline(PL_bufptr); if (!PL_lex_formbrack) + { + formbrack = 1; goto rightbracket; - OPERATOR(';'); + } + PL_bufptr = s; + return yylex(); } s = PL_bufptr; @@ -4890,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; @@ -5134,9 +5220,11 @@ Perl_yylex(pTHX) } } if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { - PL_bufptr = s; PL_lex_state = LEX_FORMLINE; - return yylex(); + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.ival = 0; + force_next(FORMRBRACK); + TOKEN(';'); } goto retry; case '\r': @@ -5191,9 +5279,11 @@ Perl_yylex(pTHX) incline(s); } if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { - PL_bufptr = s; PL_lex_state = LEX_FORMLINE; - return yylex(); + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.ival = 0; + force_next(FORMRBRACK); + TOKEN(';'); } } else { @@ -5495,7 +5585,7 @@ Perl_yylex(pTHX) } sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0); if (*d == '(') { - d = scan_str(d,TRUE,TRUE); + d = scan_str(d,TRUE,TRUE,FALSE); if (!d) { /* MUST advance bufptr here to avoid bogus "at end of line" context messages from yyerror(). @@ -5651,17 +5741,13 @@ Perl_yylex(pTHX) } TERM(']'); case '{': - leftbracket: s++; + leftbracket: if (PL_lex_brackets > 100) { Renew(PL_lex_brackstack, PL_lex_brackets + 10, char); } switch (PL_expect) { case XTERM: - if (PL_lex_formbrack) { - s--; - PRETERMBLOCK(DO); - } if (PL_oldoldbufptr == PL_last_lop) PL_lex_brackstack[PL_lex_brackets++] = XTERM; else @@ -5815,7 +5901,7 @@ Perl_yylex(pTHX) pl_yylval.ival = CopLINE(PL_curcop); if (isSPACE(*s) || *s == '#') PL_copline = NOLINE; /* invalidate current command line number */ - TOKEN('{'); + TOKEN(formbrack ? '=' : '{'); case '}': if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF) TOKEN(0); @@ -5826,8 +5912,6 @@ Perl_yylex(pTHX) else PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets]; PL_lex_allbrackets--; - if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL) - PL_lex_formbrack = 0; if (PL_lex_state == LEX_INTERPNORMAL) { if (PL_lex_brackets == 0) { if (PL_expect & XFAKEBRACK) { @@ -5859,11 +5943,17 @@ Perl_yylex(pTHX) curmad('X', newSVpvn(s-1,1)); CURMAD('_', PL_thiswhite); } - force_next('}'); + force_next(formbrack ? '.' : '}'); + if (formbrack) LEAVE; #ifdef PERL_MAD if (!PL_thistoken) PL_thistoken = newSVpvs(""); #endif + if (formbrack == 2) { /* means . where arguments were expected */ + start_force(PL_curforce); + force_next(';'); + TOKEN(FORMRBRACK); + } TOKEN(';'); case '&': s++; @@ -5949,7 +6039,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') { @@ -5980,7 +6071,7 @@ Perl_yylex(pTHX) goto retry; } } - if (PL_lex_brackets < PL_lex_formbrack) { + if (PL_expect == XBLOCK) { const char *t = s; #ifdef PERL_STRICT_CR while (SPACE_OR_TAB(*t)) @@ -5989,8 +6080,12 @@ Perl_yylex(pTHX) #endif t++; if (*t == '\n' || *t == '#') { - s--; - PL_expect = XBLOCK; + formbrack = 1; + ENTER; + SAVEI8(PL_parser->form_lex_state); + SAVEI32(PL_lex_formbrack); + PL_parser->form_lex_state = PL_lex_state; + PL_lex_formbrack = PL_lex_brackets + 1; goto leftbracket; } } @@ -6041,7 +6136,8 @@ Perl_yylex(pTHX) s = scan_heredoc(s); else s = scan_inputsymbol(s); - TERM(sublex_start()); + PL_expect = XOPERATOR; + TOKEN(sublex_start()); } s++; { @@ -6349,8 +6445,8 @@ Perl_yylex(pTHX) #endif && (s == PL_linestart || s[-1] == '\n') ) { - PL_lex_formbrack = 0; PL_expect = XSTATE; + formbrack = 2; /* dot seen where arguments expected */ goto rightbracket; } if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') { @@ -6391,7 +6487,7 @@ Perl_yylex(pTHX) TERM(THING); case '\'': - s = scan_str(s,!!PL_madskills,FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE); DEBUG_T( { printbuf("### Saw string before %s\n", s); } ); if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { @@ -6406,7 +6502,7 @@ Perl_yylex(pTHX) TERM(sublex_start()); case '"': - s = scan_str(s,!!PL_madskills,FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE); DEBUG_T( { printbuf("### Saw string before %s\n", s); } ); if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { @@ -6429,7 +6525,7 @@ Perl_yylex(pTHX) TERM(sublex_start()); case '`': - s = scan_str(s,!!PL_madskills,FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE); DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } ); if (PL_expect == XOPERATOR) no_op("Backticks",s); @@ -6881,7 +6977,7 @@ Perl_yylex(pTHX) op_free(rv2cv_op); SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv); ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv); - pl_yylval.opval->op_private = 0; + pl_yylval.opval->op_private = OPpCONST_FOLDED; pl_yylval.opval->op_flags |= OPf_SPECIAL; TOKEN(WORD); } @@ -7196,10 +7292,19 @@ Perl_yylex(pTHX) case KEY_CORE: if (*s == ':' && s[1] == ':') { - s += 2; + STRLEN olen = len; d = s; + s += 2; s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); - if (!(tmp = keyword(PL_tokenbuf, len, 1))) + if ((*s == ':' && s[1] == ':') + || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\'')) + { + s = d; + len = olen; + Copy(PL_bufptr, PL_tokenbuf, olen, char); + goto just_a_word; + } + if (!tmp) Perl_croak(aTHX_ "CORE::%"SVf" is not a keyword", SVfARG(newSVpvn_flags(PL_tokenbuf, len, (UTF ? SVf_UTF8 : 0) | SVs_TEMP))); @@ -7310,8 +7415,13 @@ Perl_yylex(pTHX) s = SKIPSPACE1(s); if (*s == '{') PRETERMBLOCK(DO); - if (*s != '\'') - s = force_word(s,WORD,TRUE,TRUE,FALSE); + if (*s != '\'') { + d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, 1, &len); + if (len) { + d = SKIPSPACE1(d); + if (*d == '(') s = force_word(s,WORD,TRUE,TRUE,FALSE); + } + } if (orig_keyword == KEY_do) { orig_keyword = 0; pl_yylval.ival = 1; @@ -7705,7 +7815,7 @@ Perl_yylex(pTHX) case KEY_no: s = tokenize_use(0, s); - OPERATOR(USE); + TERM(USE); case KEY_not: if (*s == '(' || (s = SKIPSPACE1(s), *s == '(')) @@ -7795,7 +7905,7 @@ Perl_yylex(pTHX) LOP(OP_PIPE_OP,XTERM); case KEY_q: - s = scan_str(s,!!PL_madskills,FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE); if (!s) missingterm(NULL); pl_yylval.ival = OP_CONST; @@ -7806,7 +7916,7 @@ Perl_yylex(pTHX) case KEY_qw: { OP *words = NULL; - s = scan_str(s,!!PL_madskills,FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE); if (!s) missingterm(NULL); PL_expect = XOPERATOR; @@ -7856,7 +7966,7 @@ Perl_yylex(pTHX) } case KEY_qq: - s = scan_str(s,!!PL_madskills,FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE); if (!s) missingterm(NULL); pl_yylval.ival = OP_STRINGIFY; @@ -7869,7 +7979,7 @@ Perl_yylex(pTHX) TERM(sublex_start()); case KEY_qx: - s = scan_str(s,!!PL_madskills,FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE); if (!s) missingterm(NULL); readpipe_override(); @@ -8152,8 +8262,6 @@ Perl_yylex(pTHX) } if (key == KEY_format) { - if (*s == '=') - PL_lex_formbrack = PL_lex_brackets + 1; #ifdef PERL_MAD PL_thistoken = subtoken; s = d; @@ -8162,7 +8270,7 @@ Perl_yylex(pTHX) (void) force_word(PL_oldbufptr + tboffset, WORD, FALSE, TRUE, TRUE); #endif - OPERATOR(FORMAT); + PREBLOCK(FORMAT); } /* Look for a prototype */ @@ -8178,7 +8286,7 @@ Perl_yylex(pTHX) const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO); STRLEN tmplen; - s = scan_str(s,!!PL_madskills,FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE); if (!s) Perl_croak(aTHX_ "Prototype not terminated"); /* strip spaces and check for bad characters */ @@ -8325,6 +8433,7 @@ Perl_yylex(pTHX) LOP(OP_SYSWRITE,XTERM); case KEY_tr: + case KEY_y: s = scan_trans(s); TERM(sublex_start()); @@ -8452,10 +8561,6 @@ Perl_yylex(pTHX) return REPORT(0); pl_yylval.ival = OP_XOR; OPERATOR(OROP); - - case KEY_y: - s = scan_trans(s); - TERM(sublex_start()); } }} } @@ -8467,7 +8572,6 @@ static int S_pending_ident(pTHX) { dVAR; - register char *d; PADOFFSET tmp = 0; /* pit holds the identifier we read and pending_ident is reset */ char pit = PL_pending_ident; @@ -8509,14 +8613,6 @@ S_pending_ident(pTHX) /* build the ops for accesses to a my() variable. - - Deny my($a) or my($b) in a sort block, *if* $a or $b is - then used in a comparison. This catches most, but not - all cases. For instance, it catches - sort { my($a); $a <=> $b } - but not - sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; } - (although why you'd do that is anyone's guess). */ if (!has_colon) { @@ -8545,23 +8641,6 @@ S_pending_ident(pTHX) return WORD; } - /* if it's a sort block and they're naming $a or $b */ - if (PL_last_lop_op == OP_SORT && - PL_tokenbuf[0] == '$' && - (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b') - && !PL_tokenbuf[2]) - { - for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart; - d < PL_bufend && *d != '\n'; - d++) - { - if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) { - Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison", - PL_tokenbuf); - } - } - } - pl_yylval.opval = newOP(OP_PADANY, 0); pl_yylval.opval->op_targ = tmp; return PRIVATEREF; @@ -8788,8 +8867,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; @@ -8833,8 +8912,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; @@ -9009,18 +9088,24 @@ S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charse /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in * the parse starting at 's', based on the subset that are valid in this * context input to this routine in 'valid_flags'. Advances s. Returns - * TRUE if the input was a valid flag, so the next char may be as well; - * otherwise FALSE. 'charset' should point to a NUL upon first call on the - * current regex. This routine will set it to any charset modifier found. - * The caller shouldn't change it. This way, another charset modifier - * encountered in the parse can be detected as an error, as we have decided - * allow only one */ + * TRUE if the input should be treated as a valid flag, so the next char + * may be as well; otherwise FALSE. 'charset' should point to a NUL upon + * first call on the current regex. This routine will set it to any + * charset modifier found. The caller shouldn't change it. This way, + * another charset modifier encountered in the parse can be detected as an + * error, as we have decided to allow only one */ const char c = **s; - - if (! strchr(valid_flags, c)) { - if (isALNUM(c)) { - goto deprecate; + STRLEN charlen = UTF ? UTF8SKIP(*s) : 1; + + if ( charlen != 1 || ! strchr(valid_flags, c) ) { + if (isALNUM_lazy_if(*s, UTF)) { + yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s), + UTF ? SVf_UTF8 : 0); + (*s) += charlen; + /* Pretend that it worked, so will continue processing before + * dieing */ + return TRUE; } return FALSE; } @@ -9034,34 +9119,6 @@ S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charse case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break; case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break; case LOCALE_PAT_MOD: - - /* In 5.14, qr//lt is legal but deprecated; the 't' means they - * can't be regex modifiers. - * In 5.14, s///le is legal and ambiguous. Try to disambiguate as - * much as easily done. s///lei, for example, has to mean regex - * modifiers if it's not an error (as does any word character - * following the 'e'). Otherwise, we resolve to the backwards- - * compatible, but less likely 's/// le ...', i.e. as meaning - * less-than-or-equal. The reason it's not likely is that s// - * returns a number for code in the field (/r returns a string, but - * that wasn't added until the 5.13 series), and so '<=' should be - * used for comparing, not 'le'. */ - if (*((*s) + 1) == 't') { - goto deprecate; - } - else if (*((*s) + 1) == 'e' && ! isALNUM(*((*s) + 2))) { - - /* 'e' is valid only for substitutes, s///e. If it is not - * valid in the current context, then 'm//le' must mean the - * comparison operator, so use the regular deprecation message. - */ - if (! strchr(valid_flags, 'e')) { - goto deprecate; - } - Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS), - "Ambiguous use of 's//le...' resolved as 's// le...'; Rewrite as 's//el' if you meant 'use locale rules and evaluate rhs as an expression'. In Perl 5.18, it will be resolved the other way"); - return FALSE; - } if (*charset) { goto multiple_charsets; } @@ -9069,11 +9126,6 @@ S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charse *charset = c; break; case UNICODE_PAT_MOD: - /* In 5.14, qr//unless and qr//until are legal but deprecated; the - * 'n' means they can't be regex modifiers */ - if (*((*s) + 1) == 'n') { - goto deprecate; - } if (*charset) { goto multiple_charsets; } @@ -9081,12 +9133,6 @@ S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charse *charset = c; break; case ASCII_RESTRICT_PAT_MOD: - /* In 5.14, qr//and is legal but deprecated; the 'n' means they - * can't be regex modifiers */ - if (*((*s) + 1) == 'n') { - goto deprecate; - } - if (! *charset) { set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET); } @@ -9116,11 +9162,6 @@ S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charse (*s)++; return TRUE; - deprecate: - Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), - "Having no space between pattern and following word is deprecated"); - return FALSE; - multiple_charsets: if (*charset != c) { yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c)); @@ -9142,7 +9183,7 @@ S_scan_pat(pTHX_ char *start, I32 type) { dVAR; PMOP *pm; - char *s = scan_str(start,!!PL_madskills,FALSE); + char *s = scan_str(start,!!PL_madskills,FALSE, PL_reg_state.re_reparsing); const char * const valid_flags = (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS); char charset = '\0'; /* character set modifier */ @@ -9152,6 +9193,9 @@ S_scan_pat(pTHX_ char *start, I32 type) PERL_ARGS_ASSERT_SCAN_PAT; + /* this was only needed for the initial scan_str; set it to false + * so that any (?{}) code blocks etc are parsed normally */ + PL_reg_state.re_reparsing = FALSE; if (!s) { const char * const delimiter = skipspace(start); Perl_croak(aTHX_ @@ -9187,6 +9231,25 @@ S_scan_pat(pTHX_ char *start, I32 type) #ifdef PERL_MAD modstart = s; #endif + + /* if qr/...(?{..}).../, then need to parse the pattern within a new + * anon CV. False positives like qr/[(?{]/ are harmless */ + + if (type == OP_QR) { + STRLEN len; + char *e, *p = SvPV(PL_lex_stuff, len); + e = p + len; + for (; p < e; p++) { + if (p[0] == '(' && p[1] == '?' + && (p[2] == '{' || (p[2] == '?' && p[3] == '{'))) + { + pm->op_pmflags |= PMf_HAS_CV; + break; + } + } + pm->op_pmflags |= PMf_IS_QR; + } + while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {}; #ifdef PERL_MAD if (PL_madskills && modstart != s) { @@ -9211,7 +9274,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 */ @@ -9223,7 +9286,7 @@ S_scan_subst(pTHX_ char *start) pl_yylval.ival = OP_NULL; - s = scan_str(start,!!PL_madskills,FALSE); + s = scan_str(start,!!PL_madskills,FALSE,FALSE); if (!s) Perl_croak(aTHX_ "Substitution pattern not terminated"); @@ -9241,7 +9304,7 @@ S_scan_subst(pTHX_ char *start) #endif first_start = PL_multi_start; - s = scan_str(s,!!PL_madskills,FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE); if (!s) { if (PL_lex_stuff) { SvREFCNT_dec(PL_lex_stuff); @@ -9288,8 +9351,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) { @@ -9299,13 +9360,13 @@ 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_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_lex_repl); - PL_lex_repl = repl; + SvREFCNT_dec(PL_sublex_info.repl); + PL_sublex_info.repl = repl; } PL_lex_op = (OP*)pm; @@ -9317,7 +9378,7 @@ STATIC char * S_scan_trans(pTHX_ char *start) { dVAR; - register char* s; + char* s; OP *o; U8 squash; U8 del; @@ -9331,7 +9392,7 @@ S_scan_trans(pTHX_ char *start) pl_yylval.ival = OP_NULL; - s = scan_str(start,!!PL_madskills,FALSE); + s = scan_str(start,!!PL_madskills,FALSE,FALSE); if (!s) Perl_croak(aTHX_ "Transliteration pattern not terminated"); @@ -9347,7 +9408,7 @@ S_scan_trans(pTHX_ char *start) } #endif - s = scan_str(s,!!PL_madskills,FALSE); + s = scan_str(s,!!PL_madskills,FALSE,FALSE); if (!s) { if (PL_lex_stuff) { SvREFCNT_dec(PL_lex_stuff); @@ -9390,7 +9451,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; @@ -9407,6 +9468,36 @@ 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; @@ -9432,10 +9523,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++; @@ -9443,12 +9533,14 @@ S_scan_heredoc(pTHX_ register char *s) s = peek; term = *s++; s = delimcpy(d, e, s, PL_bufend, term, &len); + if (s == PL_bufend) + Perl_croak(aTHX_ "Unterminated delimiter for here document"); d += len; - if (s < PL_bufend) - s++; + s++; } else { if (*s == '\\') + /* <<\FOO is equivalent to <<'FOO' */ s++, term = '\''; else term = '"'; @@ -9467,8 +9559,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); @@ -9498,10 +9590,8 @@ S_scan_heredoc(pTHX_ register char *s) s = olds; } #endif -#ifdef PERL_MAD - found_newline = 0; -#endif - if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) { + if ((infile && !PL_lex_inwhat) + || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s))) { herewas = newSVpvn(s,PL_bufend-s); } else { @@ -9541,47 +9631,94 @@ 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; + 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. + */ + SV *linestr; + char *bufptr, *bufend; char * const olds = s - SvCUR(herewas); - s = strchr(bufptr, '\n'); - if (!s) - s = bufend; + char * const real_olds = s; + PERL_CONTEXT * const cx = &cxstack[cxstack_ix]; + do { + 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 = real_olds; + goto streaming; + } + } while (!(s = (char *)memchr( + (void *)shared->ls_bufptr, '\n', + SvEND(shared->ls_linestr)-shared->ls_bufptr + ))); + bufptr = shared->ls_bufptr; + 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); + SvREFCNT_dec(herewas); + SvREFCNT_dec(tmpstr); + CopLINE_set(PL_curcop, (line_t)PL_multi_start-1); + missingterm(PL_tokenbuf + 1); } sv_setpvn(herewas,bufptr,d-bufptr+1); sv_setpvn(tmpstr,d+1,s-d); s += len - 1; + /* 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, + SvEND(linestr) - 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); + } 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 (!outer) { + 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 != term || memNE(s,PL_tokenbuf,len)) ) { + (*s != '\n' || memNE(s,PL_tokenbuf,len)) ) { if (*s++ == '\n') - CopLINE_inc(PL_curcop); + ++shared->herelines; } if (s >= PL_bufend) { - CopLINE_set(PL_curcop, (line_t)PL_multi_start); - missingterm(PL_tokenbuf); + SvREFCNT_dec(herewas); + SvREFCNT_dec(tmpstr); + CopLINE_set(PL_curcop, (line_t)PL_multi_start-1); + missingterm(PL_tokenbuf + 1); } sv_setpvn(tmpstr,d+1,s-d); #ifdef PERL_MAD @@ -9594,17 +9731,45 @@ 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); + /* s now points to the newline after the heredoc terminator. + d points to the newline before the body of the heredoc. + */ + /* 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, + PL_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); + 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); - PL_last_lop = PL_last_uni = NULL; + 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 - SvCUR(herewas) - 1; /* s gets set to this afterwards */ + PL_linestr = newSVpvs(""); + PL_bufptr = PL_bufend = s = SvPVX(PL_linestr); + while (s >= PL_bufend) { /* multiple line string? */ #ifdef PERL_MAD if (PL_madskills) { tstart = SvPVX(PL_linestr) + stuffstart; @@ -9615,17 +9780,26 @@ S_scan_heredoc(pTHX_ register char *s) } #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); + 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); + SvREFCNT_dec(linestr_save); + CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1); + missingterm(PL_tokenbuf + 1); + } + 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); + shared->herelines++; PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = NULL; #ifndef PERL_STRICT_CR @@ -9643,18 +9817,18 @@ 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; } else { s = PL_bufend; sv_catsv(tmpstr,PL_linestr); } + } } s++; retval: @@ -9694,7 +9868,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 */ @@ -9739,7 +9913,7 @@ S_scan_inputsymbol(pTHX_ char *start) if (d - PL_tokenbuf != len) { pl_yylval.ival = OP_GLOB; - s = scan_str(start,!!PL_madskills,FALSE); + s = scan_str(start,!!PL_madskills,FALSE,FALSE); if (!s) Perl_croak(aTHX_ "Glob not terminated"); return s; @@ -9839,6 +10013,8 @@ intro_sym: takes: start position in buffer keep_quoted preserve \ on the embedded delimiter(s) keep_delims preserve the delimiters around the string + re_reparse compiling a run-time /(?{})/: + collapse // to /, and skip encoding src returns: position to continue reading from buffer side-effects: multi_start, multi_close, lex_repl or lex_stuff, and updates the read buffer. @@ -9879,14 +10055,14 @@ intro_sym: */ STATIC char * -S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) +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 */ @@ -9958,7 +10134,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) } #endif for (;;) { - if (PL_encoding && !UTF) { + if (PL_encoding && !UTF && !re_reparse) { bool cont = TRUE; while (cont) { @@ -9970,7 +10146,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) 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; @@ -10037,12 +10213,15 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) 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 && s[1] == term) + if (!keep_quoted + && (s[1] == term + || (re_reparse && s[1] == '\\')) + ) s++; - /* any other quotes are simply copied straight through */ + /* any other quotes are simply copied straight through */ else *to++ = *s++; } @@ -10069,7 +10248,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) 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 && @@ -10128,7 +10307,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) 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); @@ -10143,7 +10322,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* at this point, we have successfully read the delimited string */ - if (!PL_encoding || UTF) { + if (!PL_encoding || UTF || re_reparse) { #ifdef PERL_MAD if (PL_madskills) { char * const tstart = SvPVX(PL_linestr) + stuffstart; @@ -10175,7 +10354,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) } } #endif - if (has_utf8 || PL_encoding) + if (has_utf8 || (PL_encoding && !re_reparse)) SvUTF8_on(sv); PL_multi_end = CopLINE(PL_curcop); @@ -10191,7 +10370,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) */ if (PL_lex_stuff) - PL_lex_repl = sv; + PL_sublex_info.repl = sv; else PL_lex_stuff = sv; return s; @@ -10223,9 +10402,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? */ @@ -10596,8 +10775,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; @@ -10628,13 +10807,9 @@ S_scan_formline(pTHX_ register char *s) break; } } - if (PL_in_eval && !PL_rsfp && !PL_parser->filtered) { - eol = (char *) memchr(s,'\n',PL_bufend-s); - if (!eol++) + eol = (char *) memchr(s,'\n',PL_bufend-s); + if (!eol++) eol = PL_bufend; - } - else - eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); if (*s != '#') { for (t = s; t < eol; t++) { if (*t == '~' && t[1] == '~' && SvCUR(stuff)) { @@ -10659,7 +10834,8 @@ S_scan_formline(pTHX_ register char *s) break; } s = (char*)eol; - if (PL_rsfp || PL_parser->filtered) { + if ((PL_rsfp || PL_parser->filtered) + && PL_parser->form_lex_state == LEX_NORMAL) { bool got_some; #ifdef PERL_MAD if (PL_madskills) { @@ -10670,7 +10846,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; @@ -10683,16 +10859,15 @@ S_scan_formline(pTHX_ register char *s) incline(s); } enough: + if (!SvCUR(stuff) || needargs) + PL_lex_state = PL_parser->form_lex_state; if (SvCUR(stuff)) { - PL_expect = XTERM; + PL_expect = XSTATE; if (needargs) { - PL_lex_state = LEX_NORMAL; start_force(PL_curforce); NEXTVAL_NEXTTOKE.ival = 0; - force_next(','); + force_next(FORMLBRACK); } - else - PL_lex_state = LEX_FORMLINE; if (!IN_BYTES) { if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff))) SvUTF8_on(stuff); @@ -10702,15 +10877,11 @@ S_scan_formline(pTHX_ register char *s) start_force(PL_curforce); NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff); force_next(THING); - start_force(PL_curforce); - NEXTVAL_NEXTTOKE.ival = OP_FORMLINE; - force_next(LSTOP); } else { SvREFCNT_dec(stuff); if (eofmt) PL_lex_formbrack = 0; - PL_bufptr = s; } #ifdef PERL_MAD if (PL_madskills) { @@ -10731,9 +10902,6 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) const I32 oldsavestack_ix = PL_savestack_ix; CV* const outsidecv = PL_compcv; - if (PL_compcv) { - assert(SvTYPE(PL_compcv) == SVt_PVCV); - } SAVEI32(PL_subline); save_item(PL_subname); SAVESPTR(PL_compcv); @@ -10745,6 +10913,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; } @@ -11629,29 +11799,12 @@ Perl_parse_stmtseq(pTHX_ U32 flags) return stmtseqop; } -void -Perl_munge_qwlist_to_paren_list(pTHX_ OP *qwlist) -{ - PERL_ARGS_ASSERT_MUNGE_QWLIST_TO_PAREN_LIST; - deprecate("qw(...) as parentheses"); - force_next((4<<24)|')'); - if (qwlist->op_type == OP_STUB) { - op_free(qwlist); - } - else { - start_force(PL_curforce); - NEXTVAL_NEXTTOKE.opval = qwlist; - force_next(THING); - } - force_next((2<<24)|'('); -} - /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 - * indent-tabs-mode: t + * indent-tabs-mode: nil * End: * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */