X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=951c1ca84cfe93b0ccd331a677e5881ac50c1d77;hb=6ed34527c34dc05915ae3caa982e733d04613a1e;hp=7587df186047a526bf92af517ef874a9e2448a2c;hpb=5ab7ff9835a1d1b96af849579ce604bb74101206;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 7587df1..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, 2007, 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"] */ /* @@ -26,7 +28,7 @@ #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 yylval (PL_parser->yylval) +#define pl_yylval (PL_parser->yylval) /* YYINITDEPTH -- initial size of the parser's stacks. */ #define YYINITDEPTH 200 @@ -227,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 @@ -239,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. @@ -259,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; \ @@ -273,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 == '(') \ @@ -283,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 @@ -368,15 +370,19 @@ static struct debug_tokens { { WHEN, TOKENTYPE_IVAL, "WHEN" }, { WHILE, TOKENTYPE_IVAL, "WHILE" }, { WORD, TOKENTYPE_OPVAL, "WORD" }, + { 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; @@ -403,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))); } } @@ -435,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); } @@ -458,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; @@ -482,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 @@ -535,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'; @@ -567,11 +572,14 @@ S_missingterm(pTHX_ char *s) * Check whether the named feature is enabled. */ STATIC bool -S_feature_is_enabled(pTHX_ const 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[8 + MAX_FEATURE_LEN] = "feature_"; + + PERL_ARGS_ASSERT_FEATURE_IS_ENABLED; + assert(namelen <= MAX_FEATURE_LEN); memcpy(&he_name[8], name, namelen); @@ -583,14 +591,16 @@ S_feature_is_enabled(pTHX_ const 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 */ @@ -600,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); @@ -616,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') { @@ -692,12 +707,13 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter) #else 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() - : (AV*)SvREFCNT_inc(oparser->rsfp_filters); + : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters)); Newx(parser->lex_brackstack, 120, char); Newx(parser->lex_casestack, 12, char); @@ -734,13 +750,15 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter) 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->rsfp != parser->old_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); @@ -783,6 +801,8 @@ S_incline(pTHX_ const char *s) const char *n; const char *e; + PERL_ARGS_ASSERT_INCLINE; + CopLINE_inc(PL_curcop); if (*s++ != '#') return; @@ -804,6 +824,8 @@ S_incline(pTHX_ const char *s) 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, '"'))) { @@ -878,8 +900,8 @@ S_incline(pTHX_ const char *s) gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE); /* adjust ${"::_mad_key == '^') { (*where)->mad_key = slot; - sv_free((SV*)((*where)->mad_val)); + sv_free(MUTABLE_SV(((*where)->mad_val))); (*where)->mad_val = (void*)sv; } else @@ -1323,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); @@ -1344,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; } @@ -1377,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) || @@ -1421,6 +1461,9 @@ STATIC void S_force_ident(pTHX_ register const char *s, int kind) { dVAR; + + PERL_ARGS_ASSERT_FORCE_IDENT; + if (*s) { const STRLEN len = strlen(s); OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len)); @@ -1453,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; @@ -1487,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; @@ -1503,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); @@ -1557,6 +1605,8 @@ S_tokeq(pTHX_ SV *sv) STRLEN len = 0; SV *pv = sv; + PERL_ARGS_ASSERT_TOKEQ; + if (!SvLEN(sv)) goto finish; @@ -1570,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 == '\\') { @@ -1607,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. * @@ -1625,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; } @@ -1639,13 +1687,11 @@ 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) @@ -1655,7 +1701,7 @@ S_sublex_start(pTHX) else if (op_type == OP_BACKTICK && PL_lex_op) { /* readpipe() vas overriden */ cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff); - yylval.opval = PL_lex_op; + pl_yylval.opval = PL_lex_op; PL_lex_op = NULL; PL_lex_stuff = NULL; return THING; @@ -1668,7 +1714,7 @@ S_sublex_start(pTHX) PL_expect = XTERM; if (PL_lex_op) { - yylval.opval = PL_lex_op; + pl_yylval.opval = PL_lex_op; PL_lex_op = NULL; return PMFUNC; } @@ -1752,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; } @@ -1798,7 +1844,7 @@ S_sublex_done(pTHX) PL_thiswhite = 0; } if (PL_thistoken) - sv_setpvn(PL_thistoken,"",0); + sv_setpvs(PL_thistoken,""); else PL_realtokenstart = -1; } @@ -1825,7 +1871,7 @@ S_sublex_done(pTHX) Returns a pointer to the character scanned up to. If this is advanced from the start pointer supplied (i.e. if anything was successfully parsed), will leave an OP for the substring scanned - 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: @@ -1886,7 +1932,9 @@ S_sublex_done(pTHX) 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) */ @@ -1896,19 +1944,40 @@ 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 + 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 */ has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF); @@ -2123,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 */ @@ -2175,18 +2249,18 @@ S_scan_const(pTHX_ char *start) 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 == '{') { @@ -2201,67 +2275,47 @@ 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 |= @@ -2282,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 == '{') { @@ -2297,7 +2352,8 @@ 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; @@ -2335,22 +2391,24 @@ 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) @@ -2415,20 +2473,41 @@ 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; @@ -2464,7 +2543,7 @@ 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 ) ) { const char *const key = PL_lex_inpat ? "qr" : "q"; @@ -2486,7 +2565,7 @@ S_scan_const(pTHX_ char *start) sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL, type, typelen); } - yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); + pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); } else SvREFCNT_dec(sv); return s; @@ -2517,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] == '{')) @@ -2682,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; @@ -2808,6 +2892,8 @@ 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(void*, funcp))); @@ -2848,6 +2934,8 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) #endif : maxlen; + PERL_ARGS_ASSERT_FILTER_READ; + if (!PL_parser || !PL_rsfp_filters) return -1; if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */ @@ -2903,6 +2991,9 @@ 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); @@ -2926,6 +3017,8 @@ 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; @@ -2957,7 +3050,7 @@ S_readpipe_override(pTHX) { GV **gvp; GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV); - yylval.ival = OP_BACKTICK; + pl_yylval.ival = OP_BACKTICK; if ((gv_readpipe && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)) || @@ -3080,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; @@ -3151,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; } @@ -3160,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")); @@ -3180,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 @@ -3261,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; @@ -3281,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; @@ -3497,7 +3593,7 @@ Perl_yylex(pTHX) sv = tokeq(sv); else if ( PL_hints & HINT_NEW_RE ) sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1); - yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); + pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); s = PL_bufend; } else { @@ -3513,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++) { @@ -3611,16 +3707,20 @@ Perl_yylex(pTHX) } } else sv_setpvs(PL_linestr,""); - if (PL_preambleav){ - while(AvFILLp(PL_preambleav) >= 0) { - SV *tmpsv = av_shift(PL_preambleav); - sv_catsv(PL_linestr, tmpsv); + 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) @@ -3652,13 +3752,11 @@ 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) + if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) update_debugger_info(PL_linestr, NULL, 0); goto retry; } @@ -3670,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); @@ -3696,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, @@ -3719,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); @@ -3741,7 +3828,7 @@ Perl_yylex(pTHX) sv_catsv(PL_thiswhite, PL_linestr); #endif if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) { - 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; @@ -3751,7 +3838,7 @@ Perl_yylex(pTHX) incline(s); } while (PL_doextract); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; - if (PERLDB_LINE && PL_curstash != PL_debstash) + 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; @@ -3924,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; } @@ -4028,7 +4115,7 @@ Perl_yylex(pTHX) if (!PL_thiswhite) 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); @@ -4286,7 +4373,7 @@ Perl_yylex(pTHX) 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 /* skip to avoid loading attributes.pm */ #endif @@ -4569,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('{'); @@ -4592,7 +4679,7 @@ Perl_yylex(pTHX) if (PL_madskills) { if (!PL_thiswhite) PL_thiswhite = newSVpvs(""); - sv_catpvn(PL_thiswhite,"}",1); + sv_catpvs(PL_thiswhite,"}"); } #endif return yylex(); /* ignore fake brackets */ @@ -4629,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); @@ -4642,7 +4729,7 @@ Perl_yylex(pTHX) } else PREREF('&'); - yylval.ival = (OPpENTERSUB_AMPER<<8); + pl_yylval.ival = (OPpENTERSUB_AMPER<<8); TERM('&'); case '|': @@ -4714,9 +4801,13 @@ Perl_yylex(pTHX) 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++; @@ -4818,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, + pl_yylval.opval = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling))); - yylval.opval->op_private = OPpCONST_ARYBASE; + pl_yylval.opval->op_private = OPpCONST_ARYBASE; TERM(THING); } @@ -4968,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++; @@ -5010,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) @@ -5029,7 +5128,7 @@ 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); + s = scan_num(s, &pl_yylval); DEBUG_T( { printbuf("### Saw number in %s\n", s); } ); if (PL_expect == XOPERATOR) no_op("Number",s); @@ -5049,7 +5148,7 @@ Perl_yylex(pTHX) } if (!s) missingterm(NULL); - yylval.ival = OP_CONST; + pl_yylval.ival = OP_CONST; TERM(sublex_start()); case '"': @@ -5066,12 +5165,12 @@ Perl_yylex(pTHX) } if (!s) missingterm(NULL); - yylval.ival = OP_CONST; + 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; } } @@ -5102,7 +5201,7 @@ 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 */ @@ -5111,7 +5210,7 @@ Perl_yylex(pTHX) || PL_expect == XTERMORDORDOR)) { 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); } } @@ -5180,7 +5279,7 @@ Perl_yylex(pTHX) if (!tmp && PL_expect == XSTATE && d < PL_bufend && *d == ':' && *(d + 1) != ':') { s = d + 1; - yylval.pval = CopLABEL_alloc(PL_tokenbuf); + pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf); CLINE; TOKEN(LABEL); } @@ -5191,10 +5290,10 @@ Perl_yylex(pTHX) /* 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); } @@ -5285,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 @@ -5344,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))) @@ -5367,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. */ @@ -5424,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); } @@ -5449,7 +5548,7 @@ 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) { @@ -5459,7 +5558,7 @@ Perl_yylex(pTHX) } #endif force_next(WORD); - yylval.ival = 0; + pl_yylval.ival = 0; TOKEN('&'); } @@ -5488,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); } @@ -5503,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? */ @@ -5516,7 +5615,7 @@ Perl_yylex(pTHX) 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 == '_') && proto[1] == '\0') @@ -5538,7 +5637,7 @@ 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; @@ -5571,15 +5670,15 @@ Perl_yylex(pTHX) } if (probable_sub) { gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV); - op_free(yylval.opval); - yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); - yylval.opval->op_private |= OPpENTERSUB_NOPAREN; + 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); @@ -5588,7 +5687,7 @@ Perl_yylex(pTHX) TOKEN(NOAMP); } #else - NEXTVAL_NEXTTOKE.opval = yylval.opval; + NEXTVAL_NEXTTOKE.opval = pl_yylval.opval; PL_expect = XTERM; force_next(WORD); TOKEN(NOAMP); @@ -5597,10 +5696,10 @@ 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)) { d = PL_tokenbuf; @@ -5627,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)); @@ -5664,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; @@ -5877,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: @@ -5908,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: @@ -5959,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; @@ -6097,7 +6194,7 @@ 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: @@ -6107,7 +6204,7 @@ Perl_yylex(pTHX) UNI(OP_HEX); case KEY_if: - yylval.ival = CopLINE(PL_curcop); + pl_yylval.ival = CopLINE(PL_curcop); OPERATOR(IF); case KEY_index: @@ -6139,7 +6236,7 @@ Perl_yylex(pTHX) UNI(OP_LCFIRST); case KEY_local: - yylval.ival = 0; + pl_yylval.ival = 0; OPERATOR(LOCAL); case KEY_length: @@ -6218,7 +6315,7 @@ Perl_yylex(pTHX) } #endif } - yylval.ival = 1; + pl_yylval.ival = 1; OPERATOR(MY); case KEY_next: @@ -6259,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: @@ -6305,7 +6402,7 @@ Perl_yylex(pTHX) s = scan_str(s,!!PL_madskills,FALSE); if (!s) missingterm(NULL); - yylval.ival = OP_CONST; + pl_yylval.ival = OP_CONST; TERM(sublex_start()); case KEY_quotemeta: @@ -6345,9 +6442,7 @@ Perl_yylex(pTHX) 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))); } @@ -6369,7 +6464,7 @@ Perl_yylex(pTHX) s = scan_str(s,!!PL_madskills,FALSE); if (!s) missingterm(NULL); - yylval.ival = OP_STRINGIFY; + pl_yylval.ival = OP_STRINGIFY; if (SvIVX(PL_lex_stuff) == '\'') SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */ TERM(sublex_start()); @@ -6405,10 +6500,10 @@ Perl_yylex(pTHX) } 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; @@ -6464,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 */ @@ -6617,7 +6712,7 @@ Perl_yylex(pTHX) (*s == ':' && s[1] == ':')) { #ifdef PERL_MAD - SV *nametoke; + SV *nametoke = NULL; #endif PL_expect = XBLOCK; @@ -6656,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; } @@ -6678,6 +6773,12 @@ Perl_yylex(pTHX) 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); @@ -6689,14 +6790,47 @@ Perl_yylex(pTHX) for (p = d; *p; ++p) { if (!isSPACE(*p)) { d[tmp++] = *p; - if (warnsyntax && !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 (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", + "Illegal character %sin prototype for %"SVf" : %s", + seen_underscore ? "after '_' " : "", SVfARG(PL_subname), d); SvCUR_set(PL_lex_stuff, tmp); have_proto = TRUE; @@ -6819,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: @@ -6855,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: @@ -6896,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: @@ -6945,8 +7079,8 @@ S_pending_ident(pTHX) 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; } } @@ -6975,8 +7109,8 @@ S_pending_ident(pTHX) SV * const sym = newSVhek(stashname); sv_catpvs(sym, "::"); sv_catpvn(sym, PL_tokenbuf+1, tokenbuf_len - 1); - yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym); - yylval.opval->op_private = OPpCONST_ENTERED; + 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) @@ -7005,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; } } @@ -7034,9 +7168,9 @@ S_pending_ident(pTHX) } /* build ops for a bareword */ - yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1, + pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1, tokenbuf_len - 1)); - yylval.opval->op_private = OPpCONST_ENTERED; + 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. @@ -7070,6 +7204,9 @@ I32 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords) { dVAR; + + PERL_ARGS_ASSERT_KEYWORD; + switch (len) { case 1: /* 5 tokens of length 1 */ @@ -10458,6 +10595,8 @@ S_checkcomma(pTHX_ const char *s, const char *name, const char *what) { dVAR; + PERL_ARGS_ASSERT_CHECKCOMMA; + if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ if (ckWARN(WARN_SYNTAX)) { int level = 1; @@ -10520,6 +10659,8 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, SV *cv, *typesv; const char *why1 = "", *why2 = "", *why3 = ""; + PERL_ARGS_ASSERT_NEW_CONSTANT; + if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { SV *msg; @@ -10555,9 +10696,9 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, 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(newSVpvn(type, typelen)); + typesv = newSVpvn_flags(type, typelen, SVs_TEMP); else typesv = &PL_sv_undef; @@ -10614,6 +10755,9 @@ 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); @@ -10657,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)) { @@ -10811,9 +10957,11 @@ 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<256) { - char c = (char)ch; + const char c = (char)ch; switch (c) { CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl); case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break; @@ -10836,6 +10984,7 @@ S_scan_pat(pTHX_ char *start, I32 type) char *modstart; #endif + PERL_ARGS_ASSERT_SCAN_PAT; if (!s) { const char * const delimiter = skipspace(start); @@ -10856,10 +11005,10 @@ S_scan_pat(pTHX_ char *start, I32 type) matches. */ assert(type != OP_TRANS); if (PL_curstash) { - MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab); + MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab); U32 elements; if (!mg) { - mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, + mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0, 0); } elements = mg->mg_len / sizeof(PMOP**); @@ -10889,7 +11038,7 @@ S_scan_pat(pTHX_ char *start, I32 type) } PL_lex_op = (OP*)pm; - yylval.ival = OP_MATCH; + pl_yylval.ival = OP_MATCH; return s; } @@ -10905,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); @@ -10993,7 +11144,7 @@ S_scan_subst(pTHX_ char *start) } PL_lex_op = (OP*)pm; - yylval.ival = OP_SUBST; + pl_yylval.ival = OP_SUBST; return s; } @@ -11004,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) @@ -11073,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) { @@ -11108,6 +11261,8 @@ 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; @@ -11279,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) { @@ -11316,7 +11471,7 @@ 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) + 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); @@ -11344,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: @@ -11371,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; @@ -11411,7 +11567,7 @@ S_scan_inputsymbol(pTHX_ char *start) */ if (d - PL_tokenbuf != len) { - yylval.ival = OP_GLOB; + pl_yylval.ival = OP_GLOB; s = scan_str(start,!!PL_madskills,FALSE); if (!s) Perl_croak(aTHX_ "Glob not terminated"); @@ -11486,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 @@ -11500,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; } } @@ -11571,6 +11727,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) char *tstart; #endif + PERL_ARGS_ASSERT_SCAN_STR; + /* skip space before the delimiter */ if (isSPACE(*s)) { s = PEEKSPACE(s); @@ -11812,7 +11970,7 @@ 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) + 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 */ @@ -11880,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: @@ -11911,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) { @@ -12293,14 +12453,16 @@ 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; @@ -12427,12 +12589,12 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) save_item(PL_subname); SAVESPTR(PL_compcv); - PL_compcv = (CV*)newSV_type(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; @@ -12441,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; @@ -12452,7 +12617,7 @@ 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; @@ -12461,6 +12626,8 @@ Perl_yyerror(pTHX_ const char *s) SV *msg; int yychar = PL_parser->yychar; + PERL_ARGS_ASSERT_YYERROR; + if (!yychar || (yychar == ';' && !PL_rsfp)) where = "at EOF"; else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr && @@ -12508,7 +12675,7 @@ 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)) { @@ -12559,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) { @@ -12732,11 +12902,14 @@ passed in, for performance reasons. */ char * -Perl_scan_vstring(pTHX_ const char *s, const char *e, 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 < e && (isDIGIT(*pos) || *pos == '_')) pos++; @@ -12758,7 +12931,7 @@ Perl_scan_vstring(pTHX_ const char *s, const char *e, SV *sv) if (*s == 'v') s++; /* get past 'v' */ - sv_setpvn(sv, "", 0); + sv_setpvs(sv, ""); for (;;) { /* this is atoi() that tolerates underscores */