X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=951c1ca84cfe93b0ccd331a677e5881ac50c1d77;hb=0598b5ab3697b872539de6ed6dc1522b873602e1;hp=fe530bcb4235a2284c83ae573e79f8a8a262b6f4;hpb=cd81e91502ad4d6bb904961b23b1a3ff2fa664af;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index fe530bc..951c1ca 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 + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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. @@ -9,7 +9,9 @@ */ /* - * "It all comes from here, the stench and the peril." --Frodo + * 'It all comes from here, the stench and the peril.' --Frodo + * + * [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"] */ /* @@ -23,33 +25,89 @@ #define PERL_IN_TOKE_C #include "perl.h" -#define yychar (*PL_yycharp) -#define yylval (*PL_yylvalp) +#define new_constant(a,b,c,d,e,f,g) \ + S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g) + +#define pl_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) +#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) +# 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"; -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); #endif #ifdef PERL_MAD -/* XXX these probably need to be made into PL vars */ -static I32 PL_realtokenstart; -static I32 PL_faketokens = 0; -static MADPROP *PL_thismad; -static SV *PL_thistoken; -static SV *PL_thisopen; -static SV *PL_thisstuff; -static SV *PL_thisclose; -static SV *PL_thiswhite; -static SV *PL_nextwhite; -static SV *PL_skipwhite; -static SV *PL_endwhite; -static I32 PL_curforce = -1; - # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; } # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val #else @@ -171,7 +229,7 @@ static const char* const lex_state_names[] = { */ #ifdef DEBUGGING /* Serve -DT. */ -# define REPORT(retval) tokereport((I32)retval) +# define REPORT(retval) tokereport((I32)retval, &pl_yylval) #else # define REPORT(retval) (retval) #endif @@ -183,19 +241,19 @@ static const char* const lex_state_names[] = { #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval)) #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval)) #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval)) -#define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX)) -#define FTST(f) return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP)) -#define FUN0(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0)) -#define FUN1(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1)) -#define BOop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP))) -#define BAop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP))) -#define SHop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP))) -#define PWop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP))) -#define PMop(f) return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP)) -#define Aop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP))) -#define Mop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP))) -#define Eop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP)) -#define Rop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP)) +#define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX)) +#define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP)) +#define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0)) +#define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1)) +#define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP))) +#define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP))) +#define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP))) +#define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP))) +#define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP)) +#define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP))) +#define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP))) +#define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP)) +#define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP)) /* This bit of chicanery makes a unary function followed by * a parenthesis into a function with one argument, highest precedence. @@ -203,7 +261,7 @@ static const char* const lex_state_names[] = { * operator (such as C). */ #define UNI2(f,x) { \ - yylval.ival = f; \ + pl_yylval.ival = f; \ PL_expect = x; \ PL_bufptr = s; \ PL_last_uni = PL_oldbufptr; \ @@ -217,7 +275,7 @@ static const char* const lex_state_names[] = { #define UNIDOR(f) UNI2(f,XTERMORDORDOR) #define UNIBRACK(f) { \ - yylval.ival = f; \ + pl_yylval.ival = f; \ PL_bufptr = s; \ PL_last_uni = PL_oldbufptr; \ if (*s == '(') \ @@ -227,15 +285,15 @@ static const char* const lex_state_names[] = { } /* grandfather return to old style */ -#define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP) +#define OLDLOP(f) return(pl_yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP) #ifdef DEBUGGING -/* how to interpret the yylval associated with the token */ +/* how to interpret the pl_yylval associated with the token */ enum token_type { TOKENTYPE_NONE, TOKENTYPE_IVAL, - TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */ + TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */ TOKENTYPE_PVAL, TOKENTYPE_OPVAL, TOKENTYPE_GVVAL @@ -312,15 +370,19 @@ static struct debug_tokens { { WHEN, TOKENTYPE_IVAL, "WHEN" }, { WHILE, TOKENTYPE_IVAL, "WHILE" }, { WORD, TOKENTYPE_OPVAL, "WORD" }, - { 0, TOKENTYPE_NONE, 0 } + { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" }, + { 0, TOKENTYPE_NONE, NULL } }; -/* dump the returned token in rv, plus any optional arg in yylval */ +/* dump the returned token in rv, plus any optional arg in pl_yylval */ STATIC int -S_tokereport(pTHX_ I32 rv) +S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp) { dVAR; + + PERL_ARGS_ASSERT_TOKEREPORT; + if (DEBUG_T_TEST) { const char *name = NULL; enum token_type type = TOKENTYPE_NONE; @@ -347,22 +409,22 @@ S_tokereport(pTHX_ I32 rv) case TOKENTYPE_GVVAL: /* doesn't appear to be used */ break; case TOKENTYPE_IVAL: - Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival); + Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival); break; case TOKENTYPE_OPNUM: Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)", - PL_op_name[yylval.ival]); + PL_op_name[lvalp->ival]); break; case TOKENTYPE_PVAL: - Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval); + Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval); break; case TOKENTYPE_OPVAL: - if (yylval.opval) { + if (lvalp->opval) { Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)", - PL_op_name[yylval.opval->op_type]); - if (yylval.opval->op_type == OP_CONST) { + PL_op_name[lvalp->opval->op_type]); + if (lvalp->opval->op_type == OP_CONST) { Perl_sv_catpvf(aTHX_ report, " %s", - SvPEEK(cSVOPx_sv(yylval.opval))); + SvPEEK(cSVOPx_sv(lvalp->opval))); } } @@ -379,9 +441,12 @@ S_tokereport(pTHX_ I32 rv) /* print the buffer with suitable escapes */ STATIC void -S_printbuf(pTHX_ const char* fmt, const char* s) +S_printbuf(pTHX_ const char *const fmt, const char *const s) { SV* const tmp = newSVpvs(""); + + PERL_ARGS_ASSERT_PRINTBUF; + PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60)); SvREFCNT_dec(tmp); } @@ -402,11 +467,11 @@ S_ao(pTHX_ int toketype) if (*PL_bufptr == '=') { PL_bufptr++; if (toketype == ANDAND) - yylval.ival = OP_ANDASSIGN; + pl_yylval.ival = OP_ANDASSIGN; else if (toketype == OROR) - yylval.ival = OP_ORASSIGN; + pl_yylval.ival = OP_ORASSIGN; else if (toketype == DORDOR) - yylval.ival = OP_DORASSIGN; + pl_yylval.ival = OP_DORASSIGN; toketype = ASSIGNOP; } return toketype; @@ -426,12 +491,14 @@ S_ao(pTHX_ int toketype) */ STATIC void -S_no_op(pTHX_ const char *what, char *s) +S_no_op(pTHX_ const char *const what, char *s) { dVAR; char * const oldbp = PL_bufptr; const bool is_first = (PL_oldbufptr == PL_linestart); + PERL_ARGS_ASSERT_NO_OP; + if (!s) s = oldbp; else @@ -443,7 +510,8 @@ S_no_op(pTHX_ const char *what, char *s) "\t(Missing semicolon on previous line?)\n"); else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) { const char *t; - for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ; + for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) + NOOP; if (t < PL_bufptr && isSPACE(*t)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\t(Do you need to predeclare %.*s?)\n", @@ -461,7 +529,7 @@ S_no_op(pTHX_ const char *what, char *s) /* * S_missingterm * Complain about missing quote/regexp/heredoc terminator. - * If it's called with (char *)NULL then it cauterizes the line buffer. + * If it's called with NULL then it cauterizes the line buffer. * If we're in a delimited string and the delimiter is a control * character, it's reformatted into a two-char sequence like ^C. * This is fatal. @@ -478,13 +546,7 @@ S_missingterm(pTHX_ char *s) if (nl) *nl = '\0'; } - else if ( -#ifdef EBCDIC - iscntrl(PL_multi_close) -#else - PL_multi_close < 32 || PL_multi_close == 127 -#endif - ) { + else if (isCNTRL(PL_multi_close)) { *tmpbuf = '^'; tmpbuf[1] = (char)toCTRL(PL_multi_close); tmpbuf[2] = '\0'; @@ -502,18 +564,25 @@ S_missingterm(pTHX_ char *s) #define FEATURE_IS_ENABLED(name) \ ((0 != (PL_hints & HINT_LOCALIZE_HH)) \ && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name))) +/* The longest string we pass in. */ +#define MAX_FEATURE_LEN (sizeof("switch")-1) + /* * S_feature_is_enabled * Check whether the named feature is enabled. */ STATIC bool -S_feature_is_enabled(pTHX_ char *name, STRLEN namelen) +S_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen) { dVAR; HV * const hinthv = GvHV(PL_hintgv); - char he_name[32] = "feature_"; - (void) strncpy(&he_name[8], name, 24); - + char he_name[8 + MAX_FEATURE_LEN] = "feature_"; + + PERL_ARGS_ASSERT_FEATURE_IS_ENABLED; + + assert(namelen <= MAX_FEATURE_LEN); + memcpy(&he_name[8], name, namelen); + return (hinthv && hv_exists(hinthv, he_name, 8 + namelen)); } @@ -522,14 +591,16 @@ S_feature_is_enabled(pTHX_ char *name, STRLEN namelen) */ void -Perl_deprecate(pTHX_ const char *s) +Perl_deprecate(pTHX_ const char *const s) { + PERL_ARGS_ASSERT_DEPRECATE; + if (ckWARN(WARN_DEPRECATED)) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s); } void -Perl_deprecate_old(pTHX_ const char *s) +Perl_deprecate_old(pTHX_ const char *const s) { /* This function should NOT be called for any new deprecated warnings */ /* Use Perl_deprecate instead */ @@ -539,6 +610,8 @@ Perl_deprecate_old(pTHX_ const char *s) /* live under the "syntax" category. It is now a top-level category */ /* in its own right. */ + PERL_ARGS_ASSERT_DEPRECATE_OLD; + if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of %s is deprecated", s); @@ -555,6 +628,9 @@ strip_return(SV *sv) { register const char *s = SvPVX_const(sv); register const char * const e = s + SvCUR(sv); + + PERL_ARGS_ASSERT_STRIP_RETURN; + /* outer loop optimized to do nothing if there are no CR-LFs */ while (s < e) { if (*s++ == '\r' && *s == '\n') { @@ -582,114 +658,118 @@ 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 + * + * 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; + const char *s = NULL; STRLEN len; + yy_parser *parser, *oparser; + + /* create and initialise a parser */ + + Newxz(parser, 1, yy_parser); + parser->old_parser = oparser = 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); + parser->saved_curcop = PL_curcop; + + /* 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; - PL_rsfp = 0; + parser->nexttoke = 0; +#endif + parser->error_count = oparser ? oparser->error_count : 0; + parser->copline = NOLINE; + parser->lex_state = LEX_NORMAL; + parser->expect = XSTATE; + parser->rsfp = rsfp; + parser->rsfp_filters = (new_filter || !oparser) ? newAV() + : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters)); + + 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; } + +/* delete a parser object */ + +void +Perl_parser_free(pTHX_ const yy_parser *parser) +{ + PERL_ARGS_ASSERT_PARSER_FREE; + + 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->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); + PL_parser = parser->old_parser; + Safefree(parser); +} + + /* * Perl_lex_end * Finalizer for lexing operations. Must be called when the parser is @@ -714,18 +794,20 @@ 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; + + PERL_ARGS_ASSERT_INCLINE; CopLINE_inc(PL_curcop); if (*s++ != '#') return; - while (SPACE_OR_TAB(*s)) s++; + while (SPACE_OR_TAB(*s)) + s++; if (strnEQ(s, "line", 4)) s += 4; else @@ -734,12 +816,16 @@ S_incline(pTHX_ char *s) s++; else return; - while (SPACE_OR_TAB(*s)) s++; + while (SPACE_OR_TAB(*s)) + s++; if (!isDIGIT(*s)) return; + n = s; while (isDIGIT(*s)) s++; + if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0') + return; while (SPACE_OR_TAB(*s)) s++; if (*s == '"' && (t = strchr(s+1, '"'))) { @@ -747,7 +833,9 @@ S_incline(pTHX_ char *s) e = t + 1; } else { - for (t = s; !isSPACE(*t); t++) ; + t = s; + while (!isSPACE(*t)) + t++; e = t; } while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f') @@ -755,50 +843,75 @@ 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; + SV *const temp_sv = CopFILESV(PL_curcop); + const char *cf; + STRLEN tmplen; + + if (temp_sv) { + cf = SvPVX(temp_sv); + tmplen = SvCUR(temp_sv); + } else { + cf = NULL; + tmplen = 0; + } + if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) { /* must copy *{"::_<(eval N)[oldfilename:L]"} * to *{"::_= 0) { - char *tstart = SvPVX(PL_linestr) + PL_realtokenstart; + const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart; PL_thistoken = newSVpvn(tstart, start - tstart); } PL_realtokenstart = -1; if (PL_skipwhite) { if (!PL_nextwhite) - PL_nextwhite = newSVpvn("",0); + PL_nextwhite = newSVpvs(""); sv_catsv(PL_nextwhite, PL_skipwhite); sv_free(PL_skipwhite); PL_skipwhite = 0; @@ -852,22 +969,25 @@ S_skipspace1(pTHX_ register char *s) STATIC char * S_skipspace2(pTHX_ register char *s, SV **svp) { - char *start = s; - I32 bufptroff = PL_bufptr - SvPVX(PL_linestr); - I32 startoff = start - SvPVX(PL_linestr); + char *start; + const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr); + const I32 startoff = s - SvPVX(PL_linestr); + + PERL_ARGS_ASSERT_SKIPSPACE2; + s = skipspace(s); PL_bufptr = SvPVX(PL_linestr) + bufptroff; if (!PL_madskills || !svp) return s; start = SvPVX(PL_linestr) + startoff; if (!PL_thistoken && PL_realtokenstart >= 0) { - char *tstart = SvPVX(PL_linestr) + PL_realtokenstart; + char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart; PL_thistoken = newSVpvn(tstart, start - tstart); PL_realtokenstart = -1; } if (PL_skipwhite) { if (!*svp) - *svp = newSVpvn("",0); + *svp = newSVpvs(""); sv_setsv(*svp, PL_skipwhite); sv_free(PL_skipwhite); PL_skipwhite = 0; @@ -877,6 +997,22 @@ S_skipspace2(pTHX_ register char *s, SV **svp) } #endif +STATIC void +S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len) +{ + AV *av = CopFILEAVx(PL_curcop); + if (av) { + SV * const sv = newSV_type(SVt_PVMG); + if (orig_sv) + sv_setsv(sv, orig_sv); + else + sv_setpvn(sv, buf, len); + (void)SvIOK_on(sv); + SvIV_set(sv, 0); + av_store(av, (I32)CopLINE(PL_curcop), sv); + } +} + /* * S_skipspace * Called to gobble the appropriate amount and type of whitespace. @@ -891,11 +1027,14 @@ S_skipspace(pTHX_ register char *s) int curoff; int startoff = s - SvPVX(PL_linestr); + PERL_ARGS_ASSERT_SKIPSPACE; + if (PL_skipwhite) { sv_free(PL_skipwhite); PL_skipwhite = 0; } #endif + PERL_ARGS_ASSERT_SKIPSPACE; if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { while (s < PL_bufend && SPACE_OR_TAB(*s)) @@ -951,7 +1090,7 @@ S_skipspace(pTHX_ register char *s) #ifdef PERL_MAD if (PL_madskills && curoff != startoff) { if (!PL_skipwhite) - PL_skipwhite = newSVpvn("",0); + PL_skipwhite = newSVpvs(""); sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff, curoff - startoff); } @@ -968,27 +1107,27 @@ S_skipspace(pTHX_ register char *s) /* XXX these shouldn't really be added here, can't set PL_faketokens */ if (PL_minus_p) { #ifdef PERL_MAD - sv_catpv(PL_linestr, + sv_catpvs(PL_linestr, ";}continue{print or die qq(-p destination: $!\\n);}"); #else - sv_setpv(PL_linestr, + sv_setpvs(PL_linestr, ";}continue{print or die qq(-p destination: $!\\n);}"); #endif PL_minus_n = PL_minus_p = 0; } else if (PL_minus_n) { #ifdef PERL_MAD - sv_catpvn(PL_linestr, ";}", 2); + sv_catpvs(PL_linestr, ";}"); #else - sv_setpvn(PL_linestr, ";}", 2); + sv_setpvs(PL_linestr, ";}"); #endif PL_minus_n = 0; } else #ifdef PERL_MAD - sv_catpvn(PL_linestr,";", 1); + sv_catpvs(PL_linestr,";"); #else - sv_setpvn(PL_linestr,";", 1); + sv_setpvs(PL_linestr,";"); #endif /* reset variables for next time we lex */ @@ -1001,16 +1140,14 @@ S_skipspace(pTHX_ register char *s) PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = NULL; - /* Close the filehandle. Could be from -P preprocessor, + /* Close the filehandle. Could be from * STDIN, or a regular file. If we were reading code from * STDIN (because the commandline held no -e or filename) * then we don't close it, we reset it so the code can * read from STDIN too. */ - if (PL_preprocess && !PL_in_eval) - (void)PerlProc_pclose(PL_rsfp); - else if ((PerlIO*)PL_rsfp == PerlIO_stdin()) + if ((PerlIO*)PL_rsfp == PerlIO_stdin()) PerlIO_clearerr(PL_rsfp); else (void)PerlIO_close(PL_rsfp); @@ -1040,22 +1177,15 @@ S_skipspace(pTHX_ register char *s) /* debugger active and we're not compiling the debugger code, * so store the line into the debugger's array of lines */ - if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV * const sv = newSV(0); - - sv_upgrade(sv, SVt_PVMG); - sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr); - (void)SvIOK_on(sv); - SvIV_set(sv, 0); - av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv); - } + if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) + update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr); } #ifdef PERL_MAD done: if (PL_madskills) { if (!PL_skipwhite) - PL_skipwhite = newSVpvn("",0); + PL_skipwhite = newSVpvs(""); curoff = s - SvPVX(PL_linestr); if (curoff - startoff) sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff, @@ -1078,14 +1208,16 @@ STATIC void S_check_uni(pTHX) { dVAR; - char *s; - char *t; + const char *s; + const char *t; if (PL_oldoldbufptr != PL_last_uni) return; while (isSPACE(*PL_last_uni)) PL_last_uni++; - for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ; + s = PL_last_uni; + while (isALNUM_lazy_if(s,UTF) || *s == '-') + s++; if ((t = strchr(s, '(')) && t < PL_bufptr) return; @@ -1115,7 +1247,10 @@ STATIC I32 S_lop(pTHX_ I32 f, int x, char *s) { dVAR; - yylval.ival = f; + + PERL_ARGS_ASSERT_LOP; + + pl_yylval.ival = f; CLINE; PL_expect = x; PL_bufptr = s; @@ -1164,7 +1299,7 @@ S_start_force(pTHX_ int where) PL_curforce = where; if (PL_nextwhite) { if (PL_madskills) - curmad('^', newSVpvn("",0)); + curmad('^', newSVpvs("")); CURMAD('_', PL_nextwhite); } } @@ -1182,7 +1317,7 @@ S_curmad(pTHX_ char slot, SV *sv) where = &PL_nexttoke[PL_curforce].next_mad; if (PL_faketokens) - sv_setpvn(sv, "", 0); + sv_setpvs(sv, ""); else { if (!IN_BYTES) { if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv))) @@ -1196,15 +1331,15 @@ 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(MUTABLE_SV(((*where)->mad_val))); (*where)->mad_val = (void*)sv; } else addmad(newMADsv(slot, sv), where, 0); } #else -# define start_force(where) -# define curmad(slot, sv) +# define start_force(where) NOOP +# define curmad(slot, sv) NOOP #endif /* @@ -1220,6 +1355,12 @@ STATIC void S_force_next(pTHX_ I32 type) { dVAR; +#ifdef DEBUGGING + if (DEBUG_T_TEST) { + PerlIO_printf(Perl_debug_log, "### forced token:\n"); + tokereport(type, &NEXTVAL_NEXTTOKE); + } +#endif #ifdef PERL_MAD if (PL_curforce < 0) start_force(PL_lasttoke); @@ -1241,12 +1382,12 @@ S_force_next(pTHX_ I32 type) } STATIC SV * -S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len) +S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len) { dVAR; - SV * const sv = newSVpvn(start,len); - if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len)) - SvUTF8_on(sv); + SV * const sv = newSVpvn_utf8(start, len, + UTF && !IN_BYTES + && is_utf8_string((const U8*)start, len)); return sv; } @@ -1254,11 +1395,12 @@ S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len) * S_force_word * When the lexer knows the next thing is a word (for instance, it has * just seen -> 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, @@ -1273,6 +1415,8 @@ S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow register char *s; STRLEN len; + PERL_ARGS_ASSERT_FORCE_WORD; + start = SKIPSPACE1(start); s = start; if (isIDFIRST_lazy_if(s,UTF) || @@ -1280,7 +1424,7 @@ S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow (allow_initial_tick && *s == '\'') ) { s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len); - if (check_keyword && keyword(PL_tokenbuf, len)) + if (check_keyword && keyword(PL_tokenbuf, len, 0)) return start; start_force(PL_curforce); if (PL_madskills) @@ -1293,6 +1437,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)); @@ -1315,7 +1461,10 @@ STATIC void S_force_ident(pTHX_ register const char *s, int kind) { dVAR; - if (s && *s) { + + PERL_ARGS_ASSERT_FORCE_IDENT; + + if (*s) { const STRLEN len = strlen(s); OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len)); start_force(PL_curforce); @@ -1347,6 +1496,9 @@ Perl_str_to_version(pTHX_ SV *sv) const char *start = SvPV_const(sv,len); const char * const end = start + len; const bool utf = SvUTF8(sv) ? TRUE : FALSE; + + PERL_ARGS_ASSERT_STR_TO_VERSION; + while (start < end) { STRLEN skip; UV n; @@ -1381,6 +1533,8 @@ S_force_version(pTHX_ char *s, int guessing) I32 startoff = s - SvPVX(PL_linestr); #endif + PERL_ARGS_ASSERT_FORCE_VERSION; + s = SKIPSPACE1(s); d = s; @@ -1397,8 +1551,8 @@ S_force_version(pTHX_ char *s, int guessing) #endif if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) { SV *ver; - s = scan_num(s, &yylval); - version = yylval.opval; + s = scan_num(s, &pl_yylval); + version = pl_yylval.opval; ver = cSVOPx(version)->op_sv; if (SvPOK(ver) && !SvNIOK(ver)) { SvUPGRADE(ver, SVt_PVNV); @@ -1451,6 +1605,8 @@ S_tokeq(pTHX_ SV *sv) STRLEN len = 0; SV *pv = sv; + PERL_ARGS_ASSERT_TOKEQ; + if (!SvLEN(sv)) goto finish; @@ -1464,9 +1620,7 @@ S_tokeq(pTHX_ SV *sv) goto finish; d = s; if ( PL_hints & HINT_NEW_STRING ) { - pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len)); - if (SvUTF8(sv)) - SvUTF8_on(pv); + pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv)); } while (s < send) { if (*s == '\\') { @@ -1479,7 +1633,7 @@ S_tokeq(pTHX_ SV *sv) SvCUR_set(sv, d - SvPVX_const(sv)); finish: if ( PL_hints & HINT_NEW_STRING ) - return new_constant(NULL, 0, "q", sv, pv, "q"); + return new_constant(NULL, 0, "q", sv, pv, "q", 1); return sv; } @@ -1501,10 +1655,10 @@ S_tokeq(pTHX_ SV *sv) /* * S_sublex_start - * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST). + * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST). * * Pattern matching will set PL_lex_op to the pattern-matching op to - * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise). + * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise). * * OP_CONST and OP_READLINE are easy--just make the new op and return. * @@ -1519,10 +1673,10 @@ STATIC I32 S_sublex_start(pTHX) { dVAR; - register const I32 op_type = yylval.ival; + register const I32 op_type = pl_yylval.ival; if (op_type == OP_NULL) { - yylval.opval = PL_lex_op; + pl_yylval.opval = PL_lex_op; PL_lex_op = NULL; return THING; } @@ -1533,28 +1687,34 @@ S_sublex_start(pTHX) /* Overloaded constants, nothing fancy: Convert to SVt_PV: */ STRLEN len; const char * const p = SvPV_const(sv, len); - SV * const nsv = newSVpvn(p, len); - if (SvUTF8(sv)) - SvUTF8_on(nsv); + SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv)); SvREFCNT_dec(sv); sv = nsv; } - yylval.opval = (OP*)newSVOP(op_type, 0, sv); + pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv); PL_lex_stuff = NULL; /* Allow // "foo" */ if (op_type == OP_READLINE) 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); + pl_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; PL_expect = XTERM; if (PL_lex_op) { - yylval.opval = PL_lex_op; + pl_yylval.opval = PL_lex_op; PL_lex_op = NULL; return PMFUNC; } @@ -1577,13 +1737,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); @@ -1638,7 +1798,7 @@ S_sublex_done(pTHX) if (SvUTF8(PL_linestr)) SvUTF8_on(sv); PL_expect = XOPERATOR; - yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); + pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); return THING; } @@ -1679,12 +1839,12 @@ S_sublex_done(pTHX) if (PL_madskills) { if (PL_thiswhite) { if (!PL_endwhite) - PL_endwhite = newSVpvn("",0); + PL_endwhite = newSVpvs(""); sv_catsv(PL_endwhite, PL_thiswhite); PL_thiswhite = 0; } if (PL_thistoken) - sv_setpvn(PL_thistoken,"",0); + sv_setpvs(PL_thistoken,""); else PL_realtokenstart = -1; } @@ -1704,35 +1864,37 @@ S_sublex_done(pTHX) Extracts a pattern, double-quoted string, or transliteration. This is terrifying code. - It looks at lex_inwhat and PL_lex_inpat to find out whether it's + 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 - (lex_inwhat & OP_TRANS is true), or a double-quoted string. + (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string. - Returns a pointer to the character scanned up to. Iff this is - advanced from the start pointer supplied (ie if anything was + 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 - in yylval. Caller must intuit reason for not parsing further + in pl_yylval. Caller must intuit reason for not parsing further by looking at the next characters herself. In patterns: backslashes: double-quoted style: \r and \n regexp special ones: \D \s - constants: \x3 - backrefs: \1 (deprecated in substitution replacements) + constants: \x31 + backrefs: \1 case and quoting: \U \Q \E stops on @ and $, but not for $ as tail anchor In transliterations: characters are VERY literal, except for - not at the start or end - of the string, which indicates a range. scan_const expands the - range to the full set of intermediate characters. + of the string, which indicates a range. If the range is in bytes, + scan_const expands the range to the full set of intermediate + characters. If the range is in utf8, the hyphen is replaced with + a certain range mark which will be handled by pmtrans() in op.c. In double-quoted strings: backslashes: double-quoted style: \r and \n - constants: \x3 - backrefs: \1 (deprecated) + constants: \x31 + deprecated backrefs: \1 (in substitution replacements) case and quoting: \U \Q \E stops on @ and $ @@ -1740,33 +1902,39 @@ S_sublex_done(pTHX) It stops processing as soon as it finds an embedded $ or @ variable and leaves it to the caller to work out what's going on. - @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo. + embedded arrays (whether in pattern or not) could be: + @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-. + + $ in double-quoted strings must be the symbol of an embedded scalar. $ in pattern could be $foo or could be tail anchor. Assumption: it's a tail anchor if $ is the last thing in the string, or if it's - followed by one of ")| \n\t" + followed by one of "()| \r\n\t" \1 (backreferences) are turned into $1 The structure of the code is while (there's a character to process) { - handle transliteration ranges - skip regexp comments - skip # initiated comments in //x patterns - check for embedded @foo + handle transliteration ranges + skip regexp comments /(?#comment)/ and codes /(?{code})/ + skip #-initiated comments in //x patterns + check for embedded arrays check for embedded scalars if (backslash) { - leave intact backslashes from leave (below) - deprecate \1 in strings and sub replacements + leave intact backslashes from leaveit (below) + deprecate \1 in substitution replacements handle string-changing backslashes \l \U \Q \E, etc. switch (what was escaped) { - handle - in a transliteration (becomes a literal -) - handle \132 octal characters - handle 0x15 hex characters - handle \cV (control V) - handle printf backslashes (\f, \r, \n, etc) + handle \- in a transliteration (becomes a literal -) + handle \132 (octal characters) + handle \x15 and \x{1234} (hex characters) + handle \N{name} (named characters) + handle \cV (control characters) + handle printf-style backslashes (\f, \r, \n, etc) } (end switch) + continue } (end if backslash) + handle regular character } (end while character to read) */ @@ -1776,22 +1944,39 @@ S_scan_const(pTHX_ char *start) { dVAR; register char *send = PL_bufend; /* end of the constant */ - SV *sv = newSV(send - start); /* sv for 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 */ bool dorange = FALSE; /* are we in a translit range? */ bool didrange = FALSE; /* did we just finish a range? */ I32 has_utf8 = FALSE; /* Output constant is UTF8 */ - I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */ + I32 this_utf8 = UTF; /* Is the source string assumed + to be UTF8? But, this can + show as true when the source + isn't utf8, as for example + when it is entirely composed + of hex constants */ + + /* Note on sizing: The scanned constant is placed into sv, which is + * initialized by newSV() assuming one byte of output for every byte of + * input. This routine expects newSV() to allocate an extra byte for a + * trailing NUL, which this routine will append if it gets to the end of + * the input. There may be more bytes of input than output (eg., \N{LATIN + * CAPITAL LETTER A}), or more output than input if the constant ends up + * recoded to utf8, but each time a construct is found that might increase + * the needed size, SvGROW() is called. Its size parameter each time is + * based on the best guess estimate at the time, namely the length used so + * far, plus the length the current construct will occupy, plus room for + * the trailing NUL, plus one byte for every input byte still unscanned */ + UV uv; #ifdef EBCDIC UV literal_endpoint = 0; + bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */ #endif - const char *leaveit = /* set of acceptably-backslashed characters */ - PL_lex_inpat - ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#" - : ""; + PERL_ARGS_ASSERT_SCAN_CONST; if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { /* If we are doing a trans and we know we want UTF8 set expectation */ @@ -1809,7 +1994,15 @@ S_scan_const(pTHX_ char *start) I32 min; /* first character in range */ I32 max; /* last character in range */ - if (has_utf8) { +#ifdef EBCDIC + UV uvmax = 0; +#endif + + if (has_utf8 +#ifdef EBCDIC + && !native_range +#endif + ) { char * const c = (char*)utf8_hop((U8*)d, -1); char *e = d++; while (e-- > c) @@ -1822,12 +2015,43 @@ S_scan_const(pTHX_ char *start) } i = d - SvPVX_const(sv); /* remember current offset */ +#ifdef EBCDIC + SvGROW(sv, + SvLEN(sv) + (has_utf8 ? + (512 - UTF_CONTINUATION_MARK + + UNISKIP(0x100)) + : 256)); + /* How many two-byte within 0..255: 128 in UTF-8, + * 96 in UTF-8-mod. */ +#else SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */ +#endif d = SvPVX(sv) + i; /* refresh d after realloc */ - d -= 2; /* eat the first char and the - */ - - min = (U8)*d; /* first char in range */ - max = (U8)d[1]; /* last char in range */ +#ifdef EBCDIC + if (has_utf8) { + int j; + for (j = 0; j <= 1; j++) { + char * const c = (char*)utf8_hop((U8*)d, -1); + const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0); + if (j) + min = (U8)uv; + else if (uv < 256) + max = (U8)uv; + else { + max = (U8)0xff; /* only to \xff */ + uvmax = uv; /* \x{100} to uvmax */ + } + d = c; /* eat endpoint chars */ + } + } + else { +#endif + d -= 2; /* eat the first char and the - */ + min = (U8)*d; /* first char in range */ + max = (U8)d[1]; /* last char in range */ +#ifdef EBCDIC + } +#endif if (min > max) { Perl_croak(aTHX_ @@ -1852,7 +2076,29 @@ S_scan_const(pTHX_ char *start) else #endif for (i = min; i <= max; i++) - *d++ = (char)i; +#ifdef EBCDIC + if (has_utf8) { + const U8 ch = (U8)NATIVE_TO_UTF(i); + if (UNI_IS_INVARIANT(ch)) + *d++ = (U8)i; + else { + *d++ = (U8)UTF8_EIGHT_BIT_HI(ch); + *d++ = (U8)UTF8_EIGHT_BIT_LO(ch); + } + } + else +#endif + *d++ = (char)i; + +#ifdef EBCDIC + if (uvmax) { + d = (char*)uvchr_to_utf8((U8*)d, 0x100); + if (uvmax > 0x101) + *d++ = (char)UTF_TO_NATIVE(0xff); + if (uvmax > 0x100) + d = (char*)uvchr_to_utf8((U8*)d, uvmax); + } +#endif /* mark the range as done, and continue */ dorange = FALSE; @@ -1868,7 +2114,11 @@ S_scan_const(pTHX_ char *start) if (didrange) { Perl_croak(aTHX_ "Ambiguous range in transliteration operator"); } - if (has_utf8) { + if (has_utf8 +#ifdef EBCDIC + && !native_range +#endif + ) { *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */ s++; continue; @@ -1880,6 +2130,7 @@ S_scan_const(pTHX_ char *start) didrange = FALSE; #ifdef EBCDIC literal_endpoint = 0; + native_range = TRUE; #endif } } @@ -1894,7 +2145,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); @@ -1926,9 +2177,14 @@ S_scan_const(pTHX_ char *start) /* check for embedded arrays (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-) */ - else if (*s == '@' && s[1] - && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1]))) - break; + else if (*s == '@' && s[1]) { + if (isALNUM_lazy_if(s+1,UTF)) + break; + if (strchr(":'{$", s[1])) + break; + if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-')) + break; /* in regexp, neither @+ nor @- are interpolated */ + } /* check for embedded scalars. only stop if we're sure it's a variable. @@ -1936,8 +2192,13 @@ S_scan_const(pTHX_ char *start) else if (*s == '$') { if (!PL_lex_inpat) /* not a regexp, so $ must be var */ break; - if (s + 1 < send && !strchr("()| \r\n\t", s[1])) + if (s + 1 < send && !strchr("()| \r\n\t", s[1])) { + if (s[1] == '\\' && ckWARN(WARN_AMBIGUOUS)) { + Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), + "Possible unintended interpolation of $\\ in regex"); + } break; /* in regexp, $ might be tail anchor */ + } } /* End of else if chain - OP_TRANS rejoin rest */ @@ -1946,13 +2207,6 @@ S_scan_const(pTHX_ char *start) if (*s == '\\' && s+1 < send) { s++; - /* some backslashes we leave behind */ - if (*leaveit && *s && strchr(leaveit, *s)) { - *d++ = NATIVE_TO_NEED(has_utf8,'\\'); - *d++ = NATIVE_TO_NEED(has_utf8,*s++); - continue; - } - /* deprecate \1 in strings and substitution replacements */ if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat && isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) @@ -1968,6 +2222,11 @@ S_scan_const(pTHX_ char *start) --s; break; } + /* skip any other backslash escapes in a pattern */ + else if (PL_lex_inpat) { + *d++ = NATIVE_TO_NEED(has_utf8,'\\'); + goto default_action; + } /* if we get here, it's either a quoted -, or a digit */ switch (*s) { @@ -1981,28 +2240,27 @@ S_scan_const(pTHX_ char *start) /* FALL THROUGH */ default: { - if (isALNUM(*s) && - *s != '_' && + if ((isALPHA(*s) || isDIGIT(*s)) && ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), - "Unrecognized escape \\%c passed through", - *s); + "Unrecognized escape \\%c passed through", + *s); /* default action is to copy the quoted character */ goto default_action; } - /* \132 indicates an octal constant */ + /* eg. \132 indicates the octal constant 0x132 */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': { I32 flags = 0; STRLEN len = 3; - uv = grok_oct(s, &len, &flags, NULL); + uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL)); s += len; } goto NUM_ESCAPE_INSERT; - /* \x24 indicates a hex constant */ + /* eg. \x24 indicates the hex constant 0x24 */ case 'x': ++s; if (*s == '{') { @@ -2017,73 +2275,57 @@ S_scan_const(pTHX_ char *start) continue; } len = e - s; - uv = grok_hex(s, &len, &flags, NULL); + uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL)); s = e + 1; } else { { STRLEN len = 2; I32 flags = PERL_SCAN_DISALLOW_PREFIX; - uv = grok_hex(s, &len, &flags, NULL); + uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL)); s += len; } } NUM_ESCAPE_INSERT: - /* Insert oct or hex escaped character. - * There will always enough room in sv since such - * escapes will be longer than any UTF-8 sequence - * they can end up as. */ + /* Insert oct, hex, or \N{U+...} escaped character. There will + * always be enough room in sv since such escapes will be + * longer than any UTF-8 sequence they can end up as, except if + * they force us to recode the rest of the string into utf8 */ - /* We need to map to chars to ASCII before doing the tests - to cover EBCDIC - */ - if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) { + /* Here uv is the ordinal of the next character being added in + * unicode (converted from native). (It has to be done before + * here because \N is interpreted as unicode, and oct and hex + * as native.) */ + if (!UNI_IS_INVARIANT(uv)) { if (!has_utf8 && uv > 255) { - /* Might need to recode whatever we have - * accumulated so far if it contains any - * hibit chars. - * - * (Can't we keep track of that and avoid - * this rescan? --jhi) - */ - int hicount = 0; - U8 *c; - for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) { - if (!NATIVE_IS_INVARIANT(*c)) { - hicount++; - } - } - if (hicount) { - const STRLEN offset = d - SvPVX_const(sv); - U8 *src, *dst; - d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset; - src = (U8 *)d - 1; - dst = src+hicount; - d += hicount; - while (src >= (const U8 *)SvPVX_const(sv)) { - if (!NATIVE_IS_INVARIANT(*src)) { - const U8 ch = NATIVE_TO_ASCII(*src); - *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch); - *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch); - } - else { - *dst-- = *src; - } - src--; - } - } + /* Might need to recode whatever we have accumulated so + * far if it contains any chars variant in utf8 or + * utf-ebcdic. */ + + SvCUR_set(sv, d - SvPVX_const(sv)); + SvPOK_on(sv); + *d = '\0'; + /* See Note on sizing above. */ + sv_utf8_upgrade_flags_grow(sv, + SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, + UNISKIP(uv) + (STRLEN)(send - s) + 1); + d = SvPVX(sv) + SvCUR(sv); + has_utf8 = TRUE; } - if (has_utf8 || uv > 255) { - d = (char*)uvchr_to_utf8((U8*)d, uv); - has_utf8 = TRUE; + if (has_utf8) { + d = (char*)uvuni_to_utf8((U8*)d, uv); if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { PL_sublex_info.sub_op->op_private |= (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF); } +#ifdef EBCDIC + if (uv > 255 && !dorange) + native_range = FALSE; +#endif } else { *d++ = (char)uv; @@ -2094,7 +2336,8 @@ S_scan_const(pTHX_ char *start) } continue; - /* \N{LATIN SMALL LETTER A} is a named character */ + /* \N{LATIN SMALL LETTER A} is a named character, and so is + * \N{U+0041} */ case 'N': ++s; if (*s == '{') { @@ -2109,18 +2352,22 @@ S_scan_const(pTHX_ char *start) goto cont_scan; } if (e > s + 2 && s[1] == 'U' && s[2] == '+') { - /* \N{U+...} */ + /* \N{U+...} The ... is a unicode value even on EBCDIC + * machines */ I32 flags = PERL_SCAN_ALLOW_UNDERSCORES | PERL_SCAN_DISALLOW_PREFIX; s += 3; len = e - s; uv = grok_hex(s, &len, &flags, NULL); + if ( e > s && len != (STRLEN)(e - s) ) { + uv = 0xFFFD; + } s = e + 1; goto NUM_ESCAPE_INSERT; } res = newSVpvn(s + 1, e - s - 1); res = new_constant( NULL, 0, "charnames", - res, NULL, "\\N{...}" ); + res, NULL, s - 2, e - s + 3 ); if (has_utf8) sv_utf8_upgrade(res); str = SvPV_const(res,len); @@ -2144,23 +2391,29 @@ S_scan_const(pTHX_ char *start) } } #endif + /* If destination is not in utf8 but this new character is, + * recode the dest to utf8 */ if (!has_utf8 && SvUTF8(res)) { - const char * const ostart = SvPVX_const(sv); - SvCUR_set(sv, d - ostart); + SvCUR_set(sv, d - SvPVX_const(sv)); SvPOK_on(sv); *d = '\0'; - sv_utf8_upgrade(sv); - /* this just broke our allocation above... */ - SvGROW(sv, (STRLEN)(send - start)); + /* See Note on sizing above. */ + sv_utf8_upgrade_flags_grow(sv, + SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, + len + (STRLEN)(send - s) + 1); d = SvPVX(sv) + SvCUR(sv); has_utf8 = TRUE; - } - if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */ - const char * const odest = SvPVX_const(sv); + } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */ - SvGROW(sv, (SvLEN(sv) + len - (e - s + 4))); - d = SvPVX(sv) + (d - odest); + /* See Note on sizing above. (NOTE: SvCUR() is not set + * correctly here). */ + const STRLEN off = d - SvPVX_const(sv); + d = SvGROW(sv, off + len + (STRLEN)(send - s) + 1) + off; } +#ifdef EBCDIC + if (!dorange) + native_range = FALSE; /* \N{} is guessed to be Unicode */ +#endif Copy(str, d, len, char); d += len; SvREFCNT_dec(res); @@ -2220,20 +2473,45 @@ S_scan_const(pTHX_ char *start) #endif default_action: - /* If we started with encoded form, or already know we want it - and then encode the next character */ - if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) { + /* If we started with encoded form, or already know we want it, + then encode the next character */ + if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) { STRLEN len = 1; + + + /* One might think that it is wasted effort in the case of the + * source being utf8 (this_utf8 == TRUE) to take the next character + * in the source, convert it to an unsigned value, and then convert + * it back again. But the source has not been validated here. The + * routine that does the conversion checks for errors like + * malformed utf8 */ + const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s); const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv)); - s += len; - if (need > len) { - /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */ + if (!has_utf8) { + SvCUR_set(sv, d - SvPVX_const(sv)); + SvPOK_on(sv); + *d = '\0'; + /* See Note on sizing above. */ + sv_utf8_upgrade_flags_grow(sv, + SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, + need + (STRLEN)(send - s) + 1); + d = SvPVX(sv) + SvCUR(sv); + has_utf8 = TRUE; + } else if (need > len) { + /* encoded value larger than old, may need extra space (NOTE: + * SvCUR() is not set correctly here). See Note on sizing + * above. */ const STRLEN off = d - SvPVX_const(sv); - d = SvGROW(sv, SvLEN(sv) + (need-len)) + off; + d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off; } + s += len; + d = (char*)uvchr_to_utf8((U8*)d, nextuv); - has_utf8 = TRUE; +#ifdef EBCDIC + if (uv > 255 && !dorange) + native_range = FALSE; +#endif } else { *d++ = NATIVE_TO_NEED(has_utf8,*s++); @@ -2265,17 +2543,29 @@ S_scan_const(pTHX_ char *start) SvPV_shrink_to_cur(sv); } - /* return the substring (via yylval) only if we parsed anything */ + /* return the substring (via pl_yylval) only if we parsed anything */ if (s > PL_bufptr) { - if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) - sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"), - sv, NULL, - ( PL_lex_inwhat == OP_TRANS - ? "tr" - : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) - ? "s" - : "qq"))); - yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); + if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) { + const char *const key = PL_lex_inpat ? "qr" : "q"; + const STRLEN keylen = PL_lex_inpat ? 2 : 1; + const char *type; + STRLEN typelen; + + if (PL_lex_inwhat == OP_TRANS) { + type = "tr"; + typelen = 2; + } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) { + type = "s"; + typelen = 1; + } else { + type = "qq"; + typelen = 2; + } + + sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL, + type, typelen); + } + pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); } else SvREFCNT_dec(sv); return s; @@ -2306,6 +2596,9 @@ STATIC int S_intuit_more(pTHX_ register char *s) { dVAR; + + PERL_ARGS_ASSERT_INTUIT_MORE; + if (PL_lex_brackets) return TRUE; if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{')) @@ -2389,7 +2682,7 @@ S_intuit_more(pTHX_ register char *s) if (s[1]) { if (strchr("wds]",s[1])) weight += 100; - else if (seen['\''] || seen['"']) + else if (seen[(U8)'\''] || seen[(U8)'"']) weight += 1; else if (strchr("rnftbxcav",s[1])) weight += 40; @@ -2421,7 +2714,7 @@ S_intuit_more(pTHX_ register char *s) while (isALPHA(*s)) *d++ = *s++; *d = '\0'; - if (keyword(tmpbuf, d - tmpbuf)) + if (keyword(tmpbuf, d - tmpbuf, 0)) weight -= 150; } if (un_char == last_un_char + 1) @@ -2471,6 +2764,8 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) int soff; #endif + PERL_ARGS_ASSERT_INTUIT_METHOD; + if (gv) { if (SvTYPE(gv) == SVt_PVGV && GvIO(gv)) return 0; @@ -2485,7 +2780,7 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) } } } else - gv = 0; + gv = NULL; } s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); /* start is the beginning of the possible filehandle/object, @@ -2494,20 +2789,21 @@ 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); #endif s = PEEKSPACE(s); -#ifdef PERLMAD +#ifdef PERL_MAD start = SvPVX(PL_linestr) + len; #endif PL_bufptr = start; PL_expect = XREF; return *s == '(' ? FUNCMETH : METHOD; } - if (!keyword(tmpbuf, len)) { + if (!keyword(tmpbuf, len, 0)) { if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') { len -= 2; tmpbuf[len] = '\0'; @@ -2520,7 +2816,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 @@ -2546,29 +2842,6 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) return 0; } -/* - * S_incl_perldb - * Return a string of Perl code to load the debugger. If PERL5DB - * is set, it will return the contents of that, otherwise a - * compile-time require of perl5db.pl. - */ - -STATIC const char* -S_incl_perldb(pTHX) -{ - dVAR; - if (PL_perldb) { - const char * const pdb = PerlEnv_getenv("PERL5DB"); - - if (pdb) - return pdb; - SETERRNO(0,SS_NORMAL); - return "BEGIN { require 'perl5db.pl' }"; - } - return ""; -} - - /* Encoded script support. filter_add() effectively inserts a * 'pre-processing' function into the current source input stream. * Note that the filter function only applies to the current source file @@ -2593,6 +2866,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) @@ -2601,7 +2877,8 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */ IoFLAGS(datasv) |= IOf_FAKE_DIRP; DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n", - IoANY(datasv), SvPV_nolen(datasv))); + FPTR2DPTR(void *, IoANY(datasv)), + SvPV_nolen(datasv))); av_unshift(PL_rsfp_filters, 1); av_store(PL_rsfp_filters, 0, datasv) ; return(datasv); @@ -2615,10 +2892,13 @@ Perl_filter_del(pTHX_ filter_t funcp) dVAR; SV *datasv; + PERL_ARGS_ASSERT_FILTER_DEL; + #ifdef DEBUGGING - DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, 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)); @@ -2642,22 +2922,36 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) dVAR; filter_t funcp; SV *datasv = NULL; + /* This API is bad. It should have been using unsigned int for maxlen. + Not sure if we want to change the API, but if not we should sanity + check the value here. */ + const unsigned int correct_length + = maxlen < 0 ? +#ifdef PERL_MICRO + 0x7FFFFFFF +#else + INT_MAX +#endif + : maxlen; - if (!PL_rsfp_filters) + PERL_ARGS_ASSERT_FILTER_READ; + + 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. */ /* Note that we append to the line. This is handy. */ DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: from rsfp\n", idx)); - if (maxlen) { + if (correct_length) { /* Want a block */ int len ; const int old_len = SvCUR(buf_sv); /* ensure buf_sv is large enough */ - SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ; - if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){ + SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ; + if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, + correct_length)) <= 0) { if (PerlIO_error(PL_rsfp)) return -1; /* error */ else @@ -2680,23 +2974,26 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: skipped (filter deleted)\n", idx)); - return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */ + return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */ } /* Get function pointer hidden within datasv */ funcp = DPTR2FPTR(filter_t, IoANY(datasv)); DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: via function %p (%s)\n", - idx, datasv, SvPV_nolen_const(datasv))); + idx, (void*)datasv, SvPV_nolen_const(datasv))); /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ /* Return: <0:error, =0:eof, >0:not eof */ - return (*funcp)(aTHX_ idx, buf_sv, maxlen); + return (*funcp)(aTHX_ idx, buf_sv, correct_length); } STATIC char * S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) { dVAR; + + PERL_ARGS_ASSERT_FILTER_GETS; + #ifdef PERL_CR_FILTER if (!PL_rsfp_filters) { filter_add(S_cr_textfilter,NULL); @@ -2715,11 +3012,13 @@ S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) } STATIC HV * -S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) +S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len) { dVAR; GV *gv; + PERL_ARGS_ASSERT_FIND_IN_MY_STASH; + if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__")) return PL_curstash; @@ -2731,14 +3030,39 @@ S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) } /* use constant CLASS => 'MyClass' */ - if ((gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV))) { - SV *sv; - if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) { - pkgname = SvPV_nolen_const(sv); - } + gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV); + if (gv && GvCV(gv)) { + SV * const sv = cv_const_sv(GvCV(gv)); + if (sv) + pkgname = SvPV_const(sv, len); } - return gv_stashpv(pkgname, FALSE); + return gv_stashpvn(pkgname, len, 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); + pl_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)))); + } } #ifdef PERL_MAD @@ -2779,9 +3103,9 @@ Perl_madlex(pTHX) if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */ if (!PL_thistoken) { if (PL_realtokenstart < 0 || !CopLINE(PL_curcop)) - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); else { - char *tstart = SvPVX(PL_linestr) + PL_realtokenstart; + char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart; PL_thistoken = newSVpvn(tstart, s - tstart); } } @@ -2849,8 +3173,8 @@ Perl_madlex(pTHX) case FUNC0SUB: case UNIOPSUB: case LSTOPSUB: - if (yylval.opval) - append_madprops(PL_thismad, yylval.opval, 0); + if (pl_yylval.opval) + append_madprops(PL_thismad, pl_yylval.opval, 0); PL_thismad = 0; return optype; @@ -2920,7 +3244,7 @@ Perl_madlex(pTHX) } /* Create new token struct. Note: opvals return early above. */ - yylval.tkval = newTOKEN(optype, yylval, PL_thismad); + pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad); PL_thismad = 0; return optype; } @@ -2929,6 +3253,9 @@ Perl_madlex(pTHX) STATIC char * S_tokenize_use(pTHX_ int is_use, char *s) { dVAR; + + PERL_ARGS_ASSERT_TOKENIZE_USE; + if (PL_expect != XSTATE) yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression", is_use ? "use" : "no")); @@ -2949,7 +3276,7 @@ S_tokenize_use(pTHX_ int is_use, char *s) { s = force_word(s,WORD,FALSE,TRUE,FALSE); s = force_version(s, FALSE); } - yylval.ival = is_use; + pl_yylval.ival = is_use; return s; } #ifdef DEBUGGING @@ -2997,6 +3324,13 @@ Perl_yylex(pTHX) STRLEN len; bool bof = FALSE; + /* orig_keyword, gvp, and gv are initialized here because + * jump to the label just_a_word_zero can bypass their + * initialization later. */ + I32 orig_keyword = 0; + GV *gv = NULL; + GV **gvp = NULL; + DEBUG_T( { SV* tmp = newSVpvs(""); PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n", @@ -3023,12 +3357,12 @@ Perl_yylex(pTHX) case LEX_KNOWNEXT: #ifdef PERL_MAD PL_lasttoke--; - yylval = PL_nexttoke[PL_lasttoke].next_val; + pl_yylval = PL_nexttoke[PL_lasttoke].next_val; if (PL_madskills) { PL_thismad = PL_nexttoke[PL_lasttoke].next_mad; PL_nexttoke[PL_lasttoke].next_mad = 0; if (PL_thismad && PL_thismad->mad_key == '_') { - PL_thiswhite = (SV*)PL_thismad->mad_val; + PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val); PL_thismad->mad_val = 0; mad_free(PL_thismad); PL_thismad = 0; @@ -3043,7 +3377,7 @@ Perl_yylex(pTHX) } #else PL_nexttoke--; - yylval = PL_nextval[PL_nexttoke]; + pl_yylval = PL_nextval[PL_nexttoke]; if (!PL_nexttoke) { PL_lex_state = PL_lex_defer; PL_expect = PL_lex_expect; @@ -3078,7 +3412,7 @@ Perl_yylex(pTHX) PL_lex_state = LEX_INTERPCONCAT; #ifdef PERL_MAD if (PL_madskills) - PL_thistoken = newSVpvn("\\E",2); + PL_thistoken = newSVpvs("\\E"); #endif } return REPORT(')'); @@ -3087,7 +3421,7 @@ Perl_yylex(pTHX) while (PL_bufptr != PL_bufend && PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') { if (!PL_thiswhite) - PL_thiswhite = newSVpvn("",0); + PL_thiswhite = newSVpvs(""); sv_catpvn(PL_thiswhite, PL_bufptr, 2); PL_bufptr += 2; } @@ -3105,7 +3439,7 @@ Perl_yylex(pTHX) if (s[1] == '\\' && s[2] == 'E') { #ifdef PERL_MAD if (!PL_thiswhite) - PL_thiswhite = newSVpvn("",0); + PL_thiswhite = newSVpvs(""); sv_catpvn(PL_thiswhite, PL_bufptr, 4); #endif PL_bufptr = s + 3; @@ -3144,8 +3478,10 @@ Perl_yylex(pTHX) else Perl_croak(aTHX_ "panic: yylex"); if (PL_madskills) { - SV* tmpsv = newSVpvn("",0); - Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s); + SV* const tmpsv = newSVpvs("\\ "); + /* replace the space with the character we want to escape + */ + SvPVX(tmpsv)[1] = *s; curmad('_', tmpsv); } PL_bufptr = s + 1; @@ -3158,7 +3494,7 @@ Perl_yylex(pTHX) if (PL_madskills) { if (PL_thistoken) sv_free(PL_thistoken); - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); } #endif /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ @@ -3204,7 +3540,7 @@ Perl_yylex(pTHX) if (PL_madskills) { if (PL_thistoken) sv_free(PL_thistoken); - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); } #endif /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ @@ -3230,7 +3566,7 @@ Perl_yylex(pTHX) if (PL_madskills) { if (PL_thistoken) sv_free(PL_thistoken); - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); } #endif return REPORT(')'); @@ -3256,8 +3592,8 @@ Perl_yylex(pTHX) if (!PL_lex_inpat) sv = tokeq(sv); else if ( PL_hints & HINT_NEW_RE ) - sv = new_constant(NULL, 0, "qr", sv, sv, "q"); - yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); + sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1); + pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); s = PL_bufend; } else { @@ -3273,7 +3609,7 @@ Perl_yylex(pTHX) if (PL_madskills) { curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr)); } - NEXTVAL_NEXTTOKE = yylval; + NEXTVAL_NEXTTOKE = pl_yylval; PL_expect = XTERM; force_next(THING); if (PL_lex_starts++) { @@ -3281,7 +3617,7 @@ Perl_yylex(pTHX) if (PL_madskills) { if (PL_thistoken) sv_free(PL_thistoken); - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); } #endif /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ @@ -3321,7 +3657,8 @@ Perl_yylex(pTHX) default: if (isIDFIRST_lazy_if(s,UTF)) goto keylookup; - Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255); + len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart); + Perl_croak(aTHX_ "Unrecognized character \\x%02X in column %d", *s & 255, (int) len + 1); case 4: case 26: goto fake_eof; /* emulate EOF on ^D or ^Z */ @@ -3334,9 +3671,10 @@ Perl_yylex(pTHX) PL_last_uni = 0; PL_last_lop = 0; if (PL_lex_brackets) { - yyerror(PL_lex_formbrack - ? "Format not terminated" - : "Missing right curly or square bracket"); + yyerror((const char *) + (PL_lex_formbrack + ? "Format not terminated" + : "Missing right curly or square bracket")); } DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Tokener got EOF\n"); @@ -3353,19 +3691,36 @@ Perl_yylex(pTHX) if (PL_madskills) PL_faketokens = 1; #endif - sv_setpv(PL_linestr,incl_perldb()); - if (SvCUR(PL_linestr)) - sv_catpvs(PL_linestr,";"); - if (PL_preambleav){ - while(AvFILLp(PL_preambleav) >= 0) { - SV *tmpsv = av_shift(PL_preambleav); - sv_catsv(PL_linestr, tmpsv); + if (PL_perldb) { + /* Generate a string of Perl code to load the debugger. + * If PERL5DB is set, it will return the contents of that, + * otherwise a compile-time require of perl5db.pl. */ + + const char * const pdb = PerlEnv_getenv("PERL5DB"); + + if (pdb) { + sv_setpv(PL_linestr, pdb); + sv_catpvs(PL_linestr,";"); + } else { + SETERRNO(0,SS_NORMAL); + sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };"); + } + } else + sv_setpvs(PL_linestr,""); + if (PL_preambleav) { + SV **svp = AvARRAY(PL_preambleav); + SV **const end = svp + AvFILLp(PL_preambleav); + while(svp <= end) { + sv_catsv(PL_linestr, *svp); + ++svp; sv_catpvs(PL_linestr, ";"); - sv_free(tmpsv); } - sv_free((SV*)PL_preambleav); + sv_free(MUTABLE_SV(PL_preambleav)); PL_preambleav = NULL; } + if (PL_minus_E) + sv_catpvs(PL_linestr, + "use feature ':5." STRINGIFY(PERL_VERSION) "';"); if (PL_minus_n || PL_minus_p) { sv_catpvs(PL_linestr, "LINE: while (<>) {"); if (PL_minus_l) @@ -3397,21 +3752,12 @@ Perl_yylex(pTHX) sv_catpvs(PL_linestr,"our @F=split(' ');"); } } - if (PL_minus_E) - sv_catpvs(PL_linestr,"use feature ':5.10';"); sv_catpvs(PL_linestr, "\n"); 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 || PERLDB_SAVESRC) && PL_curstash != PL_debstash) + update_debugger_info(PL_linestr, NULL, 0); goto retry; } do { @@ -3422,9 +3768,7 @@ Perl_yylex(pTHX) PL_realtokenstart = -1; #endif if (PL_rsfp) { - if (PL_preprocess && !PL_in_eval) - (void)PerlProc_pclose(PL_rsfp); - else if ((PerlIO *)PL_rsfp == PerlIO_stdin()) + if ((PerlIO *)PL_rsfp == PerlIO_stdin()) PerlIO_clearerr(PL_rsfp); else (void)PerlIO_close(PL_rsfp); @@ -3436,8 +3780,10 @@ Perl_yylex(pTHX) if (PL_madskills) PL_faketokens = 1; #endif - sv_setpv(PL_linestr,PL_minus_p - ? ";}continue{print;}" : ";}"); + if (PL_minus_p) + sv_setpvs(PL_linestr, ";}continue{print;}"); + else + sv_setpvs(PL_linestr, ";}"); 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; @@ -3446,7 +3792,7 @@ Perl_yylex(pTHX) } PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_last_lop = PL_last_uni = NULL; - sv_setpvn(PL_linestr,"",0); + sv_setpvs(PL_linestr,""); TOKEN(';'); /* not infinite loop because rsfp is NULL now */ } /* If it looks like the start of a BOM or raw UTF-16, @@ -3469,16 +3815,7 @@ Perl_yylex(pTHX) # endif # endif #endif -#ifdef FTELL_FOR_PIPE_IS_BROKEN - /* This loses the possibility to detect the bof - * situation on perl -P when the libc5 is being used. - * Workaround? Maybe attach some extra state to PL_rsfp? - */ - if (!PL_preprocess) - bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr); -#else bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr); -#endif if (bof) { PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); s = swallow_bom((U8*)s); @@ -3490,8 +3827,8 @@ Perl_yylex(pTHX) if (PL_madskills) sv_catsv(PL_thiswhite, PL_linestr); #endif - if (*s == '=' && strnEQ(s, "=cut", 4)) { - sv_setpvn(PL_linestr, "", 0); + if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) { + sv_setpvs(PL_linestr, ""); 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; @@ -3501,15 +3838,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 || PERLDB_SAVESRC) && 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) { @@ -3651,24 +3981,28 @@ Perl_yylex(pTHX) } #endif if (d) { - while (*d && !isSPACE(*d)) d++; - while (SPACE_OR_TAB(*d)) d++; + while (*d && !isSPACE(*d)) + d++; + while (SPACE_OR_TAB(*d)) + d++; if (*d++ == '-') { const bool switches_done = PL_doswitches; const U32 oldpdb = PL_perldb; const bool oldn = PL_minus_n; const bool oldp = PL_minus_p; + const char *d1 = d; do { - if (*d == 'M' || *d == 'm' || *d == 'C') { - const char * const m = d; - while (*d && !isSPACE(*d)) d++; + if (*d1 == 'M' || *d1 == 'm' || *d1 == 'C') { + const char * const m = d1; + while (*d1 && !isSPACE(*d1)) + d1++; Perl_croak(aTHX_ "Too late for \"-%.*s\" option", - (int)(d - m), m); + (int)(d1 - m), m); } - d = moreswitches(d); - } while (d); + d1 = moreswitches(d1); + } while (d1); if (PL_doswitches && !switches_done) { int argc = PL_origargc; char **argv = PL_origargv; @@ -3677,17 +4011,17 @@ Perl_yylex(pTHX) } while (argc && argv[0][0] == '-' && argv[0][1]); init_argv_symbols(argc,argv); } - if ((PERLDB_LINE && !oldpdb) || + if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) || ((PL_minus_n || PL_minus_p) && !(oldn || oldp))) /* if we have already added "LINE: while (<>) {", we must not do it again */ { - sv_setpvn(PL_linestr, "", 0); + sv_setpvs(PL_linestr, ""); 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; PL_preambled = FALSE; - if (PERLDB_LINE) + if (PERLDB_LINE || PERLDB_SAVESRC) (void)gv_fetchfile(PL_origfilename); goto retry; } @@ -3713,10 +4047,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': @@ -3778,9 +4113,9 @@ Perl_yylex(pTHX) Perl_croak(aTHX_ "panic: input overflow"); if (PL_madskills && CopLINE(PL_curcop) >= 1) { if (!PL_thiswhite) - PL_thiswhite = newSVpvn("",0); + PL_thiswhite = newSVpvs(""); if (CopLINE(PL_curcop) == 1) { - sv_setpvn(PL_thiswhite, "", 0); + sv_setpvs(PL_thiswhite, ""); PL_faketokens = 0; } sv_catpvn(PL_thiswhite, s, d - s); @@ -3810,9 +4145,7 @@ Perl_yylex(pTHX) if (strnEQ(s,"=>",2)) { s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE); - DEBUG_T( { S_printbuf(aTHX_ - "### Saw unary minus before =>, forcing word %s\n", s); - } ); + DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } ); OPERATOR('-'); /* unary minus */ } PL_last_uni = PL_oldbufptr; @@ -3941,7 +4274,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('%'); } @@ -3956,8 +4290,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); @@ -3996,13 +4329,13 @@ Perl_yylex(pTHX) attrs = NULL; while (isIDFIRST_lazy_if(s,UTF)) { I32 tmp; + SV *sv; d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); - if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) { + if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) { if (tmp < 0) tmp = -tmp; switch (tmp) { case KEY_or: case KEY_and: - case KEY_err: case KEY_for: case KEY_unless: case KEY_if: @@ -4013,6 +4346,7 @@ Perl_yylex(pTHX) break; } } + sv = newSVpvn(s, len); if (*d == '(') { d = scan_str(d,TRUE,TRUE); if (!d) { @@ -4023,11 +4357,11 @@ Perl_yylex(pTHX) yyerror("Unterminated attribute parameter in attribute list"); if (attrs) op_free(attrs); + sv_free(sv); return REPORT(0); /* EOF indicator */ } } if (PL_lex_stuff) { - SV *sv = newSVpvn(s, len); sv_catsv(sv, PL_lex_stuff); attrs = append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, sv)); @@ -4035,27 +4369,34 @@ Perl_yylex(pTHX) PL_lex_stuff = NULL; } else { - if (len == 6 && strnEQ(s, "unique", len)) { - if (PL_in_my == KEY_our) + if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) { + sv_free(sv); + if (PL_in_my == KEY_our) { #ifdef USE_ITHREADS - GvUNIQUE_on(cGVOPx_gv(yylval.opval)); + GvUNIQUE_on(cGVOPx_gv(pl_yylval.opval)); #else - /*EMPTY*/; /* skip to avoid loading attributes.pm */ + /* skip to avoid loading attributes.pm */ #endif + deprecate(":unique"); + } else Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables"); } /* NOTE: any CV attrs applied here need to be part of the CVf_BUILTIN_ATTRS define in cv.h! */ - else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len)) + else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) { + sv_free(sv); CvLVALUE_on(PL_compcv); - else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len)) + } + else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) { + sv_free(sv); CvLOCKED_on(PL_compcv); - else if (!PL_in_my && len == 6 && strnEQ(s, "method", len)) + } + else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) { + sv_free(sv); CvMETHOD_on(PL_compcv); - else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len)) - 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 @@ -4069,7 +4410,7 @@ Perl_yylex(pTHX) else attrs = append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, - newSVpvn(s, len))); + sv)); } s = PEEKSPACE(d); if (*s == ':' && s[1] != ':') @@ -4094,10 +4435,11 @@ Perl_yylex(pTHX) context messages from yyerror(). */ PL_bufptr = s; - yyerror( *s - ? Perl_form(aTHX_ "Invalid separator character " - "%c%c%c in attribute list", q, *s, q) - : "Unterminated attribute list" ); + yyerror( (const char *) + (*s + ? Perl_form(aTHX_ "Invalid separator character " + "%c%c%c in attribute list", q, *s, q) + : "Unterminated attribute list" ) ); if (attrs) op_free(attrs); OPERATOR(':'); @@ -4149,7 +4491,9 @@ Perl_yylex(pTHX) --PL_lex_brackets; if (PL_lex_state == LEX_INTERPNORMAL) { if (PL_lex_brackets == 0) { - if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>')) + if (*s == '-' && s[1] == '>') + PL_lex_state = LEX_INTERPENDMAYBE; + else if (*s != '[' && *s != '{') PL_lex_state = LEX_INTERPEND; } } @@ -4312,7 +4656,7 @@ Perl_yylex(pTHX) } break; } - yylval.ival = CopLINE(PL_curcop); + pl_yylval.ival = CopLINE(PL_curcop); if (isSPACE(*s) || *s == '#') PL_copline = NOLINE; /* invalidate current command line number */ TOKEN('{'); @@ -4334,8 +4678,8 @@ Perl_yylex(pTHX) #if 0 if (PL_madskills) { if (!PL_thiswhite) - PL_thiswhite = newSVpvn("",0); - sv_catpvn(PL_thiswhite,"}",1); + PL_thiswhite = newSVpvs(""); + sv_catpvs(PL_thiswhite,"}"); } #endif return yylex(); /* ignore fake brackets */ @@ -4359,7 +4703,7 @@ Perl_yylex(pTHX) force_next('}'); #ifdef PERL_MAD if (!PL_thistoken) - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); #endif TOKEN(';'); case '&': @@ -4372,7 +4716,7 @@ Perl_yylex(pTHX) && isIDFIRST_lazy_if(s,UTF)) { CopLINE_dec(PL_curcop); - Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi); + Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi); CopLINE_inc(PL_curcop); } BAop(OP_BIT_AND); @@ -4385,7 +4729,7 @@ Perl_yylex(pTHX) } else PREREF('&'); - yylval.ival = (OPpENTERSUB_AMPER<<8); + pl_yylval.ival = (OPpENTERSUB_AMPER<<8); TERM('&'); case '|': @@ -4433,7 +4777,7 @@ Perl_yylex(pTHX) #ifdef PERL_MAD if (PL_madskills) { if (!PL_thiswhite) - PL_thiswhite = newSVpvn("",0); + PL_thiswhite = newSVpvs(""); sv_catpvn(PL_thiswhite, PL_linestart, PL_bufend - PL_linestart); } @@ -4444,21 +4788,26 @@ Perl_yylex(pTHX) } } if (PL_lex_brackets < PL_lex_formbrack) { - const char *t; + const char *t = s; #ifdef PERL_STRICT_CR - for (t = s; SPACE_OR_TAB(*t); t++) ; + while (SPACE_OR_TAB(*t)) #else - for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ; + while (SPACE_OR_TAB(*t) || *t == '\r') #endif + t++; if (*t == '\n' || *t == '#') { s--; PL_expect = XBLOCK; goto leftbracket; } } - yylval.ival = 0; + pl_yylval.ival = 0; OPERATOR(ASSIGNOP); case '!': + if (PL_expect == XSTATE && s[1] == '!' && s[2] == '!') { + s += 3; + LOP(OP_DIE,XTERM); + } s++; { const char tmp = *s++; @@ -4517,7 +4866,7 @@ Perl_yylex(pTHX) const char tmp = *s++; if (tmp == '>') SHop(OP_RIGHT_SHIFT); - if (tmp == '=') + else if (tmp == '=') Rop(OP_GE); } s--; @@ -4560,9 +4909,9 @@ Perl_yylex(pTHX) /* This kludge not intended to be bulletproof. */ if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) { - yylval.opval = newSVOP(OP_CONST, 0, - newSViv(PL_compiling.cop_arybase)); - yylval.opval->op_private = OPpCONST_ARYBASE; + pl_yylval.opval = newSVOP(OP_CONST, 0, + newSViv(CopARYBASE_get(&PL_compiling))); + pl_yylval.opval->op_private = OPpCONST_ARYBASE; TERM(THING); } @@ -4577,10 +4926,10 @@ Perl_yylex(pTHX) if (*s == '[') { PL_tokenbuf[0] = '@'; if (ckWARN(WARN_SYNTAX)) { - char *t; - for(t = s + 1; - isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$'; - t++) ; + char *t = s+1; + + while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$') + t++; if (*t++ == ',') { PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */ while (t < PL_bufend && *t != ']') @@ -4598,13 +4947,16 @@ Perl_yylex(pTHX) && (t = strchr(s, '}')) && (t = strchr(t, '='))) { char tmpbuf[sizeof PL_tokenbuf]; - for (t++; isSPACE(*t); t++) ; + do { + t++; + } while (isSPACE(*t)); if (isIDFIRST_lazy_if(t,UTF)) { - STRLEN dummylen; + STRLEN len; t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, - &dummylen); - for (; isSPACE(*t); t++) ; - if (*t == ';' && get_cv(tmpbuf, FALSE)) + &len); + while (isSPACE(*t)) + t++; + if (*t == ';' && get_cvn_flags(tmpbuf, len, 0)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "You need to quote \"%s\"", tmpbuf); @@ -4626,7 +4978,7 @@ Perl_yylex(pTHX) char tmpbuf[sizeof PL_tokenbuf]; int t2; scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); - if ((t2 = keyword(tmpbuf, len))) { + if ((t2 = keyword(tmpbuf, len, 0))) { /* binary operators exclude handle interpretations */ switch (t2) { case -KEY_x: @@ -4707,10 +5059,14 @@ Perl_yylex(pTHX) AOPERATOR(DORDOR); } case '?': /* may either be conditional or pattern */ - if(PL_expect == XOPERATOR) { + if (PL_expect == XSTATE && s[1] == '?' && s[2] == '?') { + s += 3; + LOP(OP_WARN,XTERM); + } + if (PL_expect == XOPERATOR) { char tmp = *s++; if(tmp == '?') { - OPERATOR('?'); + OPERATOR('?'); } else { tmp = *s++; @@ -4749,16 +5105,20 @@ Perl_yylex(pTHX) PL_expect = XSTATE; goto rightbracket; } + if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') { + s += 3; + OPERATOR(YADAYADA); + } if (PL_expect == XOPERATOR || !isDIGIT(s[1])) { char tmp = *s++; if (*s == tmp) { s++; if (*s == tmp) { s++; - yylval.ival = OPf_SPECIAL; + pl_yylval.ival = OPf_SPECIAL; } else - yylval.ival = 0; + pl_yylval.ival = 0; OPERATOR(DOTDOT); } if (PL_expect != XOPERATOR) @@ -4768,15 +5128,15 @@ Perl_yylex(pTHX) /* FALL THROUGH */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': - s = scan_num(s, &yylval); - DEBUG_T( { S_printbuf(aTHX_ "### Saw number in %s\n", s); } ); + s = scan_num(s, &pl_yylval); + DEBUG_T( { printbuf("### Saw number in %s\n", s); } ); if (PL_expect == XOPERATOR) no_op("Number",s); TERM(THING); case '\'': s = scan_str(s,!!PL_madskills,FALSE); - DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } ); + DEBUG_T( { printbuf("### Saw string before %s\n", s); } ); if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; @@ -4787,13 +5147,13 @@ Perl_yylex(pTHX) no_op("String",s); } if (!s) - missingterm((char*)0); - yylval.ival = OP_CONST; + missingterm(NULL); + pl_yylval.ival = OP_CONST; TERM(sublex_start()); case '"': s = scan_str(s,!!PL_madskills,FALSE); - DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } ); + DEBUG_T( { printbuf("### Saw string before %s\n", s); } ); if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; @@ -4804,13 +5164,13 @@ Perl_yylex(pTHX) no_op("String",s); } if (!s) - missingterm((char*)0); - yylval.ival = OP_CONST; + missingterm(NULL); + pl_yylval.ival = OP_CONST; /* FIXME. I think that this can be const if char *d is replaced by more localised variables. */ for (d = SvPV(PL_lex_stuff, len); len; len--, d++) { if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) { - yylval.ival = OP_STRINGIFY; + pl_yylval.ival = OP_STRINGIFY; break; } } @@ -4818,13 +5178,12 @@ Perl_yylex(pTHX) case '`': s = scan_str(s,!!PL_madskills,FALSE); - DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } ); + DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } ); if (PL_expect == XOPERATOR) no_op("Backticks",s); if (!s) - missingterm((char*)0); - yylval.ival = OP_BACKTICK; - set_csh(); + missingterm(NULL); + readpipe_override(); TERM(sublex_start()); case '\\': @@ -4842,20 +5201,16 @@ Perl_yylex(pTHX) while (isDIGIT(*start) || *start == '_') start++; if (*start == '.' && isDIGIT(start[1])) { - s = scan_num(s, &yylval); + s = scan_num(s, &pl_yylval); TERM(THING); } /* avoid v123abc() or $h{v1}, allow C */ else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE || PL_expect == XTERMORDORDOR)) { - const char c = *start; - GV *gv; - *start = '\0'; - gv = gv_fetchpv(s, 0, SVt_PVCV); - *start = c; + GV *const gv = gv_fetchpvn_flags(s, start - s, 0, SVt_PVCV); if (!gv) { - s = scan_num(s, &yylval); + s = scan_num(s, &pl_yylval); TERM(THING); } } @@ -4898,9 +5253,10 @@ Perl_yylex(pTHX) keylookup: { I32 tmp; - I32 orig_keyword = 0; - GV *gv = NULL; - GV **gvp = NULL; + + orig_keyword = 0; + gv = NULL; + gvp = NULL; PL_bufptr = s; s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); @@ -4923,21 +5279,21 @@ Perl_yylex(pTHX) if (!tmp && PL_expect == XSTATE && d < PL_bufend && *d == ':' && *(d + 1) != ':') { s = d + 1; - yylval.pval = savepv(PL_tokenbuf); + pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf); CLINE; TOKEN(LABEL); } /* Check for keywords */ - tmp = keyword(PL_tokenbuf, len); + tmp = keyword(PL_tokenbuf, len, 0); /* Is this a word before a => operator? */ if (*d == '=' && d[1] == '>') { CLINE; - yylval.opval + pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len)); - yylval.opval->op_private = OPpCONST_BARE; + pl_yylval.opval->op_private = OPpCONST_BARE; TERM(WORD); } @@ -4956,7 +5312,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; @@ -4968,8 +5324,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 */ } @@ -5029,7 +5384,7 @@ Perl_yylex(pTHX) if (PL_expect == XOPERATOR) { if (PL_bufptr == PL_linestart) { CopLINE_dec(PL_curcop); - Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi); + Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi); CopLINE_inc(PL_curcop); } else @@ -5080,7 +5435,7 @@ Perl_yylex(pTHX) #ifdef PERL_MAD if (PL_madskills && !PL_thistoken) { char *start = SvPVX(PL_linestr) + PL_realtokenstart; - PL_thistoken = newSVpv(start,s - start); + PL_thistoken = newSVpvn(start,s - start); PL_realtokenstart = s - SvPVX(PL_linestr); } #endif @@ -5088,8 +5443,8 @@ Perl_yylex(pTHX) /* Presume this is going to be a bareword of some sort. */ CLINE; - yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); - yylval.opval->op_private = OPpCONST_BARE; + pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); + pl_yylval.opval->op_private = OPpCONST_BARE; /* UTF-8 package name? */ if (UTF && !IN_BYTES && is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv))) @@ -5111,7 +5466,7 @@ Perl_yylex(pTHX) /* Real typeglob, so get the real subroutine: */ ? GvCVu(gv) /* A proxy for a subroutine in this package? */ - : SvOK(gv) ? (CV *) gv : NULL) + : SvOK(gv) ? MUTABLE_CV(gv) : NULL) : NULL; /* See if it's the indirect object for a list operator. */ @@ -5168,9 +5523,9 @@ Perl_yylex(pTHX) /* Is this a word before a => operator? */ if (*s == '=' && s[1] == '>' && !pkgname) { CLINE; - sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf); + sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf); if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len)) - SvUTF8_on(((SVOP*)yylval.opval)->op_sv); + SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv); TERM(WORD); } @@ -5178,19 +5533,11 @@ Perl_yylex(pTHX) if (*s == '(') { CLINE; if (cv) { - for (d = s + 1; SPACE_OR_TAB(*d); d++) ; + d = s + 1; + while (SPACE_OR_TAB(*d)) + d++; if (*d == ')' && (sv = gv_const_sv(gv))) { s = d + 1; -#ifdef PERL_MAD - if (PL_madskills) { - char *par = SvPVX(PL_linestr) + PL_realtokenstart; - sv_catpvn(PL_thistoken, par, s - par); - if (PL_nextwhite) { - sv_free(PL_nextwhite); - PL_nextwhite = 0; - } - } -#endif goto its_constant; } } @@ -5201,17 +5548,17 @@ Perl_yylex(pTHX) } start_force(PL_curforce); #endif - NEXTVAL_NEXTTOKE.opval = yylval.opval; + NEXTVAL_NEXTTOKE.opval = pl_yylval.opval; PL_expect = XOPERATOR; #ifdef PERL_MAD if (PL_madskills) { PL_nextwhite = nextPL_nextwhite; curmad('X', PL_thistoken); - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); } #endif force_next(WORD); - yylval.ival = 0; + pl_yylval.ival = 0; TOKEN('&'); } @@ -5240,9 +5587,9 @@ Perl_yylex(pTHX) /* Check for a constant sub */ if ((sv = gv_const_sv(gv))) { its_constant: - SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv); - ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv); - yylval.opval->op_private = 0; + SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv); + ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv); + pl_yylval.opval->op_private = 0; TOKEN(WORD); } @@ -5255,9 +5602,9 @@ Perl_yylex(pTHX) cv = GvCV(gv); } - op_free(yylval.opval); - yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); - yylval.opval->op_private |= OPpENTERSUB_NOPAREN; + op_free(pl_yylval.opval); + pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); + pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN; PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_ENTERSUB; /* Is there a prototype? */ @@ -5265,18 +5612,21 @@ Perl_yylex(pTHX) #ifdef PERL_MAD cv && #endif - SvPOK(cv)) { + SvPOK(cv)) + { STRLEN protolen; - const char *proto = SvPV_const((SV*)cv, protolen); + const char *proto = SvPV_const(MUTABLE_SV(cv), protolen); if (!protolen) TERM(FUNC0SUB); - if (*proto == '$' && proto[1] == '\0') + if ((*proto == '$' || *proto == '_') && proto[1] == '\0') OPERATOR(UNIOPSUB); while (*proto == ';') proto++; if (*proto == '&' && *s == '{') { - sv_setpv(PL_subname, PL_curstash ? - "__ANON__" : "__ANON__::__ANON__"); + if (PL_curstash) + sv_setpvs(PL_subname, "__ANON__"); + else + sv_setpvs(PL_subname, "__ANON__::__ANON__"); PREBLOCK(LSTOPSUB); } } @@ -5287,12 +5637,12 @@ Perl_yylex(pTHX) PL_thiswhite = 0; } start_force(PL_curforce); - NEXTVAL_NEXTTOKE.opval = yylval.opval; + NEXTVAL_NEXTTOKE.opval = pl_yylval.opval; PL_expect = XTERM; if (PL_madskills) { PL_nextwhite = nextPL_nextwhite; curmad('X', PL_thistoken); - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); } force_next(WORD); TOKEN(NOAMP); @@ -5309,7 +5659,7 @@ Perl_yylex(pTHX) STRLEN tmplen; d = s; d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen); - if (!keyword(tmpbuf,tmplen)) + if (!keyword(tmpbuf, tmplen, 0)) probable_sub = 1; else { while (d < PL_bufend && isSPACE(*d)) @@ -5319,25 +5669,25 @@ Perl_yylex(pTHX) } } if (probable_sub) { - gv = gv_fetchpv(PL_tokenbuf, TRUE, SVt_PVCV); - op_free(yylval.opval); - yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); - yylval.opval->op_private |= OPpENTERSUB_NOPAREN; + gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV); + op_free(pl_yylval.opval); + pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); + pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN; PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_ENTERSUB; PL_nextwhite = PL_thiswhite; PL_thiswhite = 0; start_force(PL_curforce); - NEXTVAL_NEXTTOKE.opval = yylval.opval; + NEXTVAL_NEXTTOKE.opval = pl_yylval.opval; PL_expect = XTERM; PL_nextwhite = nextPL_nextwhite; curmad('X', PL_thistoken); - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); force_next(WORD); TOKEN(NOAMP); } #else - NEXTVAL_NEXTTOKE.opval = yylval.opval; + NEXTVAL_NEXTTOKE.opval = pl_yylval.opval; PL_expect = XTERM; force_next(WORD); TOKEN(NOAMP); @@ -5346,14 +5696,16 @@ Perl_yylex(pTHX) /* Call it a bare word */ + bareword: if (PL_hints & HINT_STRICT_SUBS) - yylval.opval->op_private |= OPpCONST_STRICT; + pl_yylval.opval->op_private |= OPpCONST_STRICT; else { - bareword: if (lastchar != '-') { if (ckWARN(WARN_RESERVED)) { - for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ; - if (!*d && !gv_stashpv(PL_tokenbuf,FALSE)) + d = PL_tokenbuf; + while (isLOWER(*d)) + d++; + if (!*d && !gv_stashpv(PL_tokenbuf, 0)) Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved, PL_tokenbuf); } @@ -5374,17 +5726,17 @@ Perl_yylex(pTHX) } case KEY___FILE__: - yylval.opval = (OP*)newSVOP(OP_CONST, 0, + pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0)); TERM(THING); case KEY___LINE__: - yylval.opval = (OP*)newSVOP(OP_CONST, 0, + pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop))); TERM(THING); case KEY___PACKAGE__: - yylval.opval = (OP*)newSVOP(OP_CONST, 0, + pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, (PL_curstash ? newSVhek(HvNAME_HEK(PL_curstash)) : &PL_sv_undef)); @@ -5411,9 +5763,7 @@ Perl_yylex(pTHX) #endif /* Mark this internal pseudo-handle as clean */ IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT; - if (PL_preprocess) - IoTYPE(GvIOp(gv)) = IoTYPE_PIPE; - else if ((PerlIO*)PL_rsfp == PerlIO_stdin()) + if ((PerlIO*)PL_rsfp == PerlIO_stdin()) IoTYPE(GvIOp(gv)) = IoTYPE_STD; else IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY; @@ -5464,7 +5814,7 @@ Perl_yylex(pTHX) PUTBACK; PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, Perl_form(aTHX_ ":encoding(%"SVf")", - name)); + SVfARG(name))); FREETMPS; LEAVE; } @@ -5475,14 +5825,14 @@ Perl_yylex(pTHX) if (PL_realtokenstart >= 0) { char *tstart = SvPVX(PL_linestr) + PL_realtokenstart; if (!PL_endwhite) - PL_endwhite = newSVpvn("",0); + PL_endwhite = newSVpvs(""); sv_catsv(PL_endwhite, PL_thiswhite); PL_thiswhite = 0; sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart); PL_realtokenstart = -1; } while ((s = filter_gets(PL_endwhite, PL_rsfp, - SvCUR(PL_endwhite))) != Nullch) ; + SvCUR(PL_endwhite))) != NULL) ; } #endif PL_rsfp = NULL; @@ -5493,6 +5843,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: @@ -5507,7 +5858,7 @@ Perl_yylex(pTHX) s += 2; d = s; s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); - if (!(tmp = keyword(PL_tokenbuf, len))) + if (!(tmp = keyword(PL_tokenbuf, len, 0))) Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf); if (tmp < 0) tmp = -tmp; @@ -5623,10 +5974,10 @@ Perl_yylex(pTHX) s = force_word(s,WORD,TRUE,TRUE,FALSE); if (orig_keyword == KEY_do) { orig_keyword = 0; - yylval.ival = 1; + pl_yylval.ival = 1; } else - yylval.ival = 0; + pl_yylval.ival = 0; OPERATOR(DO); case KEY_die: @@ -5654,7 +6005,7 @@ Perl_yylex(pTHX) PREBLOCK(ELSE); case KEY_elsif: - yylval.ival = CopLINE(PL_curcop); + pl_yylval.ival = CopLINE(PL_curcop); OPERATOR(ELSIF); case KEY_eq: @@ -5676,9 +6027,6 @@ Perl_yylex(pTHX) case KEY_eof: UNI(OP_EOF); - case KEY_err: - OPERATOR(DOROP); - case KEY_exp: UNI(OP_EXP); @@ -5686,7 +6034,6 @@ Perl_yylex(pTHX) UNI(OP_EACH); case KEY_exec: - set_csh(); LOP(OP_EXEC,XREF); case KEY_endhostent: @@ -5709,7 +6056,7 @@ Perl_yylex(pTHX) case KEY_for: case KEY_foreach: - yylval.ival = CopLINE(PL_curcop); + pl_yylval.ival = CopLINE(PL_curcop); s = SKIPSPACE1(s); if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) { char *p = s; @@ -5847,18 +6194,17 @@ Perl_yylex(pTHX) FUN0(OP_GETLOGIN); case KEY_given: - yylval.ival = CopLINE(PL_curcop); + pl_yylval.ival = CopLINE(PL_curcop); OPERATOR(GIVEN); case KEY_glob: - set_csh(); LOP(OP_GLOB,XTERM); case KEY_hex: UNI(OP_HEX); case KEY_if: - yylval.ival = CopLINE(PL_curcop); + pl_yylval.ival = CopLINE(PL_curcop); OPERATOR(IF); case KEY_index: @@ -5890,7 +6236,7 @@ Perl_yylex(pTHX) UNI(OP_LCFIRST); case KEY_local: - yylval.ival = 0; + pl_yylval.ival = 0; OPERATOR(LOCAL); case KEY_length: @@ -5944,7 +6290,8 @@ Perl_yylex(pTHX) case KEY_our: case KEY_my: - PL_in_my = tmp; + case KEY_state: + PL_in_my = (U16)tmp; s = SKIPSPACE1(s); if (isIDFIRST_lazy_if(s,UTF)) { #ifdef PERL_MAD @@ -5957,7 +6304,7 @@ Perl_yylex(pTHX) if (!PL_in_my_stash) { char tmpbuf[1024]; PL_bufptr = s; - sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf); + my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf); yyerror(tmpbuf); } #ifdef PERL_MAD @@ -5968,7 +6315,7 @@ Perl_yylex(pTHX) } #endif } - yylval.ival = 1; + pl_yylval.ival = 1; OPERATOR(MY); case KEY_next: @@ -5992,8 +6339,10 @@ Perl_yylex(pTHX) s = SKIPSPACE1(s); if (isIDFIRST_lazy_if(s,UTF)) { const char *t; - for (d = s; isALNUM_lazy_if(d,UTF); d++) ; - for (t=d; *t && isSPACE(*t); t++) ; + for (d = s; isALNUM_lazy_if(d,UTF);) + d++; + for (t=d; isSPACE(*t);) + t++; if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE) /* [perl #16184] */ && !(t[0] == '=' && t[1] == '>') @@ -6007,7 +6356,7 @@ Perl_yylex(pTHX) LOP(OP_OPEN,XTERM); case KEY_or: - yylval.ival = OP_OR; + pl_yylval.ival = OP_OR; OPERATOR(OROP); case KEY_ord: @@ -6052,8 +6401,8 @@ Perl_yylex(pTHX) case KEY_q: s = scan_str(s,!!PL_madskills,FALSE); if (!s) - missingterm((char*)0); - yylval.ival = OP_CONST; + missingterm(NULL); + pl_yylval.ival = OP_CONST; TERM(sublex_start()); case KEY_quotemeta: @@ -6062,7 +6411,7 @@ Perl_yylex(pTHX) case KEY_qw: s = scan_str(s,!!PL_madskills,FALSE); if (!s) - missingterm((char*)0); + missingterm(NULL); PL_expect = XOPERATOR; force_next(')'); if (SvCUR(PL_lex_stuff)) { @@ -6070,9 +6419,10 @@ Perl_yylex(pTHX) int warned = 0; d = SvPV_force(PL_lex_stuff, len); while (len) { - SV *sv; - for (; isSPACE(*d) && len; --len, ++d) ; + for (; isSPACE(*d) && len; --len, ++d) + /**/; if (len) { + SV *sv; const char *b = d; if (!warned && ckWARN(WARN_QW)) { for (; !isSPACE(*d) && len; --len, ++d) { @@ -6089,11 +6439,10 @@ Perl_yylex(pTHX) } } else { - for (; !isSPACE(*d) && len; --len, ++d) ; + for (; !isSPACE(*d) && len; --len, ++d) + /**/; } - sv = newSVpvn(b, d-b); - if (DO_UTF8(PL_lex_stuff)) - SvUTF8_on(sv); + sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff)); words = append_elem(OP_LIST, words, newSVOP(OP_CONST, 0, tokeq(sv))); } @@ -6114,8 +6463,8 @@ Perl_yylex(pTHX) case KEY_qq: s = scan_str(s,!!PL_madskills,FALSE); if (!s) - missingterm((char*)0); - yylval.ival = OP_STRINGIFY; + missingterm(NULL); + pl_yylval.ival = OP_STRINGIFY; if (SvIVX(PL_lex_stuff) == '\'') SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */ TERM(sublex_start()); @@ -6127,9 +6476,8 @@ Perl_yylex(pTHX) case KEY_qx: s = scan_str(s,!!PL_madskills,FALSE); if (!s) - missingterm((char*)0); - yylval.ival = OP_BACKTICK; - set_csh(); + missingterm(NULL); + readpipe_override(); TERM(sublex_start()); case KEY_return: @@ -6146,16 +6494,16 @@ 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"); } if (orig_keyword == KEY_require) { orig_keyword = 0; - yylval.ival = 1; + pl_yylval.ival = 1; } else - yylval.ival = 0; + pl_yylval.ival = 0; PL_expect = XTERM; PL_bufptr = s; PL_last_uni = PL_oldbufptr; @@ -6189,12 +6537,10 @@ Perl_yylex(pTHX) UNI(OP_READDIR); case KEY_readline: - set_csh(); UNIDOR(OP_READLINE); case KEY_readpipe: - set_csh(); - UNI(OP_BACKTICK); + UNIDOR(OP_BACKTICK); case KEY_rewinddir: UNI(OP_REWINDDIR); @@ -6213,7 +6559,7 @@ Perl_yylex(pTHX) case KEY_s: s = scan_subst(s); - if (yylval.opval) + if (pl_yylval.opval) TERM(sublex_start()); else TOKEN(1); /* force error */ @@ -6346,7 +6692,7 @@ Perl_yylex(pTHX) char tmpbuf[sizeof PL_tokenbuf]; SSize_t tboffset = 0; expectation attrful; - bool have_name, have_proto, bad_proto; + bool have_name, have_proto; const int key = tmp; #ifdef PERL_MAD @@ -6366,7 +6712,7 @@ Perl_yylex(pTHX) (*s == ':' && s[1] == ':')) { #ifdef PERL_MAD - SV *nametoke; + SV *nametoke = NULL; #endif PL_expect = XBLOCK; @@ -6378,8 +6724,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,"::"); @@ -6405,7 +6751,7 @@ Perl_yylex(pTHX) Perl_croak(aTHX_ "Missing name in \"my sub\""); PL_expect = XTERMBLOCK; attrful = XATTRTERM; - sv_setpvn(PL_subname,"?",1); + sv_setpvs(PL_subname,"?"); have_name = FALSE; } @@ -6426,6 +6772,14 @@ Perl_yylex(pTHX) /* Look for a prototype */ if (*s == '(') { char *p; + bool bad_proto = FALSE; + bool in_brackets = FALSE; + char greedy_proto = ' '; + bool proto_after_greedy_proto = FALSE; + bool must_be_last = FALSE; + bool underscore = FALSE; + bool seen_underscore = FALSE; + const bool warnsyntax = ckWARN(WARN_SYNTAX); s = scan_str(s,!!PL_madskills,FALSE); if (!s) @@ -6433,19 +6787,51 @@ Perl_yylex(pTHX) /* strip spaces and check for bad characters */ d = SvPVX(PL_lex_stuff); tmp = 0; - bad_proto = FALSE; for (p = d; *p; ++p) { if (!isSPACE(*p)) { d[tmp++] = *p; - if (!strchr("$@%*;[]&\\", *p)) - bad_proto = TRUE; + + if (warnsyntax) { + if (must_be_last) + proto_after_greedy_proto = TRUE; + if (!strchr("$@%*;[]&\\_", *p)) { + bad_proto = TRUE; + } + else { + if ( underscore ) { + if ( *p != ';' ) + bad_proto = TRUE; + underscore = FALSE; + } + if ( *p == '[' ) { + in_brackets = TRUE; + } + else if ( *p == ']' ) { + in_brackets = FALSE; + } + else if ( (*p == '@' || *p == '%') && + ( tmp < 2 || d[tmp-2] != '\\' ) && + !in_brackets ) { + must_be_last = TRUE; + greedy_proto = *p; + } + else if ( *p == '_' ) { + underscore = seen_underscore = TRUE; + } + } + } } } d[tmp] = '\0'; - if (bad_proto && ckWARN(WARN_SYNTAX)) + if (proto_after_greedy_proto) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "Prototype after '%c' for %"SVf" : %s", + greedy_proto, SVfARG(PL_subname), d); + if (bad_proto) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Illegal character in prototype for %"SVf" : %s", - PL_subname, d); + "Illegal character %sin prototype for %"SVf" : %s", + seen_underscore ? "after '_' " : "", + SVfARG(PL_subname), d); SvCUR_set(PL_lex_stuff, tmp); have_proto = TRUE; @@ -6457,7 +6843,7 @@ Perl_yylex(pTHX) CURMAD('Q', PL_thisclose); NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff); - PL_lex_stuff = Nullsv; + PL_lex_stuff = NULL; force_next(THING); s = SKIPSPACE2(s,tmpwhite); @@ -6474,14 +6860,14 @@ 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, PL_subname); + Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname)); } #ifdef PERL_MAD start_force(0); if (tmpwhite) { if (PL_madskills) - curmad('^', newSVpvn("",0)); + curmad('^', newSVpvs("")); CURMAD('_', tmpwhite); } force_next(0); @@ -6496,8 +6882,10 @@ Perl_yylex(pTHX) } #endif if (!have_name) { - sv_setpv(PL_subname, - PL_curstash ? "__ANON__" : "__ANON__::__ANON__"); + if (PL_curstash) + sv_setpvs(PL_subname, "__ANON__"); + else + sv_setpvs(PL_subname, "__ANON__::__ANON__"); TOKEN(ANONSUB); } #ifndef PERL_MAD @@ -6510,7 +6898,6 @@ Perl_yylex(pTHX) } case KEY_system: - set_csh(); LOP(OP_SYSTEM,XREF); case KEY_symlink: @@ -6566,11 +6953,11 @@ Perl_yylex(pTHX) UNI(OP_UNTIE); case KEY_until: - yylval.ival = CopLINE(PL_curcop); + pl_yylval.ival = CopLINE(PL_curcop); OPERATOR(UNTIL); case KEY_unless: - yylval.ival = CopLINE(PL_curcop); + pl_yylval.ival = CopLINE(PL_curcop); OPERATOR(UNLESS); case KEY_unlink: @@ -6602,11 +6989,11 @@ Perl_yylex(pTHX) LOP(OP_VEC,XTERM); case KEY_when: - yylval.ival = CopLINE(PL_curcop); + pl_yylval.ival = CopLINE(PL_curcop); OPERATOR(WHEN); case KEY_while: - yylval.ival = CopLINE(PL_curcop); + pl_yylval.ival = CopLINE(PL_curcop); OPERATOR(WHILE); case KEY_warn: @@ -6643,7 +7030,7 @@ Perl_yylex(pTHX) goto just_a_word; case KEY_xor: - yylval.ival = OP_XOR; + pl_yylval.ival = OP_XOR; OPERATOR(OROP); case KEY_y: @@ -6661,9 +7048,12 @@ S_pending_ident(pTHX) { dVAR; register char *d; - register I32 tmp = 0; + PADOFFSET tmp = 0; /* pit holds the identifier we read and pending_ident is reset */ char pit = PL_pending_ident; + const STRLEN tokenbuf_len = strlen(PL_tokenbuf); + /* All routes through this function want to know if there is a colon. */ + const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len); PL_pending_ident = 0; /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */ @@ -6678,18 +7068,19 @@ S_pending_ident(pTHX) */ if (PL_in_my) { if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */ - if (strchr(PL_tokenbuf,':')) + if (has_colon) yyerror(Perl_form(aTHX_ "No package name allowed for " "variable %s in \"our\"", PL_tokenbuf)); tmp = allocmy(PL_tokenbuf); } else { - if (strchr(PL_tokenbuf,':')) - yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf)); + if (has_colon) + yyerror(Perl_form(aTHX_ PL_no_myglob, + PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf)); - yylval.opval = newOP(OP_PADANY, 0); - yylval.opval->op_targ = allocmy(PL_tokenbuf); + pl_yylval.opval = newOP(OP_PADANY, 0); + pl_yylval.opval->op_targ = allocmy(PL_tokenbuf); return PRIVATEREF; } } @@ -6706,7 +7097,7 @@ S_pending_ident(pTHX) (although why you'd do that is anyone's guess). */ - if (!strchr(PL_tokenbuf,':')) { + if (!has_colon) { if (!PL_in_my) tmp = pad_findmy(PL_tokenbuf); if (tmp != NOT_IN_PAD) { @@ -6717,9 +7108,9 @@ S_pending_ident(pTHX) HEK * const stashname = HvNAME_HEK(stash); SV * const sym = newSVhek(stashname); sv_catpvs(sym, "::"); - sv_catpv(sym, PL_tokenbuf+1); - yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym); - yylval.opval->op_private = OPpCONST_ENTERED; + sv_catpvn(sym, PL_tokenbuf+1, tokenbuf_len - 1); + pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym); + pl_yylval.opval->op_private = OPpCONST_ENTERED; gv_fetchsv(sym, (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) @@ -6748,8 +7139,8 @@ S_pending_ident(pTHX) } } - yylval.opval = newOP(OP_PADANY, 0); - yylval.opval->op_targ = tmp; + pl_yylval.opval = newOP(OP_PADANY, 0); + pl_yylval.opval->op_targ = tmp; return PRIVATEREF; } } @@ -6760,9 +7151,14 @@ S_pending_ident(pTHX) table. */ if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) { - GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV); + GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 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), @@ -6772,10 +7168,11 @@ S_pending_ident(pTHX) } /* build ops for a bareword */ - yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0)); - yylval.opval->op_private = OPpCONST_ENTERED; - gv_fetchpv( - PL_tokenbuf+1, + pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1, + tokenbuf_len - 1)); + pl_yylval.opval->op_private = OPpCONST_ENTERED; + gv_fetchpvn_flags( + PL_tokenbuf + 1, tokenbuf_len - 1, /* If the identifier refers to a stash, don't autovivify it. * Change 24660 had the side effect of causing symbol table * hashes to always be defined, even if they were freshly @@ -6788,7 +7185,9 @@ S_pending_ident(pTHX) * tests still give the expected answers, even though what * they're actually testing has now changed subtly. */ - (*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':' + (*PL_tokenbuf == '%' + && *(d = PL_tokenbuf + tokenbuf_len - 1) == ':' + && d[-1] == ':' ? 0 : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD), ((PL_tokenbuf[0] == '$') ? SVt_PV @@ -6802,9 +7201,12 @@ S_pending_ident(pTHX) */ I32 -Perl_keyword (pTHX_ const char *name, I32 len) +Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords) { - dVAR; + dVAR; + + PERL_ARGS_ASSERT_KEYWORD; + switch (len) { case 1: /* 5 tokens of length 1 */ @@ -7071,14 +7473,6 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; - case 'r': - if (name[2] == 'r') - { /* err */ - return (FEATURE_IS_ENABLED("err") ? -KEY_err : 0); - } - - goto unknown; - case 'x': if (name[2] == 'p') { /* exp */ @@ -7213,7 +7607,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) case 'a': if (name[2] == 'y') { /* say */ - return (FEATURE_IS_ENABLED("say") ? -KEY_say : 0); + return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0); } goto unknown; @@ -7711,46 +8105,46 @@ Perl_keyword (pTHX_ const char *name, I32 len) switch (name[1]) { case 'a': - switch (name[2]) - { - case 'i': - if (name[3] == 't') - { /* wait */ - return -KEY_wait; - } + switch (name[2]) + { + case 'i': + if (name[3] == 't') + { /* wait */ + return -KEY_wait; + } - goto unknown; + goto unknown; - case 'r': - if (name[3] == 'n') - { /* warn */ - return -KEY_warn; - } + case 'r': + if (name[3] == 'n') + { /* warn */ + return -KEY_warn; + } - goto unknown; + goto unknown; - default: - goto unknown; - } + default: + goto unknown; + } case 'h': if (name[2] == 'e' && name[3] == 'n') { /* when */ - return (FEATURE_IS_ENABLED("switch") ? KEY_when : 0); - } + return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0); + } - goto unknown; + goto unknown; - default: - goto unknown; - } + default: + goto unknown; + } default: goto unknown; } - case 5: /* 38 tokens of length 5 */ + case 5: /* 39 tokens of length 5 */ switch (name[0]) { case 'B': @@ -7807,20 +8201,20 @@ Perl_keyword (pTHX_ const char *name, I32 len) { case 'l': if (name[2] == 'e' && - name[3] == 's' && - name[4] == 's') - { /* bless */ - return -KEY_bless; - } + name[3] == 's' && + name[4] == 's') + { /* bless */ + return -KEY_bless; + } - goto unknown; + goto unknown; case 'r': if (name[2] == 'e' && name[3] == 'a' && name[4] == 'k') { /* break */ - return (FEATURE_IS_ENABLED("switch") ? -KEY_break : 0); + return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0); } goto unknown; @@ -7948,7 +8342,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) name[3] == 'e' && name[4] == 'n') { /* given */ - return (FEATURE_IS_ENABLED("switch") ? KEY_given : 0); + return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0); } goto unknown; @@ -8110,14 +8504,29 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; case 't': - if (name[2] == 'u' && - name[3] == 'd' && - name[4] == 'y') - { /* study */ - return KEY_study; - } + switch (name[2]) + { + case 'a': + if (name[3] == 't' && + name[4] == 'e') + { /* state */ + return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0); + } - goto unknown; + goto unknown; + + case 'u': + if (name[3] == 'd' && + name[4] == 'y') + { /* study */ + return KEY_study; + } + + goto unknown; + + default: + goto unknown; + } default: goto unknown; @@ -8769,24 +9178,24 @@ Perl_keyword (pTHX_ const char *name, I32 len) name[5] == 'l' && name[6] == 't') { /* default */ - return (FEATURE_IS_ENABLED("switch") ? KEY_default : 0); + return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0); } goto unknown; case 'i': if (name[4] == 'n' && - name[5] == 'e' && - name[6] == 'd') - { /* defined */ - return KEY_defined; - } + name[5] == 'e' && + name[6] == 'd') + { /* defined */ + return KEY_defined; + } - goto unknown; + goto unknown; - default: - goto unknown; - } + default: + goto unknown; + } } goto unknown; @@ -9523,9 +9932,24 @@ Perl_keyword (pTHX_ const char *name, I32 len) 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' && @@ -10170,20 +10594,26 @@ STATIC void S_checkcomma(pTHX_ const char *s, const char *name, const char *what) { dVAR; - const char *w; + + PERL_ARGS_ASSERT_CHECKCOMMA; if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ if (ckWARN(WARN_SYNTAX)) { int level = 1; + const char *w; for (w = s+2; *w && level; w++) { if (*w == '(') ++level; else if (*w == ')') --level; } - if (*w) - for (; *w && isSPACE(*w); w++) ; - if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */ + while (isSPACE(*w)) + ++w; + /* 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); } @@ -10195,14 +10625,14 @@ S_checkcomma(pTHX_ const char *s, const char *name, const char *what) while (s < PL_bufend && isSPACE(*s)) s++; if (isIDFIRST_lazy_if(s,UTF)) { - w = s++; + const char * const w = s++; while (isALNUM_lazy_if(s,UTF)) s++; while (s < PL_bufend && isSPACE(*s)) s++; if (*s == ',') { GV* gv; - if (keyword(w, s - w)) + if (keyword(w, s - w, 0)) return; gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV); @@ -10219,8 +10649,8 @@ S_checkcomma(pTHX_ const char *s, const char *name, const char *what) and type is used with error messages only. */ STATIC SV * -S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv, - const char *type) +S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, + SV *sv, SV *pv, const char *type, STRLEN typelen) { dVAR; dSP; HV * const table = GvHV(PL_hintgv); /* ^H */ @@ -10229,12 +10659,15 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv, SV *cv, *typesv; const char *why1 = "", *why2 = "", *why3 = ""; + PERL_ARGS_ASSERT_NEW_CONSTANT; + if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { SV *msg; - why2 = strEQ(key,"charnames") - ? "(possibly a missing \"use charnames ...\")" - : ""; + why2 = (const char *) + (strEQ(key,"charnames") + ? "(possibly a missing \"use charnames ...\")" + : ""); msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s", (type ? type: "undef"), why2); @@ -10253,7 +10686,7 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv, SvREFCNT_dec(msg); return sv; } - cvp = hv_fetch(table, key, strlen(key), FALSE); + cvp = hv_fetch(table, key, keylen, FALSE); if (!cvp || !SvOK(*cvp)) { why1 = "$^H{"; why2 = key; @@ -10263,9 +10696,9 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv, sv_2mortal(sv); /* Parent created it permanently */ cv = *cvp; if (!pv && s) - pv = sv_2mortal(newSVpvn(s, len)); + pv = newSVpvn_flags(s, len, SVs_TEMP); if (type && pv) - typesv = sv_2mortal(newSVpv(type, 0)); + typesv = newSVpvn_flags(type, typelen, SVs_TEMP); else typesv = &PL_sv_undef; @@ -10322,28 +10755,33 @@ S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_packag dVAR; register char *d = dest; register char * const e = d + destlen - 3; /* two-character token, ending NUL */ + + PERL_ARGS_ASSERT_SCAN_WORD; + for (;;) { if (d >= e) Perl_croak(aTHX_ ident_too_long); if (isALNUM(*s)) /* UTF handled below */ *d++ = *s++; - else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) { + else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) { *d++ = ':'; *d++ = ':'; s++; } - else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') { + else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) { *d++ = *s++; *d++ = *s++; } else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { char *t = s + UTF8SKIP(s); + size_t len; while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t)) t += UTF8SKIP(t); - if (d + (t - s) > e) + len = t - s; + if (d + len > e) Perl_croak(aTHX_ ident_too_long); - Copy(s, d, t - s, char); - d += t - s; + Copy(s, d, len, char); + d += len; s = t; } else { @@ -10363,6 +10801,8 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL register char *d = dest; register char * const e = d + destlen + 3; /* two-character token, ending NUL */ + PERL_ARGS_ASSERT_SCAN_IDENT; + if (isSPACE(*s)) s = PEEKSPACE(s); if (isDIGIT(*s)) { @@ -10456,10 +10896,13 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL Perl_croak(aTHX_ ident_too_long); } *d = '\0'; - while (s < send && SPACE_OR_TAB(*s)) s++; + while (s < send && SPACE_OR_TAB(*s)) + s++; if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { - if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) { - const char *brack = *s == '[' ? "[...]" : "{...}"; + if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) { + const char * const brack = + (const char *) + ((*s == '[') ? "[...]" : "{...}"); Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of %c{%s%s} resolved to %c%s%s", funny, dest, brack, funny, dest, brack); @@ -10488,12 +10931,13 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL PL_lex_state = LEX_INTERPEND; PL_expect = XREF; } - if (funny == '#') - funny = '@'; if (PL_lex_state == LEX_NORMAL) { if (ckWARN(WARN_AMBIGUOUS) && - (keyword(dest, d - dest) || get_cv(dest, FALSE))) + (keyword(dest, d - dest, 0) + || get_cvn_flags(dest, d - dest, 0))) { + if (funny == '#') + funny = '@'; Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of %c{%s} resolved to %c%s", funny, dest, funny, dest); @@ -10513,21 +10957,19 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL void Perl_pmflag(pTHX_ U32* pmfl, int ch) { + PERL_ARGS_ASSERT_PMFLAG; + 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) { + const 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 * @@ -10536,22 +10978,46 @@ S_scan_pat(pTHX_ char *start, I32 type) dVAR; PMOP *pm; char *s = scan_str(start,!!PL_madskills,FALSE); - const char * const valid_flags = (type == OP_QR) ? "iomsx" : "iogcmsx"; + const char * const valid_flags = + (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS); #ifdef PERL_MAD char *modstart; #endif + PERL_ARGS_ASSERT_SCAN_PAT; if (!s) { const char * const delimiter = skipspace(start); - Perl_croak(aTHX_ *delimiter == '?' - ? "Search pattern not terminated or ternary operator parsed as search pattern" - : "Search pattern not terminated" ); + Perl_croak(aTHX_ + (const char *) + (*delimiter == '?' + ? "Search pattern not terminated or ternary operator parsed as search pattern" + : "Search pattern not terminated" )); } 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((const SV *)PL_curstash, PERL_MAGIC_symtab); + U32 elements; + if (!mg) { + mg = sv_magicext(MUTABLE_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 @@ -10567,13 +11033,12 @@ 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; + pl_yylval.ival = OP_MATCH; return s; } @@ -10589,7 +11054,9 @@ S_scan_subst(pTHX_ char *start) char *modstart; #endif - yylval.ival = OP_NULL; + PERL_ARGS_ASSERT_SCAN_SUBST; + + pl_yylval.ival = OP_NULL; s = scan_str(start,!!PL_madskills,FALSE); @@ -10631,11 +11098,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; @@ -10660,19 +11127,24 @@ S_scan_subst(pTHX_ char *start) PL_sublex_info.super_bufend = PL_bufend; PL_multi_end = 0; pm->op_pmflags |= PMf_EVAL; - while (es-- > 0) - sv_catpv(repl, es ? "eval " : "do "); + while (es-- > 0) { + if (es) + sv_catpvs(repl, "eval "); + else + sv_catpvs(repl, "do "); + } sv_catpvs(repl, "{"); sv_catsv(repl, PL_lex_repl); + if (strchr(SvPVX(PL_lex_repl), '#')) + sv_catpvs(repl, "\n"); sv_catpvs(repl, "}"); SvEVALED_on(repl); SvREFCNT_dec(PL_lex_repl); PL_lex_repl = repl; } - pm->op_pmpermflags = pm->op_pmflags; PL_lex_op = (OP*)pm; - yylval.ival = OP_SUBST; + pl_yylval.ival = OP_SUBST; return s; } @@ -10683,14 +11155,16 @@ S_scan_trans(pTHX_ char *start) register char* s; OP *o; short *tbl; - I32 squash; - I32 del; - I32 complement; + U8 squash; + U8 del; + U8 complement; #ifdef PERL_MAD char *modstart; #endif - yylval.ival = OP_NULL; + PERL_ARGS_ASSERT_SCAN_TRANS; + + pl_yylval.ival = OP_NULL; s = scan_str(start,!!PL_madskills,FALSE); if (!s) @@ -10744,7 +11218,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| @@ -10752,7 +11226,7 @@ S_scan_trans(pTHX_ char *start) (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0); PL_lex_op = o; - yylval.ival = OP_TRANS; + pl_yylval.ival = OP_TRANS; #ifdef PERL_MAD if (PL_madskills) { @@ -10787,12 +11261,16 @@ S_scan_heredoc(pTHX_ register char *s) PL_realtokenstart = -1; #endif + PERL_ARGS_ASSERT_SCAN_HEREDOC; + s += 2; d = PL_tokenbuf; e = PL_tokenbuf + sizeof PL_tokenbuf - 1; if (!outer) *d++ = '\n'; - for (peek = s; SPACE_OR_TAB(*peek); peek++) ; + peek = s; + while (SPACE_OR_TAB(*peek)) + peek++; if (*peek == '`' || *peek == '\'' || *peek =='"') { s = peek; term = *s++; @@ -10855,7 +11333,7 @@ S_scan_heredoc(pTHX_ register char *s) #ifdef PERL_MAD found_newline = 0; #endif - if ( outer || !(found_newline = memchr(s, '\n', PL_bufend - s)) ) { + if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) { herewas = newSVpvn(s,PL_bufend-s); } else { @@ -10884,8 +11362,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); @@ -10956,7 +11434,7 @@ S_scan_heredoc(pTHX_ register char *s) PL_last_lop = PL_last_uni = NULL; } else - sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */ + sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */ while (s >= PL_bufend) { /* multiple line string? */ #ifdef PERL_MAD if (PL_madskills) { @@ -10993,15 +11471,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 || PERLDB_SAVESRC) && 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 ) = ' '; @@ -11028,14 +11499,14 @@ retval: sv_recode_to_utf8(tmpstr, PL_encoding); } PL_lex_stuff = tmpstr; - yylval.ival = op_type; + pl_yylval.ival = op_type; return s; } /* scan_inputsymbol takes: current position in input buffer returns: new position in input buffer - side-effects: yylval and lex_op are set. + side-effects: pl_yylval and lex_op are set. This code handles: @@ -11055,10 +11526,11 @@ S_scan_inputsymbol(pTHX_ char *start) register char *s = start; /* current position in buffer */ char *end; I32 len; - char *d = PL_tokenbuf; /* start of temp holding space */ const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */ + PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL; + end = strchr(s, '\n'); if (!end) end = PL_bufend; @@ -11068,7 +11540,7 @@ S_scan_inputsymbol(pTHX_ char *start) or if it didn't end, or if we see a newline */ - if (len >= sizeof PL_tokenbuf) + if (len >= (I32)sizeof PL_tokenbuf) Perl_croak(aTHX_ "Excessively long <> operator"); if (s >= end) Perl_croak(aTHX_ "Unterminated <> operator"); @@ -11095,8 +11567,7 @@ S_scan_inputsymbol(pTHX_ char *start) */ if (d - PL_tokenbuf != len) { - yylval.ival = OP_GLOB; - set_csh(); + pl_yylval.ival = OP_GLOB; s = scan_str(start,!!PL_madskills,FALSE); if (!s) Perl_croak(aTHX_ "Glob not terminated"); @@ -11119,7 +11590,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; @@ -11127,12 +11598,11 @@ S_scan_inputsymbol(pTHX_ char *start) filehandle */ if (*d == '$') { - I32 tmp; - /* try to find it in the pad for this block, otherwise find add symbol table ops */ - if ((tmp = pad_findmy(d)) != NOT_IN_PAD) { + const PADOFFSET tmp = pad_findmy(d); + if (tmp != NOT_IN_PAD) { if (PAD_COMPNAME_FLAGS_isOUR(tmp)) { HV * const stash = PAD_COMPNAME_OURSTASH(tmp); HEK * const stashname = HvNAME_HEK(stash); @@ -11172,8 +11642,8 @@ intro_sym: } if (!readline_overriden) PL_lex_op->op_flags |= OPf_SPECIAL; - /* we created the ops in PL_lex_op, so make yylval.ival a null op */ - yylval.ival = OP_NULL; + /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */ + pl_yylval.ival = OP_NULL; } /* If it's none of the above, it must be a literal filehandle @@ -11186,7 +11656,7 @@ intro_sym: newGVOP(OP_GV, 0, gv), newCVREF(0, newGVOP(OP_GV, 0, gv_readline)))) : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv)); - yylval.ival = OP_NULL; + pl_yylval.ival = OP_NULL; } } @@ -11242,7 +11712,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) { dVAR; SV *sv; /* scalar value: string */ - char *tmps; /* temp string, used for delimiter matching */ + 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 */ @@ -11251,12 +11721,14 @@ 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; #endif + PERL_ARGS_ASSERT_SCAN_STR; + /* skip space before the delimiter */ if (isSPACE(*s)) { s = PEEKSPACE(s); @@ -11298,8 +11770,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 */ @@ -11352,9 +11824,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 == '\\') { @@ -11373,7 +11843,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; } @@ -11480,7 +11950,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) */ #ifdef PERL_MAD if (PL_madskills) { - char *tstart = SvPVX(PL_linestr) + stuffstart; + char * const tstart = SvPVX(PL_linestr) + stuffstart; if (PL_thisstuff) sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart); else @@ -11500,15 +11970,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 || PERLDB_SAVESRC) && 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); @@ -11520,11 +11983,12 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) if (!PL_encoding || UTF) { #ifdef PERL_MAD if (PL_madskills) { - char *tstart = SvPVX(PL_linestr) + stuffstart; + char * const tstart = SvPVX(PL_linestr) + stuffstart; + const int len = s - tstart; if (PL_thisstuff) - sv_catpvn(PL_thisstuff, tstart, s - tstart); + sv_catpvn(PL_thisstuff, tstart, len); else - PL_thisstuff = newSVpvn(tstart, s - tstart); + PL_thisstuff = newSVpvn(tstart, len); if (!PL_thisclose && !keep_delims) PL_thisclose = newSVpvn(s,termlen); } @@ -11537,11 +12001,12 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) #ifdef PERL_MAD else { if (PL_madskills) { - char *tstart = SvPVX(PL_linestr) + stuffstart; + char * const tstart = SvPVX(PL_linestr) + stuffstart; + const int len = s - tstart - termlen; if (PL_thisstuff) - sv_catpvn(PL_thisstuff, tstart, s - tstart - termlen); + sv_catpvn(PL_thisstuff, tstart, len); else - PL_thisstuff = newSVpvn(tstart, s - tstart - termlen); + PL_thisstuff = newSVpvn(tstart, len); if (!PL_thisclose && !keep_delims) PL_thisclose = newSVpvn(s - termlen,termlen); } @@ -11573,7 +12038,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) scan_num takes: pointer to position in buffer returns: pointer to new position in buffer - side-effects: builds ops for the constant in yylval.op + side-effects: builds ops for the constant in pl_yylval.op Read a number in any of the formats that Perl accepts: @@ -11604,6 +12069,8 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) const char *lastub = NULL; /* position of last underbar */ static char const number_too_long[] = "Number too long"; + PERL_ARGS_ASSERT_SCAN_NUM; + /* We use the first character to decide what type of number this is */ switch (*s) { @@ -11783,9 +12250,9 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) } if (just_zero && (PL_hints & HINT_NEW_INTEGER)) sv = new_constant(start, s - start, "integer", - sv, NULL, NULL); + sv, NULL, NULL, 0); else if (PL_hints & HINT_NEW_BINARY) - sv = new_constant(start, s - start, "binary", sv, NULL, NULL); + sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0); } break; @@ -11948,18 +12415,20 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) sv_setnv(sv, nv); } - if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : - (PL_hints & HINT_NEW_INTEGER) ) - sv = new_constant(PL_tokenbuf, d - PL_tokenbuf, - (floatit ? "float" : "integer"), - sv, NULL, NULL); + if ( floatit + ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) { + const char *const key = floatit ? "float" : "integer"; + const STRLEN keylen = floatit ? 5 : 7; + sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf, + key, keylen, sv, NULL, NULL, 0); + } break; /* if it starts with a v, it could be a v-string */ case 'v': vstring: sv = newSV(5); /* preallocate storage space */ - s = scan_vstring(s,sv); + s = scan_vstring(s, PL_bufend, sv); break; } @@ -11984,20 +12453,25 @@ S_scan_formline(pTHX_ register char *s) bool eofmt = FALSE; #ifdef PERL_MAD char *tokenstart = s; - SV* savewhite; - + SV* savewhite = NULL; + if (PL_madskills) { savewhite = PL_thiswhite; PL_thiswhite = 0; } #endif + PERL_ARGS_ASSERT_SCAN_FORMLINE; + while (!needargs) { if (*s == '.') { + t = s+1; #ifdef PERL_STRICT_CR - for (t = s+1;SPACE_OR_TAB(*t); t++) ; + while (SPACE_OR_TAB(*t)) + t++; #else - for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ; + while (SPACE_OR_TAB(*t) || *t == '\r') + t++; #endif if (*t == '\n' || t == PL_bufend) { eofmt = TRUE; @@ -12101,20 +12575,6 @@ S_scan_formline(pTHX_ register char *s) return s; } -STATIC void -S_set_csh(pTHX) -{ -#ifdef CSH - dVAR; - if (!PL_cshlen) - PL_cshlen = strlen(PL_cshname); -#else -#if defined(USE_ITHREADS) - PERL_UNUSED_CONTEXT; -#endif -#endif -} - I32 Perl_start_subparse(pTHX_ I32 is_format, U32 flags) { @@ -12129,13 +12589,12 @@ 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 = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV)); CvFLAGS(PL_compcv) |= flags; PL_subline = CopLINE(PL_curcop); CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB); - CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv); + CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv)); CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax; return oldsavestack_ix; @@ -12144,10 +12603,13 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) #ifdef __SC__ #pragma segment Perl_yylex #endif -int -Perl_yywarn(pTHX_ const char *s) +static int +S_yywarn(pTHX_ const char *const s) { dVAR; + + PERL_ARGS_ASSERT_YYWARN; + PL_in_eval |= EVAL_WARNONLY; yyerror(s); PL_in_eval &= ~EVAL_WARNONLY; @@ -12155,13 +12617,16 @@ Perl_yywarn(pTHX_ const char *s) } int -Perl_yyerror(pTHX_ const char *s) +Perl_yyerror(pTHX_ const char *const s) { dVAR; const char *where = NULL; const char *context = NULL; int contlen = -1; SV *msg; + int yychar = PL_parser->yychar; + + PERL_ARGS_ASSERT_YYERROR; if (!yychar || (yychar == ';' && !PL_rsfp)) where = "at EOF"; @@ -12210,11 +12675,13 @@ Perl_yyerror(pTHX_ const char *s) where = "within string"; } else { - SV * const where_sv = sv_2mortal(newSVpvs("next char ")); + SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP); if (yychar < 32) Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar)); - else if (isPRINT_LC(yychar)) - Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar); + else if (isPRINT_LC(yychar)) { + const char string = yychar; + sv_catpvn(where_sv, &string, 1); + } else Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255); where = SvPVX_const(where_sv); @@ -12232,14 +12699,16 @@ Perl_yyerror(pTHX_ const char *s) (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start); PL_multi_end = 0; } - if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg); + if (PL_in_eval & EVAL_WARNONLY) { + if (ckWARN_d(WARN_SYNTAX)) + 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", - ERRSV, OutCopFILE(PL_curcop)); + SVfARG(ERRSV), OutCopFILE(PL_curcop)); else Perl_croak(aTHX_ "%s has too many errors.\n", OutCopFILE(PL_curcop)); @@ -12257,6 +12726,9 @@ S_swallow_bom(pTHX_ U8 *s) { dVAR; const STRLEN slen = SvCUR(PL_linestr); + + PERL_ARGS_ASSERT_SWALLOW_BOM; + switch (s[0]) { case 0xFF: if (s[1] == 0xFE) { @@ -12344,6 +12816,15 @@ S_swallow_bom(pTHX_ U8 *s) goto utf16be; } } +#ifdef EBCDIC + case 0xDD: + if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) { + if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n"); + s += 4; /* UTF-8 */ + } + break; +#endif + default: if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) { /* Leading bytes @@ -12356,23 +12837,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 @@ -12383,7 +12847,8 @@ utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) const I32 count = FILTER_READ(idx+1, sv, maxlen); DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter(%p): %d %d (%d)\n", - utf16_textfilter, idx, maxlen, (int) count)); + FPTR2DPTR(void *, utf16_textfilter), + idx, maxlen, (int) count)); if (count) { U8* tmps; I32 newlen; @@ -12405,7 +12870,8 @@ utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen) const I32 count = FILTER_READ(idx+1, sv, maxlen); DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16rev_textfilter(%p): %d %d (%d)\n", - utf16rev_textfilter, idx, maxlen, (int) count)); + FPTR2DPTR(void *, utf16rev_textfilter), + idx, maxlen, (int) count)); if (count) { U8* tmps; I32 newlen; @@ -12427,28 +12893,32 @@ 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 *const e, SV *sv) { dVAR; const char *pos = s; const char *start = s; + + PERL_ARGS_ASSERT_SCAN_VSTRING; + 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; @@ -12458,22 +12928,20 @@ Perl_scan_vstring(pTHX_ const char *s, SV *sv) if (!isALPHA(*pos)) { U8 tmpbuf[UTF8_MAXBYTES+1]; - if (*s == 'v') s++; /* get past 'v' */ + if (*s == 'v') + s++; /* get past 'v' */ - sv_setpvn(sv, "", 0); + sv_setpvs(sv, ""); for (;;) { + /* this is atoi() that tolerates underscores */ U8 *tmpend; UV rev = 0; - { - /* this is atoi() that tolerates underscores */ - const char *end = pos; - UV mult = 1; - while (--end >= s) { - UV orev; - if (*end == '_') - continue; - orev = rev; + const char *end = pos; + UV mult = 1; + while (--end >= s) { + if (*end != '_') { + const UV orev = rev; rev += (*end - '0') * mult; mult *= 10; if (orev > rev && ckWARN_d(WARN_OVERFLOW)) @@ -12490,13 +12958,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);