X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8c28b960db3547273cd8c89c0eaafc8e99cf70c1..9f602dc7dfc0f7dafbd8260471ed60a61faddc5e:/toke.c diff --git a/toke.c b/toke.c index 4158e32..9726a31 100644 --- a/toke.c +++ b/toke.c @@ -1,7 +1,7 @@ /* toke.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -23,8 +23,69 @@ #define PERL_IN_TOKE_C #include "perl.h" -#define yychar (*PL_yycharp) -#define yylval (*PL_yylvalp) +#define yylval (PL_parser->yylval) + +/* YYINITDEPTH -- initial size of the parser's stacks. */ +#define YYINITDEPTH 200 + +/* XXX temporary backwards compatibility */ +#define PL_lex_brackets (PL_parser->lex_brackets) +#define PL_lex_brackstack (PL_parser->lex_brackstack) +#define PL_lex_casemods (PL_parser->lex_casemods) +#define PL_lex_casestack (PL_parser->lex_casestack) +#define PL_lex_defer (PL_parser->lex_defer) +#define PL_lex_dojoin (PL_parser->lex_dojoin) +#define PL_lex_expect (PL_parser->lex_expect) +#define PL_lex_formbrack (PL_parser->lex_formbrack) +#define PL_lex_inpat (PL_parser->lex_inpat) +#define PL_lex_inwhat (PL_parser->lex_inwhat) +#define PL_lex_op (PL_parser->lex_op) +#define PL_lex_repl (PL_parser->lex_repl) +#define PL_lex_starts (PL_parser->lex_starts) +#define PL_lex_stuff (PL_parser->lex_stuff) +#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) +#define PL_expect (PL_parser->expect) +#define PL_copline (PL_parser->copline) +#define PL_bufptr (PL_parser->bufptr) +#define PL_oldbufptr (PL_parser->oldbufptr) +#define PL_oldoldbufptr (PL_parser->oldoldbufptr) +#define PL_linestart (PL_parser->linestart) +#define PL_bufend (PL_parser->bufend) +#define PL_last_uni (PL_parser->last_uni) +#define PL_last_lop (PL_parser->last_lop) +#define PL_last_lop_op (PL_parser->last_lop_op) +#define PL_lex_state (PL_parser->lex_state) + +#ifdef PERL_MAD +# define PL_endwhite (PL_parser->endwhite) +# define PL_faketokens (PL_parser->faketokens) +# define PL_lasttoke (PL_parser->lasttoke) +# define PL_nextwhite (PL_parser->nextwhite) +# define PL_realtokenstart (PL_parser->realtokenstart) +# define PL_skipwhite (PL_parser->skipwhite) +# define PL_thisclose (PL_parser->thisclose) +# define PL_thismad (PL_parser->thismad) +# define PL_thisopen (PL_parser->thisopen) +# define PL_thisstuff (PL_parser->thisstuff) +# define PL_thistoken (PL_parser->thistoken) +# define PL_thiswhite (PL_parser->thiswhite) +# define PL_thiswhite (PL_parser->thiswhite) +# define PL_nexttoke (PL_parser->nexttoke) +# define PL_curforce (PL_parser->curforce) +#else +# define PL_nexttoke (PL_parser->nexttoke) +# define PL_nexttype (PL_parser->nexttype) +# define PL_nextval (PL_parser->nextval) +#endif + +static int +S_pending_ident(pTHX); static const char ident_too_long[] = "Identifier too long"; static const char commaless_variable_list[] = "comma-less variable list"; @@ -569,114 +630,97 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) } #endif + + /* * Perl_lex_start - * Initialize variables. Uses the Perl save_stack to save its state (for - * recursive calls to the parser). + * Create a parser object and initialise its parser and lexer fields */ void Perl_lex_start(pTHX_ SV *line) { dVAR; - const char *s; + const char *s = NULL; STRLEN len; + yy_parser *parser; + + /* create and initialise a parser */ + + Newxz(parser, 1, yy_parser); + parser->old_parser = PL_parser; + PL_parser = parser; + + Newx(parser->stack, YYINITDEPTH, yy_stack_frame); + parser->ps = parser->stack; + parser->stack_size = YYINITDEPTH; + + parser->stack->state = 0; + parser->yyerrstatus = 0; + parser->yychar = YYEMPTY; /* Cause a token to be read. */ + + /* on scope exit, free this parser and restore any outer one */ + SAVEPARSER(parser); + + /* initialise lexer state */ - SAVEI32(PL_lex_dojoin); - SAVEI32(PL_lex_brackets); - SAVEI32(PL_lex_casemods); - SAVEI32(PL_lex_starts); - SAVEI32(PL_lex_state); - SAVEVPTR(PL_lex_inpat); - SAVEI32(PL_lex_inwhat); -#ifdef PERL_MAD - if (PL_lex_state == LEX_KNOWNEXT) { - I32 toke = PL_lasttoke; - while (--toke >= 0) { - SAVEI32(PL_nexttoke[toke].next_type); - SAVEVPTR(PL_nexttoke[toke].next_val); - if (PL_madskills) - SAVEVPTR(PL_nexttoke[toke].next_mad); - } - SAVEI32(PL_lasttoke); - } - if (PL_madskills) { - SAVESPTR(PL_thistoken); - SAVESPTR(PL_thiswhite); - SAVESPTR(PL_nextwhite); - SAVESPTR(PL_thisopen); - SAVESPTR(PL_thisclose); - SAVESPTR(PL_thisstuff); - SAVEVPTR(PL_thismad); - SAVEI32(PL_realtokenstart); - SAVEI32(PL_faketokens); - } - SAVEI32(PL_curforce); -#else - if (PL_lex_state == LEX_KNOWNEXT) { - I32 toke = PL_nexttoke; - while (--toke >= 0) { - SAVEI32(PL_nexttype[toke]); - SAVEVPTR(PL_nextval[toke]); - } - SAVEI32(PL_nexttoke); - } -#endif SAVECOPLINE(PL_curcop); - SAVEPPTR(PL_bufptr); - SAVEPPTR(PL_bufend); - SAVEPPTR(PL_oldbufptr); - SAVEPPTR(PL_oldoldbufptr); - SAVEPPTR(PL_last_lop); - SAVEPPTR(PL_last_uni); - SAVEPPTR(PL_linestart); - SAVESPTR(PL_linestr); - SAVEGENERICPV(PL_lex_brackstack); - SAVEGENERICPV(PL_lex_casestack); SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp); - SAVESPTR(PL_lex_stuff); - SAVEI32(PL_lex_defer); - SAVEI32(PL_sublex_info.sub_inwhat); - SAVESPTR(PL_lex_repl); - SAVEINT(PL_expect); - SAVEINT(PL_lex_expect); - PL_lex_state = LEX_NORMAL; - PL_lex_defer = 0; - PL_expect = XSTATE; - PL_lex_brackets = 0; - Newx(PL_lex_brackstack, 120, char); - Newx(PL_lex_casestack, 12, char); - PL_lex_casemods = 0; - *PL_lex_casestack = '\0'; - PL_lex_dojoin = 0; - PL_lex_starts = 0; - PL_lex_stuff = NULL; - PL_lex_repl = NULL; - PL_lex_inpat = 0; #ifdef PERL_MAD - PL_lasttoke = 0; + parser->curforce = -1; #else - PL_nexttoke = 0; -#endif - PL_lex_inwhat = 0; - PL_sublex_info.sub_inwhat = 0; - PL_linestr = line; - if (SvREADONLY(PL_linestr)) - PL_linestr = sv_2mortal(newSVsv(PL_linestr)); - s = SvPV_const(PL_linestr, len); - if (!len || s[len-1] != ';') { - if (!(SvFLAGS(PL_linestr) & SVs_TEMP)) - PL_linestr = sv_2mortal(newSVsv(PL_linestr)); - sv_catpvs(PL_linestr, "\n;"); - } - SvTEMP_off(PL_linestr); - PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); - PL_bufend = PL_bufptr + SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = NULL; + parser->nexttoke = 0; +#endif + parser->copline = NOLINE; + PL_lex_state = LEX_NORMAL; + parser->expect = XSTATE; + Newx(parser->lex_brackstack, 120, char); + Newx(parser->lex_casestack, 12, char); + *parser->lex_casestack = '\0'; + + if (line) { + s = SvPV_const(line, len); + } else { + len = 0; + } + + if (!len) { + parser->linestr = newSVpvs("\n;"); + } else if (SvREADONLY(line) || s[len-1] != ';') { + parser->linestr = newSVsv(line); + if (s[len-1] != ';') + sv_catpvs(parser->linestr, "\n;"); + } else { + SvTEMP_off(line); + SvREFCNT_inc_simple_void_NN(line); + parser->linestr = line; + } + parser->oldoldbufptr = + parser->oldbufptr = + parser->bufptr = + parser->linestart = SvPVX(parser->linestr); + parser->bufend = parser->bufptr + SvCUR(parser->linestr); + parser->last_lop = parser->last_uni = NULL; PL_rsfp = 0; } + +/* delete a parser object */ + +void +Perl_parser_free(pTHX_ const yy_parser *parser) +{ + SvREFCNT_dec(parser->linestr); + + Safefree(parser->stack); + Safefree(parser->lex_brackstack); + Safefree(parser->lex_casestack); + PL_parser = parser->old_parser; + Safefree(parser); +} + + /* * Perl_lex_end * Finalizer for lexing operations. Must be called when the parser is @@ -701,13 +745,12 @@ Perl_lex_end(pTHX) */ STATIC void -S_incline(pTHX_ char *s) +S_incline(pTHX_ const char *s) { dVAR; - char *t; - char *n; - char *e; - char ch; + const char *t; + const char *n; + const char *e; CopLINE_inc(PL_curcop); if (*s++ != '#') @@ -747,50 +790,65 @@ S_incline(pTHX_ char *s) if (*e != '\n' && *e != '\0') return; /* false alarm */ - ch = *t; - *t = '\0'; if (t - s > 0) { + const STRLEN len = t - s; #ifndef USE_ITHREADS const char * const cf = CopFILE(PL_curcop); STRLEN tmplen = cf ? strlen(cf) : 0; if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) { /* must copy *{"::_<(eval N)[oldfilename:L]"} * to *{"::_ and it knows that the next char is a word char, then - * it calls S_force_word to stick the next word into the PL_next lookahead. + * it calls S_force_word to stick the next word into the PL_nexttoke/val + * lookahead. * * Arguments: * char *start : buffer position (must be within PL_linestr) - * int token : PL_next will be this type of bare word (e.g., METHOD,WORD) + * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD) * int check_keyword : if true, Perl checks to make sure the word isn't * a keyword (do this if the word is a label, e.g. goto FOO) * int allow_pack : if true, : characters will also be allowed (require, @@ -1288,6 +1356,8 @@ S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow PL_expect = XOPERATOR; } } + if (PL_madskills) + curmad('g', newSVpvs( "forced" )); NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST,0, S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len)); @@ -1541,9 +1611,17 @@ S_sublex_start(pTHX) PL_expect = XTERMORDORDOR; return THING; } + else if (op_type == OP_BACKTICK && PL_lex_op) { + /* readpipe() vas overriden */ + cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff); + yylval.opval = PL_lex_op; + PL_lex_op = NULL; + PL_lex_stuff = NULL; + return THING; + } PL_sublex_info.super_state = PL_lex_state; - PL_sublex_info.sub_inwhat = op_type; + PL_sublex_info.sub_inwhat = (U16)op_type; PL_sublex_info.sub_op = PL_lex_op; PL_lex_state = LEX_INTERPPUSH; @@ -1572,13 +1650,13 @@ S_sublex_push(pTHX) ENTER; PL_lex_state = PL_sublex_info.super_state; - SAVEI32(PL_lex_dojoin); + SAVEBOOL(PL_lex_dojoin); SAVEI32(PL_lex_brackets); SAVEI32(PL_lex_casemods); SAVEI32(PL_lex_starts); - SAVEI32(PL_lex_state); + SAVEI8(PL_lex_state); SAVEVPTR(PL_lex_inpat); - SAVEI32(PL_lex_inwhat); + SAVEI16(PL_lex_inwhat); SAVECOPLINE(PL_curcop); SAVEPPTR(PL_bufptr); SAVEPPTR(PL_bufend); @@ -1957,7 +2035,7 @@ S_scan_const(pTHX_ char *start) *d++ = NATIVE_TO_NEED(has_utf8,*s++); } else if (s[2] == '{' /* This should match regcomp.c */ - || ((s[2] == 'p' || s[2] == '?') && s[3] == '{')) + || (s[2] == '?' && s[3] == '{')) { I32 count = 1; char *regparse = s + (s[2] == '{' ? 3 : 4); @@ -2579,7 +2657,8 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) */ if (*start == '$') { - if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf)) + if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY || + isUPPER(*PL_tokenbuf)) return 0; #ifdef PERL_MAD len = start - SvPVX(PL_linestr); @@ -2605,7 +2684,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, FALSE)) { + if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) { #ifdef PERL_MAD soff = s - SvPVX(PL_linestr); #endif @@ -2837,7 +2916,35 @@ S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) pkgname = SvPV_nolen_const(sv); } - return gv_stashpv(pkgname, FALSE); + return gv_stashpv(pkgname, 0); +} + +/* + * S_readpipe_override + * Check whether readpipe() is overriden, and generates the appropriate + * optree, provided sublex_start() is called afterwards. + */ +STATIC void +S_readpipe_override(pTHX) +{ + GV **gvp; + GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV); + yylval.ival = OP_BACKTICK; + if ((gv_readpipe + && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)) + || + ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE)) + && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe) + && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))) + { + PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, + newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */ + newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe)))); + } + else { + set_csh(); + } } #ifdef PERL_MAD @@ -3510,15 +3617,8 @@ Perl_yylex(pTHX) PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = NULL; - if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV * const sv = newSV(0); - - sv_upgrade(sv, SVt_PVMG); - sv_setsv(sv,PL_linestr); - (void)SvIOK_on(sv); - SvIV_set(sv, 0); - av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv); - } + if (PERLDB_LINE && PL_curstash != PL_debstash) + update_debugger_info(PL_linestr, NULL, 0); goto retry; } do { @@ -3599,7 +3699,7 @@ Perl_yylex(pTHX) if (PL_madskills) sv_catsv(PL_thiswhite, PL_linestr); #endif - if (*s == '=' && strnEQ(s, "=cut", 4)) { + if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) { sv_setpvn(PL_linestr, "", 0); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); @@ -3610,15 +3710,8 @@ Perl_yylex(pTHX) incline(s); } while (PL_doextract); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; - if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV * const sv = newSV(0); - - sv_upgrade(sv, SVt_PVMG); - sv_setsv(sv,PL_linestr); - (void)SvIOK_on(sv); - SvIV_set(sv, 0); - av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv); - } + if (PERLDB_LINE && PL_curstash != PL_debstash) + update_debugger_info(PL_linestr, NULL, 0); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = NULL; if (CopLINE(PL_curcop) == 1) { @@ -3825,10 +3918,11 @@ Perl_yylex(pTHX) #endif #ifdef PERL_MAD PL_realtokenstart = -1; - s = SKIPSPACE0(s); -#else - s++; + if (!PL_thiswhite) + PL_thiswhite = newSVpvs(""); + sv_catpvn(PL_thiswhite, s, 1); #endif + s++; goto retry; case '#': case '\n': @@ -4051,7 +4145,8 @@ Perl_yylex(pTHX) Mop(OP_MODULO); } PL_tokenbuf[0] = '%'; - s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE); + s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, + sizeof PL_tokenbuf - 1, FALSE); if (!PL_tokenbuf[1]) { PREREF('%'); } @@ -4066,8 +4161,7 @@ Perl_yylex(pTHX) /* FALL THROUGH */ case '~': if (s[1] == '~' - && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) - && FEATURE_IS_ENABLED("~~")) + && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)) { s += 2; Eop(OP_SMARTMATCH); @@ -4727,12 +4821,12 @@ Perl_yylex(pTHX) t++; } while (isSPACE(*t)); if (isIDFIRST_lazy_if(t,UTF)) { - STRLEN dummylen; + STRLEN len; t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, - &dummylen); + &len); while (isSPACE(*t)) t++; - if (*t == ';' && get_cv(tmpbuf, FALSE)) + if (*t == ';' && get_cvn_flags(tmpbuf, len, 0)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "You need to quote \"%s\"", tmpbuf); @@ -4951,8 +5045,7 @@ Perl_yylex(pTHX) no_op("Backticks",s); if (!s) missingterm(NULL); - yylval.ival = OP_BACKTICK; - set_csh(); + readpipe_override(); TERM(sublex_start()); case '\\': @@ -5053,7 +5146,7 @@ Perl_yylex(pTHX) if (!tmp && PL_expect == XSTATE && d < PL_bufend && *d == ':' && *(d + 1) != ':') { s = d + 1; - yylval.pval = savepv(PL_tokenbuf); + yylval.pval = CopLABEL_alloc(PL_tokenbuf); CLINE; TOKEN(LABEL); } @@ -5086,7 +5179,7 @@ Perl_yylex(pTHX) } if (!ogv && (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) && - (gv = *gvp) != (GV*)&PL_sv_undef && + (gv = *gvp) && isGV_with_GP(gv) && GvCVu(gv) && GvIMPORTED_CV(gv)) { ogv = gv; @@ -5098,8 +5191,7 @@ Perl_yylex(pTHX) } else if (gv && !gvp && -tmp==KEY_lock /* XXX generalizable kludge */ - && GvCVu(gv) - && !hv_fetchs(GvHVn(PL_incgv), "Thread.pm", FALSE)) + && GvCVu(gv)) { tmp = 0; /* any sub overrides "weak" keyword */ } @@ -5322,8 +5414,9 @@ Perl_yylex(pTHX) PL_nextwhite = 0; } } + else #endif - goto its_constant; + goto its_constant; } } #ifdef PERL_MAD @@ -5370,7 +5463,7 @@ Perl_yylex(pTHX) "Ambiguous use of -%s resolved as -&%s()", PL_tokenbuf, PL_tokenbuf); /* Check for a constant sub */ - if ((sv = gv_const_sv(gv))) { + if ((sv = gv_const_sv(gv)) && !PL_madskills) { its_constant: SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv); ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv); @@ -5454,7 +5547,7 @@ Perl_yylex(pTHX) } } if (probable_sub) { - gv = gv_fetchpv(PL_tokenbuf, TRUE, SVt_PVCV); + gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV); op_free(yylval.opval); yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); yylval.opval->op_private |= OPpENTERSUB_NOPAREN; @@ -5490,7 +5583,7 @@ Perl_yylex(pTHX) d = PL_tokenbuf; while (isLOWER(*d)) d++; - if (!*d && !gv_stashpv(PL_tokenbuf,FALSE)) + if (!*d && !gv_stashpv(PL_tokenbuf, 0)) Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved, PL_tokenbuf); } @@ -5601,7 +5694,7 @@ Perl_yylex(pTHX) PUTBACK; PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, Perl_form(aTHX_ ":encoding(%"SVf")", - (void*)name)); + SVfARG(name))); FREETMPS; LEAVE; } @@ -5630,6 +5723,7 @@ Perl_yylex(pTHX) case KEY_AUTOLOAD: case KEY_DESTROY: case KEY_BEGIN: + case KEY_UNITCHECK: case KEY_CHECK: case KEY_INIT: case KEY_END: @@ -6082,7 +6176,7 @@ Perl_yylex(pTHX) case KEY_our: case KEY_my: case KEY_state: - PL_in_my = tmp; + PL_in_my = (U16)tmp; s = SKIPSPACE1(s); if (isIDFIRST_lazy_if(s,UTF)) { #ifdef PERL_MAD @@ -6270,8 +6364,7 @@ Perl_yylex(pTHX) s = scan_str(s,!!PL_madskills,FALSE); if (!s) missingterm(NULL); - yylval.ival = OP_BACKTICK; - set_csh(); + readpipe_override(); TERM(sublex_start()); case KEY_return: @@ -6288,7 +6381,7 @@ Perl_yylex(pTHX) *PL_tokenbuf = '\0'; s = force_word(s,WORD,TRUE,TRUE,FALSE); if (isIDFIRST_lazy_if(PL_tokenbuf,UTF)) - gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE); + gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD); else if (*s == '<') yyerror("<> should be quotes"); } @@ -6336,7 +6429,7 @@ Perl_yylex(pTHX) case KEY_readpipe: set_csh(); - UNI(OP_BACKTICK); + UNIDOR(OP_BACKTICK); case KEY_rewinddir: UNI(OP_REWINDDIR); @@ -6520,8 +6613,8 @@ Perl_yylex(pTHX) if (PL_madskills) nametoke = newSVpvn(s, d - s); #endif - if (strchr(tmpbuf, ':')) - sv_setpv(PL_subname, tmpbuf); + if (memchr(tmpbuf, ':', len)) + sv_setpvn(PL_subname, tmpbuf, len); else { sv_setsv(PL_subname,PL_curstname); sv_catpvs(PL_subname,"::"); @@ -6588,7 +6681,7 @@ Perl_yylex(pTHX) if (bad_proto) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Illegal character in prototype for %"SVf" : %s", - (void*)PL_subname, d); + SVfARG(PL_subname), d); SvCUR_set(PL_lex_stuff, tmp); have_proto = TRUE; @@ -6617,7 +6710,7 @@ Perl_yylex(pTHX) if (!have_name) Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine"); else if (*s != ';') - Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, (void*)PL_subname); + Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname)); } #ifdef PERL_MAD @@ -6907,7 +7000,11 @@ S_pending_ident(pTHX) if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) { GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV); if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) - && ckWARN(WARN_AMBIGUOUS)) + && ckWARN(WARN_AMBIGUOUS) + /* DO NOT warn for @- and @+ */ + && !( PL_tokenbuf[2] == '\0' && + ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' )) + ) { /* Downgraded from fatal to warning 20000522 mjd */ Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), @@ -7358,7 +7455,7 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords) case 'a': if (name[2] == 'y') { /* say */ - return (all_keywords || FEATURE_IS_ENABLED("say") ? -KEY_say : 0); + return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0); } goto unknown; @@ -9683,9 +9780,24 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords) goto unknown; } - case 9: /* 8 tokens of length 9 */ + case 9: /* 9 tokens of length 9 */ switch (name[0]) { + case 'U': + if (name[1] == 'N' && + name[2] == 'I' && + name[3] == 'T' && + name[4] == 'C' && + name[5] == 'H' && + name[6] == 'E' && + name[7] == 'C' && + name[8] == 'K') + { /* UNITCHECK */ + return KEY_UNITCHECK; + } + + goto unknown; + case 'e': if (name[1] == 'n' && name[2] == 'd' && @@ -10343,7 +10455,11 @@ S_checkcomma(pTHX_ const char *s, const char *name, const char *what) } while (isSPACE(*w)) ++w; - if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */ + /* the list of chars below is for end of statements or + * block / parens, boolean operators (&&, ||, //) and branch + * constructs (or, and, if, until, unless, while, err, for). + * Not a very solid hack... */ + if (!*w || !strchr(";&/|})]oaiuwef!=", *w)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (...) interpreted as function",name); } @@ -10656,7 +10772,8 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL } if (PL_lex_state == LEX_NORMAL) { if (ckWARN(WARN_AMBIGUOUS) && - (keyword(dest, d - dest, 0) || get_cv(dest, FALSE))) + (keyword(dest, d - dest, 0) + || get_cvn_flags(dest, d - dest, 0))) { if (funny == '#') funny = '@'; @@ -10680,20 +10797,16 @@ void Perl_pmflag(pTHX_ U32* pmfl, int ch) { PERL_UNUSED_CONTEXT; - if (ch == 'i') - *pmfl |= PMf_FOLD; - else if (ch == 'g') - *pmfl |= PMf_GLOBAL; - else if (ch == 'c') - *pmfl |= PMf_CONTINUE; - else if (ch == 'o') - *pmfl |= PMf_KEEP; - else if (ch == 'm') - *pmfl |= PMf_MULTILINE; - else if (ch == 's') - *pmfl |= PMf_SINGLELINE; - else if (ch == 'x') - *pmfl |= PMf_EXTENDED; + if (ch<256) { + char c = (char)ch; + switch (c) { + CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl); + case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break; + case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break; + case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break; + case KEEPCOPY_PAT_MOD: *pmfl |= PMf_KEEPCOPY; break; + } + } } STATIC char * @@ -10703,7 +10816,7 @@ S_scan_pat(pTHX_ char *start, I32 type) PMOP *pm; char *s = scan_str(start,!!PL_madskills,FALSE); const char * const valid_flags = - (const char *)((type == OP_QR) ? "iomsx" : "iogcmsx"); + (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS); #ifdef PERL_MAD char *modstart; #endif @@ -10719,8 +10832,28 @@ S_scan_pat(pTHX_ char *start, I32 type) } pm = (PMOP*)newPMOP(type, 0); - if (PL_multi_open == '?') + if (PL_multi_open == '?') { + /* This is the only point in the code that sets PMf_ONCE: */ pm->op_pmflags |= PMf_ONCE; + + /* Hence it's safe to do this bit of PMOP book-keeping here, which + allows us to restrict the list needed by reset to just the ?? + matches. */ + assert(type != OP_TRANS); + if (PL_curstash) { + MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab); + U32 elements; + if (!mg) { + mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, + 0); + } + elements = mg->mg_len / sizeof(PMOP**); + Renewc(mg->mg_ptr, elements + 1, PMOP*, char); + ((PMOP**)mg->mg_ptr) [elements++] = pm; + mg->mg_len = elements * sizeof(PMOP**); + PmopSTASH_set(pm,PL_curstash); + } + } #ifdef PERL_MAD modstart = s; #endif @@ -10736,11 +10869,10 @@ S_scan_pat(pTHX_ char *start, I32 type) if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL) && ckWARN(WARN_REGEXP)) { - Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" ); + Perl_warner(aTHX_ packWARN(WARN_REGEXP), + "Use of /c modifier is meaningless without /g" ); } - pm->op_pmpermflags = pm->op_pmflags; - PL_lex_op = (OP*)pm; yylval.ival = OP_MATCH; return s; @@ -10800,11 +10932,11 @@ S_scan_subst(pTHX_ char *start) #endif while (*s) { - if (*s == 'e') { + if (*s == EXEC_PAT_MOD) { s++; es++; } - else if (strchr("iogcmsx", *s)) + else if (strchr(S_PAT_MODS, *s)) pmflag(&pm->op_pmflags,*s++); else break; @@ -10841,7 +10973,6 @@ S_scan_subst(pTHX_ char *start) PL_lex_repl = repl; } - pm->op_pmpermflags = pm->op_pmflags; PL_lex_op = (OP*)pm; yylval.ival = OP_SUBST; return s; @@ -10915,7 +11046,7 @@ S_scan_trans(pTHX_ char *start) } no_more: - Newx(tbl, complement&&!del?258:256, short); + tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short)); o = newPVOP(OP_TRANS, 0, (char*)tbl); o->op_private &= ~OPpTRANS_ALL; o->op_private |= del|squash|complement| @@ -11057,8 +11188,8 @@ S_scan_heredoc(pTHX_ register char *s) s--; #endif - tmpstr = newSV(79); - sv_upgrade(tmpstr, SVt_PVIV); + tmpstr = newSV_type(SVt_PVIV); + SvGROW(tmpstr, 80); if (term == '\'') { op_type = OP_CONST; SvIV_set(tmpstr, -1); @@ -11166,15 +11297,8 @@ S_scan_heredoc(pTHX_ register char *s) else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r') PL_bufend[-1] = '\n'; #endif - if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV * const sv = newSV(0); - - sv_upgrade(sv, SVt_PVMG); - sv_setsv(sv,PL_linestr); - (void)SvIOK_on(sv); - SvIV_set(sv, 0); - av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop),sv); - } + if (PERLDB_LINE && PL_curstash != PL_debstash) + update_debugger_info(PL_linestr, NULL, 0); if (*s == term && memEQ(s,PL_tokenbuf,len)) { STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr); *(SvPVX(PL_linestr) + off ) = ' '; @@ -11292,7 +11416,7 @@ S_scan_inputsymbol(pTHX_ char *start) && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)) || ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE)) - && (gv_readline = *gvp) != (GV*)&PL_sv_undef + && (gv_readline = *gvp) && isGV_with_GP(gv_readline) && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))) readline_overriden = TRUE; @@ -11423,7 +11547,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) I32 termcode; /* terminating char. code */ U8 termstr[UTF8_MAXBYTES]; /* terminating string */ STRLEN termlen; /* length of terminating string */ - char *last = NULL; /* last position for nesting bracket */ + int last_off = 0; /* last position for nesting bracket */ #ifdef PERL_MAD int stuffstart; char *tstart; @@ -11470,8 +11594,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* create a new SV to hold the contents. 79 is the SV's initial length. What a random number. */ - sv = newSV(79); - sv_upgrade(sv, SVt_PVIV); + sv = newSV_type(SVt_PVIV); + SvGROW(sv, 80); SvIV_set(sv, termcode); (void)SvPOK_only(sv); /* validate pointer */ @@ -11524,9 +11648,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) else { const char *t; char *w; - if (!last) - last = SvPVX(sv); - for (t = w = last; t < svlast; w++, t++) { + for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) { /* At here, all closes are "was quoted" one, so we don't check PL_multi_close. */ if (*t == '\\') { @@ -11545,7 +11667,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) *w = '\0'; SvCUR_set(sv, w - SvPVX_const(sv)); } - last = w; + last_off = w - SvPVX(sv); if (--brackets <= 0) cont = FALSE; } @@ -11672,15 +11794,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) CopLINE_inc(PL_curcop); /* update debugger info */ - if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV * const line_sv = newSV(0); - - sv_upgrade(line_sv, SVt_PVMG); - sv_setsv(line_sv,PL_linestr); - (void)SvIOK_on(line_sv); - SvIV_set(line_sv, 0); - av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop), line_sv); - } + if (PERLDB_LINE && PL_curstash != PL_debstash) + update_debugger_info(PL_linestr, NULL, 0); /* having changed the buffer, we must update PL_bufend */ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); @@ -11693,7 +11808,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) #ifdef PERL_MAD if (PL_madskills) { char * const tstart = SvPVX(PL_linestr) + stuffstart; - const int len = s - start; + const int len = s - tstart; if (PL_thisstuff) sv_catpvn(PL_thisstuff, tstart, len); else @@ -12135,7 +12250,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) case 'v': vstring: sv = newSV(5); /* preallocate storage space */ - s = scan_vstring(s,sv); + s = scan_vstring(s, PL_bufend, sv); break; } @@ -12308,8 +12423,7 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) save_item(PL_subname); SAVESPTR(PL_compcv); - PL_compcv = (CV*)newSV(0); - sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV); + PL_compcv = (CV*)newSV_type(is_format ? SVt_PVFM : SVt_PVCV); CvFLAGS(PL_compcv) |= flags; PL_subline = CopLINE(PL_curcop); @@ -12341,6 +12455,7 @@ Perl_yyerror(pTHX_ const char *s) const char *context = NULL; int contlen = -1; SV *msg; + int yychar = PL_parser->yychar; if (!yychar || (yychar == ';' && !PL_rsfp)) where = "at EOF"; @@ -12412,13 +12527,13 @@ Perl_yyerror(pTHX_ const char *s) PL_multi_end = 0; } if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, (void*)msg); + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg)); else qerror(msg); if (PL_error_count >= 10) { if (PL_in_eval && SvCUR(ERRSV)) Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n", - (void*)ERRSV, OutCopFILE(PL_curcop)); + SVfARG(ERRSV), OutCopFILE(PL_curcop)); else Perl_croak(aTHX_ "%s has too many errors.\n", OutCopFILE(PL_curcop)); @@ -12617,28 +12732,29 @@ vstring, as well as updating the passed in sv. Function must be called like sv = newSV(5); - s = scan_vstring(s,sv); + s = scan_vstring(s,e,sv); +where s and e are the start and end of the string. The sv should already be large enough to store the vstring passed in, for performance reasons. */ char * -Perl_scan_vstring(pTHX_ const char *s, SV *sv) +Perl_scan_vstring(pTHX_ const char *s, const char *e, SV *sv) { dVAR; const char *pos = s; const char *start = s; if (*pos == 'v') pos++; /* get past 'v' */ - while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_')) + while (pos < e && (isDIGIT(*pos) || *pos == '_')) pos++; if ( *pos != '.') { /* this may not be a v-string if followed by => */ const char *next = pos; - while (next < PL_bufend && isSPACE(*next)) + while (next < e && isSPACE(*next)) ++next; - if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) { + if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) { /* return string not v-string */ sv_setpvn(sv,(char *)s,pos-s); return (char *)pos; @@ -12678,13 +12794,13 @@ Perl_scan_vstring(pTHX_ const char *s, SV *sv) sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev))) SvUTF8_on(sv); - if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1])) + if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1])) s = ++pos; else { s = pos; break; } - while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_')) + while (pos < e && (isDIGIT(*pos) || *pos == '_')) pos++; } SvPOK_on(sv);