X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/36dee510cd49a7318e0ddea31b4d74e974725f7d..584420f022db5722:/toke.c diff --git a/toke.c b/toke.c index f8e11c9..a375a77 100644 --- a/toke.c +++ b/toke.c @@ -49,6 +49,25 @@ #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) +#define PL_rsfp (PL_parser->rsfp) +#define PL_rsfp_filters (PL_parser->rsfp_filters) +#define PL_in_my (PL_parser->in_my) +#define PL_in_my_stash (PL_parser->in_my_stash) +#define PL_tokenbuf (PL_parser->tokenbuf) +#define PL_multi_end (PL_parser->multi_end) +#define PL_error_count (PL_parser->error_count) #ifdef PERL_MAD # define PL_endwhite (PL_parser->endwhite) @@ -63,6 +82,13 @@ # 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 @@ -71,7 +97,6 @@ S_pending_ident(pTHX); static const char ident_too_long[] = "Identifier too long"; static const char commaless_variable_list[] = "comma-less variable list"; -static void restore_rsfp(pTHX_ void *f); #ifndef PERL_NO_UTF16_FILTER static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen); static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen); @@ -615,21 +640,30 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) /* * Perl_lex_start + * * Create a parser object and initialise its parser and lexer fields + * + * rsfp is the opened file handle to read from (if any), + * + * line holds any initial content already read from the file (or in + * the case of no file, such as an eval, the whole contents); + * + * new_filter indicates that this is a new file and it shouldn't inherit + * the filters from the current parser (ie require). */ void -Perl_lex_start(pTHX_ SV *line) +Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter) { dVAR; const char *s = NULL; STRLEN len; - yy_parser *parser; + yy_parser *parser, *oparser; /* create and initialise a parser */ Newxz(parser, 1, yy_parser); - parser->old_parser = PL_parser; + parser->old_parser = oparser = PL_parser; PL_parser = parser; Newx(parser->stack, YYINITDEPTH, yy_stack_frame); @@ -642,77 +676,49 @@ Perl_lex_start(pTHX_ SV *line) /* on scope exit, free this parser and restore any outer one */ SAVEPARSER(parser); + parser->saved_curcop = PL_curcop; /* initialise lexer state */ - SAVEI32(PL_lex_state); #ifdef PERL_MAD - if (PL_lex_state == LEX_KNOWNEXT) { - I32 toke = parser->old_parser->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_curforce); - PL_curforce = -1; + parser->curforce = -1; #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); - } + parser->nexttoke = 0; #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); - SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp); - SAVEINT(PL_expect); + parser->copline = NOLINE; + parser->lex_state = LEX_NORMAL; + parser->expect = XSTATE; + parser->rsfp = rsfp; + parser->rsfp_filters = (new_filter || !oparser) ? newAV() + : (AV*)SvREFCNT_inc(oparser->rsfp_filters); - PL_copline = NOLINE; - PL_lex_state = LEX_NORMAL; - PL_expect = XSTATE; Newx(parser->lex_brackstack, 120, char); Newx(parser->lex_casestack, 12, char); *parser->lex_casestack = '\0'; -#ifndef PERL_MAD - PL_nexttoke = 0; -#endif if (line) { s = SvPV_const(line, len); } else { len = 0; } + if (!len) { - PL_linestr = newSVpvs("\n;"); + parser->linestr = newSVpvs("\n;"); } else if (SvREADONLY(line) || s[len-1] != ';') { - PL_linestr = newSVsv(line); + parser->linestr = newSVsv(line); if (s[len-1] != ';') - sv_catpvs(PL_linestr, "\n;"); + sv_catpvs(parser->linestr, "\n;"); } else { SvTEMP_off(line); SvREFCNT_inc_simple_void_NN(line); - PL_linestr = line; - } - /* PL_linestr needs to survive until end of scope, not just the next - FREETMPS. See changes 17505 and 17546 which fixed the symptoms only. */ - SAVEFREESV(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; - PL_rsfp = 0; + 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; } @@ -721,6 +727,16 @@ Perl_lex_start(pTHX_ SV *line) void Perl_parser_free(pTHX_ const yy_parser *parser) { + PL_curcop = parser->saved_curcop; + SvREFCNT_dec(parser->linestr); + + if (parser->rsfp == PerlIO_stdin()) + PerlIO_clearerr(parser->rsfp); + else if (parser->rsfp && parser->old_parser + && parser->rsfp != parser->old_parser->rsfp) + PerlIO_close(parser->rsfp); + SvREFCNT_dec(parser->rsfp_filters); + Safefree(parser->stack); Safefree(parser->lex_brackstack); Safefree(parser->lex_casestack); @@ -1266,7 +1282,7 @@ S_curmad(pTHX_ char slot, SV *sv) /* keep a slot open for the head of the list? */ if (slot != '_' && *where && (*where)->mad_key == '^') { (*where)->mad_key = slot; - sv_free((*where)->mad_val); + sv_free((SV*)((*where)->mad_val)); (*where)->mad_val = (void*)sv; } else @@ -1364,6 +1380,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)); @@ -1627,7 +1645,7 @@ S_sublex_start(pTHX) } 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; @@ -1656,13 +1674,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); @@ -2763,6 +2781,9 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) if (!funcp) return NULL; + if (!PL_parser) + return NULL; + if (!PL_rsfp_filters) PL_rsfp_filters = newAV(); if (!datasv) @@ -2790,7 +2811,7 @@ Perl_filter_del(pTHX_ filter_t funcp) DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(void*, funcp))); #endif - if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0) + if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0) return; /* if filter is on top of stack (usual case) just pop it off */ datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters)); @@ -2826,7 +2847,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) #endif : maxlen; - if (!PL_rsfp_filters) + if (!PL_parser || !PL_rsfp_filters) return -1; if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */ /* Provide a default input filter to make life easy. */ @@ -4275,10 +4296,6 @@ Perl_yylex(pTHX) sv_free(sv); CvMETHOD_on(PL_compcv); } - else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) { - sv_free(sv); - CvASSERTION_on(PL_compcv); - } /* After we've set the flags, it could be argued that we don't need to do the attributes.pm-based setting process, and shouldn't bother appending recognized @@ -5197,8 +5214,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 */ } @@ -6183,7 +6199,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 @@ -10839,8 +10855,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 @@ -10860,8 +10896,6 @@ S_scan_pat(pTHX_ char *start, I32 type) "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; @@ -10962,7 +10996,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; @@ -12649,23 +12682,6 @@ S_swallow_bom(pTHX_ U8 *s) return (char*)s; } -/* - * restore_rsfp - * Restore a source filter. - */ - -static void -restore_rsfp(pTHX_ void *f) -{ - dVAR; - PerlIO * const fp = (PerlIO*)f; - - if (PL_rsfp == PerlIO_stdin()) - PerlIO_clearerr(PL_rsfp); - else if (PL_rsfp && (PL_rsfp != fp)) - PerlIO_close(PL_rsfp); - PL_rsfp = fp; -} #ifndef PERL_NO_UTF16_FILTER static I32