X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7294df96f6c174861cfdbe3e109c745792c2be60..df9a60198135b900e391b399c4576b1b17f56902:/toke.c diff --git a/toke.c b/toke.c index 287aa94..4bf4a85 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, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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. @@ -26,12 +26,8 @@ #define yychar (*PL_yycharp) #define yylval (*PL_yylvalp) -static const char ident_too_long[] = - "Identifier too long"; -static const char c_without_g[] = - "Use of /c modifier is meaningless without /g"; -static const char c_in_subst[] = - "Use of /c modifier is meaningless in s///"; +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 @@ -39,6 +35,14 @@ 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 +# define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; } +# define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val +#else +# define CURMAD(slot,sv) +# define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke] +#endif + #define XFAKEBRACK 128 #define XENUMMASK 127 @@ -112,6 +116,18 @@ static const char* const lex_state_names[] = { #endif #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline)) +#ifdef PERL_MAD +# define SKIPSPACE0(s) skipspace0(s) +# define SKIPSPACE1(s) skipspace1(s) +# define SKIPSPACE2(s,tsv) skipspace2(s,&tsv) +# define PEEKSPACE(s) skipspace2(s,0) +#else +# define SKIPSPACE0(s) skipspace(s) +# define SKIPSPACE1(s) skipspace(s) +# define SKIPSPACE2(s,tsv) skipspace(s) +# define PEEKSPACE(s) skipspace(s) +#endif + /* * Convenience functions to return different tokens and prime the * lexer for the next token. They all take an argument. @@ -141,7 +157,7 @@ static const char* const lex_state_names[] = { */ #ifdef DEBUGGING /* Serve -DT. */ -# define REPORT(retval) tokereport(s,(int)retval) +# define REPORT(retval) tokereport((I32)retval) #else # define REPORT(retval) (retval) #endif @@ -180,7 +196,7 @@ static const char* const lex_state_names[] = { PL_last_lop_op = f; \ if (*s == '(') \ return REPORT( (int)FUNC1 ); \ - s = skipspace(s); \ + s = PEEKSPACE(s); \ return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \ } #define UNI(f) UNI2(f,XTERM) @@ -192,7 +208,7 @@ static const char* const lex_state_names[] = { PL_last_uni = PL_oldbufptr; \ if (*s == '(') \ return REPORT( (int)FUNC1 ); \ - s = skipspace(s); \ + s = PEEKSPACE(s); \ return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \ } @@ -211,8 +227,11 @@ enum token_type { TOKENTYPE_GVVAL }; -static struct debug_tokens { const int token, type; const char *name; } - const debug_tokens[] = +static struct debug_tokens { + const int token; + enum token_type type; + const char *name; +} const debug_tokens[] = { { ADDOP, TOKENTYPE_OPNUM, "ADDOP" }, { ANDAND, TOKENTYPE_NONE, "ANDAND" }, @@ -224,6 +243,7 @@ static struct debug_tokens { const int token, type; const char *name; } { BITOROP, TOKENTYPE_OPNUM, "BITOROP" }, { COLONATTR, TOKENTYPE_NONE, "COLONATTR" }, { CONTINUE, TOKENTYPE_NONE, "CONTINUE" }, + { DEFAULT, TOKENTYPE_NONE, "DEFAULT" }, { DO, TOKENTYPE_NONE, "DO" }, { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" }, { DORDOR, TOKENTYPE_NONE, "DORDOR" }, @@ -239,6 +259,7 @@ static struct debug_tokens { const int token, type; const char *name; } { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" }, { FUNC1, TOKENTYPE_OPNUM, "FUNC1" }, { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" }, + { GIVEN, TOKENTYPE_IVAL, "GIVEN" }, { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" }, { IF, TOKENTYPE_IVAL, "IF" }, { LABEL, TOKENTYPE_PVAL, "LABEL" }, @@ -274,6 +295,7 @@ static struct debug_tokens { const int token, type; const char *name; } { UNLESS, TOKENTYPE_IVAL, "UNLESS" }, { UNTIL, TOKENTYPE_IVAL, "UNTIL" }, { USE, TOKENTYPE_IVAL, "USE" }, + { WHEN, TOKENTYPE_IVAL, "WHEN" }, { WHILE, TOKENTYPE_IVAL, "WHILE" }, { WORD, TOKENTYPE_OPVAL, "WORD" }, { 0, TOKENTYPE_NONE, 0 } @@ -282,13 +304,14 @@ static struct debug_tokens { const int token, type; const char *name; } /* dump the returned token in rv, plus any optional arg in yylval */ STATIC int -S_tokereport(pTHX_ const char* s, I32 rv) +S_tokereport(pTHX_ I32 rv) { + dVAR; if (DEBUG_T_TEST) { - const char *name = Nullch; + const char *name = NULL; enum token_type type = TOKENTYPE_NONE; const struct debug_tokens *p; - SV* const report = newSVpvn("<== ", 4); + SV* const report = newSVpvs("<== "); for (p = debug_tokens; p->token; p++) { if (p->token == (int)rv) { @@ -302,7 +325,7 @@ S_tokereport(pTHX_ const char* s, I32 rv) else if ((char)rv > ' ' && (char)rv < '~') Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv); else if (!rv) - Perl_sv_catpv(aTHX_ report, "EOF"); + sv_catpvs(report, "EOF"); else Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv); switch (type) { @@ -330,7 +353,7 @@ S_tokereport(pTHX_ const char* s, I32 rv) } else - Perl_sv_catpv(aTHX_ report, "(opval=null)"); + sv_catpvs(report, "(opval=null)"); break; } PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report)); @@ -344,7 +367,7 @@ S_tokereport(pTHX_ const char* s, I32 rv) STATIC void S_printbuf(pTHX_ const char* fmt, const char* s) { - SV* tmp = newSVpvn("", 0); + SV* const tmp = newSVpvs(""); PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60)); SvREFCNT_dec(tmp); } @@ -361,6 +384,7 @@ S_printbuf(pTHX_ const char* fmt, const char* s) STATIC int S_ao(pTHX_ int toketype) { + dVAR; if (*PL_bufptr == '=') { PL_bufptr++; if (toketype == ANDAND) @@ -390,6 +414,7 @@ S_ao(pTHX_ int toketype) STATIC void S_no_op(pTHX_ const char *what, char *s) { + dVAR; char * const oldbp = PL_bufptr; const bool is_first = (PL_oldbufptr == PL_linestart); @@ -431,6 +456,7 @@ S_no_op(pTHX_ const char *what, char *s) STATIC void S_missingterm(pTHX_ char *s) { + dVAR; char tmpbuf[3]; char q; if (s) { @@ -459,6 +485,24 @@ S_missingterm(pTHX_ char *s) Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q); } +#define FEATURE_IS_ENABLED(name) \ + ((0 != (PL_hints & HINT_LOCALIZE_HH)) \ + && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name))) +/* + * S_feature_is_enabled + * Check whether the named feature is enabled. + */ +STATIC bool +S_feature_is_enabled(pTHX_ char *name, STRLEN namelen) +{ + dVAR; + HV * const hinthv = GvHV(PL_hintgv); + char he_name[32] = "feature_"; + (void) strncpy(&he_name[8], name, 24); + + return (hinthv && hv_exists(hinthv, he_name, 8 + namelen)); +} + /* * Perl_deprecate */ @@ -487,17 +531,6 @@ Perl_deprecate_old(pTHX_ const char *s) } /* - * depcom - * Deprecate a comma-less variable list. - */ - -STATIC void -S_depcom(pTHX) -{ - deprecate_old("comma-less variable list"); -} - -/* * experimental text filters for win32 carriage-returns, utf16-to-utf8 and * utf16-to-utf8-reversed. */ @@ -544,6 +577,7 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) void Perl_lex_start(pTHX_ SV *line) { + dVAR; const char *s; STRLEN len; @@ -554,6 +588,30 @@ Perl_lex_start(pTHX_ SV *line) 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) { @@ -562,6 +620,7 @@ Perl_lex_start(pTHX_ SV *line) } SAVEI32(PL_nexttoke); } +#endif SAVECOPLINE(PL_curcop); SAVEPPTR(PL_bufptr); SAVEPPTR(PL_bufend); @@ -591,10 +650,14 @@ Perl_lex_start(pTHX_ SV *line) *PL_lex_casestack = '\0'; PL_lex_dojoin = 0; PL_lex_starts = 0; - PL_lex_stuff = Nullsv; - PL_lex_repl = Nullsv; + PL_lex_stuff = NULL; + PL_lex_repl = NULL; PL_lex_inpat = 0; +#ifdef PERL_MAD + PL_lasttoke = 0; +#else PL_nexttoke = 0; +#endif PL_lex_inwhat = 0; PL_sublex_info.sub_inwhat = 0; PL_linestr = line; @@ -604,12 +667,12 @@ Perl_lex_start(pTHX_ SV *line) if (!len || s[len-1] != ';') { if (!(SvFLAGS(PL_linestr) & SVs_TEMP)) PL_linestr = sv_2mortal(newSVsv(PL_linestr)); - sv_catpvn(PL_linestr, "\n;", 2); + 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 = Nullch; + PL_last_lop = PL_last_uni = NULL; PL_rsfp = 0; } @@ -622,6 +685,7 @@ Perl_lex_start(pTHX_ SV *line) void Perl_lex_end(pTHX) { + dVAR; PL_doextract = FALSE; } @@ -638,6 +702,7 @@ Perl_lex_end(pTHX) STATIC void S_incline(pTHX_ char *s) { + dVAR; char *t; char *n; char *e; @@ -680,14 +745,14 @@ S_incline(pTHX_ char *s) *t = '\0'; if (t - s > 0) { #ifndef USE_ITHREADS - const char *cf = CopFILE(PL_curcop); - if (cf && strlen(cf) > 7 && strnEQ(cf, "(eval ", 6)) { + const char * const cf = CopFILE(PL_curcop); + STRLEN tmplen = cf ? strlen(cf) : 0; + if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) { /* must copy *{"::_<(eval N)[oldfilename:L]"} * to *{"::_= 0) { + char *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); + sv_catsv(PL_nextwhite, PL_skipwhite); + sv_free(PL_skipwhite); + PL_skipwhite = 0; + } + return 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); + 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; + PL_thistoken = newSVpvn(tstart, start - tstart); + PL_realtokenstart = -1; + } + if (PL_skipwhite) { + if (!*svp) + *svp = newSVpvn("",0); + sv_setsv(*svp, PL_skipwhite); + sv_free(PL_skipwhite); + PL_skipwhite = 0; + } + + return s; +} +#endif + /* * S_skipspace * Called to gobble the appropriate amount and type of whitespace. @@ -732,10 +872,25 @@ S_incline(pTHX_ char *s) STATIC char * S_skipspace(pTHX_ register char *s) { + dVAR; +#ifdef PERL_MAD + int curoff; + int startoff = s - SvPVX(PL_linestr); + + if (PL_skipwhite) { + sv_free(PL_skipwhite); + PL_skipwhite = 0; + } +#endif + if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; +#ifdef PERL_MAD + goto done; +#else return s; +#endif } for (;;) { STRLEN prevlen; @@ -765,30 +920,72 @@ S_skipspace(pTHX_ register char *s) */ if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE) +#ifdef PERL_MAD + goto done; +#else return s; +#endif /* try to recharge the buffer */ +#ifdef PERL_MAD + curoff = s - SvPVX(PL_linestr); +#endif + if ((s = filter_gets(PL_linestr, PL_rsfp, - (prevlen = SvCUR(PL_linestr)))) == Nullch) + (prevlen = SvCUR(PL_linestr)))) == NULL) { +#ifdef PERL_MAD + if (PL_madskills && curoff != startoff) { + if (!PL_skipwhite) + PL_skipwhite = newSVpvn("",0); + sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff, + curoff - startoff); + } + + /* mustn't throw out old stuff yet if madpropping */ + SvCUR(PL_linestr) = curoff; + s = SvPVX(PL_linestr) + curoff; + *s = 0; + if (curoff && s[-1] == '\n') + s[-1] = ' '; +#endif + /* end of file. Add on the -p or -n magic */ + /* XXX these shouldn't really be added here, can't set PL_faketokens */ if (PL_minus_p) { +#ifdef PERL_MAD + sv_catpv(PL_linestr, + ";}continue{print or die qq(-p destination: $!\\n);}"); +#else sv_setpv(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); +#else sv_setpvn(PL_linestr, ";}", 2); +#endif PL_minus_n = 0; } else +#ifdef PERL_MAD + sv_catpvn(PL_linestr,";", 1); +#else sv_setpvn(PL_linestr,";", 1); +#endif /* reset variables for next time we lex */ PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart - = SvPVX(PL_linestr); + = SvPVX(PL_linestr) +#ifdef PERL_MAD + + curoff +#endif + ; PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = Nullch; + PL_last_lop = PL_last_uni = NULL; /* Close the filehandle. Could be from -P preprocessor, * STDIN, or a regular file. If we were reading code from @@ -803,7 +1000,7 @@ S_skipspace(pTHX_ register char *s) PerlIO_clearerr(PL_rsfp); else (void)PerlIO_close(PL_rsfp); - PL_rsfp = Nullfp; + PL_rsfp = NULL; return s; } @@ -830,15 +1027,28 @@ S_skipspace(pTHX_ register char *s) * so store the line into the debugger's array of lines */ if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV * const sv = NEWSV(85,0); + 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(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); + av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv); } } + +#ifdef PERL_MAD + done: + if (PL_madskills) { + if (!PL_skipwhite) + PL_skipwhite = newSVpvn("",0); + curoff = s - SvPVX(PL_linestr); + if (curoff - startoff) + sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff, + curoff - startoff); + } + return s; +#endif } /* @@ -853,6 +1063,7 @@ S_skipspace(pTHX_ register char *s) STATIC void S_check_uni(pTHX) { + dVAR; char *s; char *t; @@ -863,13 +1074,11 @@ S_check_uni(pTHX) for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ; if ((t = strchr(s, '(')) && t < PL_bufptr) return; + if (ckWARN_d(WARN_AMBIGUOUS)){ - const char ch = *s; - *s = '\0'; Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), - "Warning: Use of \"%s\" without parentheses is ambiguous", - PL_last_uni); - *s = ch; + "Warning: Use of \"%.*s\" without parentheses is ambiguous", + (int)(s - PL_last_uni), PL_last_uni); } } @@ -891,35 +1100,122 @@ S_check_uni(pTHX) STATIC I32 S_lop(pTHX_ I32 f, int x, char *s) { + dVAR; yylval.ival = f; CLINE; PL_expect = x; PL_bufptr = s; PL_last_lop = PL_oldbufptr; PL_last_lop_op = (OPCODE)f; +#ifdef PERL_MAD + if (PL_lasttoke) + return REPORT(LSTOP); +#else if (PL_nexttoke) return REPORT(LSTOP); +#endif if (*s == '(') return REPORT(FUNC); - s = skipspace(s); + s = PEEKSPACE(s); if (*s == '(') return REPORT(FUNC); else return REPORT(LSTOP); } +#ifdef PERL_MAD + /* + * S_start_force + * Sets up for an eventual force_next(). start_force(0) basically does + * an unshift, while start_force(-1) does a push. yylex removes items + * on the "pop" end. + */ + +STATIC void +S_start_force(pTHX_ int where) +{ + int i; + + if (where < 0) /* so people can duplicate start_force(PL_curforce) */ + where = PL_lasttoke; + assert(PL_curforce < 0 || PL_curforce == where); + if (PL_curforce != where) { + for (i = PL_lasttoke; i > where; --i) { + PL_nexttoke[i] = PL_nexttoke[i-1]; + } + PL_lasttoke++; + } + if (PL_curforce < 0) /* in case of duplicate start_force() */ + Zero(&PL_nexttoke[where], 1, NEXTTOKE); + PL_curforce = where; + if (PL_nextwhite) { + if (PL_madskills) + curmad('^', newSVpvn("",0)); + CURMAD('_', PL_nextwhite); + } +} + +STATIC void +S_curmad(pTHX_ char slot, SV *sv) +{ + MADPROP **where; + + if (!sv) + return; + if (PL_curforce < 0) + where = &PL_thismad; + else + where = &PL_nexttoke[PL_curforce].next_mad; + + if (PL_faketokens) + sv_setpvn(sv, "", 0); + else { + if (!IN_BYTES) { + if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv))) + SvUTF8_on(sv); + else if (PL_encoding) { + sv_recode_to_utf8(sv, PL_encoding); + } + } + } + + /* 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); + (*where)->mad_val = (void*)sv; + } + else + addmad(newMADsv(slot, sv), where, 0); +} +#else +# define start_force(where) +# define curmad(slot, sv) +#endif + /* * S_force_next * When the lexer realizes it knows the next token (for instance, * it is reordering tokens for the parser) then it can call S_force_next * to know what token to return the next time the lexer is called. Caller - * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer - * handles the token correctly. + * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD), + * and possibly PL_expect to ensure the lexer handles the token correctly. */ STATIC void S_force_next(pTHX_ I32 type) { + dVAR; +#ifdef PERL_MAD + if (PL_curforce < 0) + start_force(PL_lasttoke); + PL_nexttoke[PL_curforce].next_type = type; + if (PL_lex_state != LEX_KNOWNEXT) + PL_lex_defer = PL_lex_state; + PL_lex_state = LEX_KNOWNEXT; + PL_lex_expect = PL_expect; + PL_curforce = -1; +#else PL_nexttype[PL_nexttoke] = type; PL_nexttoke++; if (PL_lex_state != LEX_KNOWNEXT) { @@ -927,11 +1223,13 @@ S_force_next(pTHX_ I32 type) PL_lex_expect = PL_expect; PL_lex_state = LEX_KNOWNEXT; } +#endif } STATIC SV * S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len) { + dVAR; SV * const sv = newSVpvn(start,len); if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len)) SvUTF8_on(sv); @@ -957,10 +1255,11 @@ S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len) STATIC char * S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick) { + dVAR; register char *s; STRLEN len; - start = skipspace(start); + start = SKIPSPACE1(start); s = start; if (isIDFIRST_lazy_if(s,UTF) || (allow_pack && *s == ':') || @@ -969,18 +1268,21 @@ S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len); if (check_keyword && keyword(PL_tokenbuf, len)) return start; + start_force(PL_curforce); + if (PL_madskills) + curmad('X', newSVpvn(start,s-start)); if (token == METHOD) { - s = skipspace(s); + s = SKIPSPACE1(s); if (*s == '(') PL_expect = XTERM; else { PL_expect = XOPERATOR; } } - PL_nextval[PL_nexttoke].opval + NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST,0, S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len)); - PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE; + NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE; force_next(token); } return s; @@ -998,21 +1300,26 @@ S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow STATIC void S_force_ident(pTHX_ register const char *s, int kind) { + dVAR; if (s && *s) { - OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0)); - PL_nextval[PL_nexttoke].opval = o; + const STRLEN len = strlen(s); + OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len)); + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.opval = o; force_next(WORD); if (kind) { o->op_private = OPpCONST_ENTERED; /* XXX see note in pp_entereval() for why we forgo typo warnings if the symbol must be introduced in an eval. GSAR 96-10-12 */ - gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE, - kind == '$' ? SVt_PV : - kind == '@' ? SVt_PVAV : - kind == '%' ? SVt_PVHV : + gv_fetchpvn_flags(s, len, + PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) + : GV_ADD, + kind == '$' ? SVt_PV : + kind == '@' ? SVt_PVAV : + kind == '%' ? SVt_PVHV : SVt_PVGV - ); + ); } } } @@ -1053,10 +1360,14 @@ Perl_str_to_version(pTHX_ SV *sv) STATIC char * S_force_version(pTHX_ char *s, int guessing) { - OP *version = Nullop; + dVAR; + OP *version = NULL; char *d; +#ifdef PERL_MAD + I32 startoff = s - SvPVX(PL_linestr); +#endif - s = skipspace(s); + s = SKIPSPACE1(s); d = s; if (*d == 'v') @@ -1064,6 +1375,12 @@ S_force_version(pTHX_ char *s, int guessing) if (isDIGIT(*d)) { while (isDIGIT(*d) || *d == '_' || *d == '.') d++; +#ifdef PERL_MAD + if (PL_madskills) { + start_force(PL_curforce); + curmad('X', newSVpvn(s,d-s)); + } +#endif if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) { SV *ver; s = scan_num(s, &yylval); @@ -1075,12 +1392,28 @@ S_force_version(pTHX_ char *s, int guessing) SvNOK_on(ver); /* hint that it is a version */ } } - else if (guessing) + else if (guessing) { +#ifdef PERL_MAD + if (PL_madskills) { + sv_free(PL_nextwhite); /* let next token collect whitespace */ + PL_nextwhite = 0; + s = SvPVX(PL_linestr) + startoff; + } +#endif return s; + } } +#ifdef PERL_MAD + if (PL_madskills && !version) { + sv_free(PL_nextwhite); /* let next token collect whitespace */ + PL_nextwhite = 0; + s = SvPVX(PL_linestr) + startoff; + } +#endif /* NOTE: The parser sees the package name and the VERSION swapped */ - PL_nextval[PL_nexttoke].opval = version; + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.opval = version; force_next(WORD); return s; @@ -1097,6 +1430,7 @@ S_force_version(pTHX_ char *s, int guessing) STATIC SV * S_tokeq(pTHX_ SV *sv) { + dVAR; register char *s; register char *send; register char *d; @@ -1170,11 +1504,12 @@ S_tokeq(pTHX_ SV *sv) STATIC I32 S_sublex_start(pTHX) { + dVAR; register const I32 op_type = yylval.ival; if (op_type == OP_NULL) { yylval.opval = PL_lex_op; - PL_lex_op = Nullop; + PL_lex_op = NULL; return THING; } if (op_type == OP_CONST || op_type == OP_READLINE) { @@ -1183,7 +1518,7 @@ S_sublex_start(pTHX) if (SvTYPE(sv) == SVt_PVIV) { /* Overloaded constants, nothing fancy: Convert to SVt_PV: */ STRLEN len; - const char *p = SvPV_const(sv, len); + const char * const p = SvPV_const(sv, len); SV * const nsv = newSVpvn(p, len); if (SvUTF8(sv)) SvUTF8_on(nsv); @@ -1191,7 +1526,7 @@ S_sublex_start(pTHX) sv = nsv; } yylval.opval = (OP*)newSVOP(op_type, 0, sv); - PL_lex_stuff = Nullsv; + PL_lex_stuff = NULL; /* Allow // "foo" */ if (op_type == OP_READLINE) PL_expect = XTERMORDORDOR; @@ -1206,7 +1541,7 @@ S_sublex_start(pTHX) PL_expect = XTERM; if (PL_lex_op) { yylval.opval = PL_lex_op; - PL_lex_op = Nullop; + PL_lex_op = NULL; return PMFUNC; } else @@ -1248,12 +1583,12 @@ S_sublex_push(pTHX) SAVEGENERICPV(PL_lex_casestack); PL_linestr = PL_lex_stuff; - PL_lex_stuff = Nullsv; + PL_lex_stuff = NULL; PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); PL_bufend += SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = Nullch; + PL_last_lop = PL_last_uni = NULL; SAVEFREESV(PL_linestr); PL_lex_dojoin = FALSE; @@ -1270,7 +1605,7 @@ S_sublex_push(pTHX) if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST) PL_lex_inpat = PL_sublex_info.sub_op; else - PL_lex_inpat = Nullop; + PL_lex_inpat = NULL; return '('; } @@ -1285,7 +1620,7 @@ S_sublex_done(pTHX) { dVAR; if (!PL_lex_starts++) { - SV * const sv = newSVpvn("",0); + SV * const sv = newSVpvs(""); if (SvUTF8(PL_linestr)) SvUTF8_on(sv); PL_expect = XOPERATOR; @@ -1304,7 +1639,7 @@ S_sublex_done(pTHX) PL_lex_inpat = 0; PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); PL_bufend += SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = Nullch; + PL_last_lop = PL_last_uni = NULL; SAVEFREESV(PL_linestr); PL_lex_dojoin = FALSE; PL_lex_brackets = 0; @@ -1321,11 +1656,25 @@ S_sublex_done(pTHX) } else { PL_lex_state = LEX_INTERPCONCAT; - PL_lex_repl = Nullsv; + PL_lex_repl = NULL; } return ','; } else { +#ifdef PERL_MAD + if (PL_madskills) { + if (PL_thiswhite) { + if (!PL_endwhite) + PL_endwhite = newSVpvn("",0); + sv_catsv(PL_endwhite, PL_thiswhite); + PL_thiswhite = 0; + } + if (PL_thistoken) + sv_setpvn(PL_thistoken,"",0); + else + PL_realtokenstart = -1; + } +#endif LEAVE; PL_bufend = SvPVX(PL_linestr); PL_bufend += SvCUR(PL_linestr); @@ -1411,8 +1760,9 @@ S_sublex_done(pTHX) STATIC char * S_scan_const(pTHX_ char *start) { + dVAR; register char *send = PL_bufend; /* end of the constant */ - SV *sv = NEWSV(93, send - start); /* sv for the constant */ + SV *sv = newSV(send - start); /* sv for the constant */ 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? */ @@ -1755,8 +2105,8 @@ S_scan_const(pTHX_ char *start) goto NUM_ESCAPE_INSERT; } res = newSVpvn(s + 1, e - s - 1); - res = new_constant( Nullch, 0, "charnames", - res, Nullsv, "\\N{...}" ); + res = new_constant( NULL, 0, "charnames", + res, NULL, "\\N{...}" ); if (has_utf8) sv_utf8_upgrade(res); str = SvPV_const(res,len); @@ -1860,15 +2210,15 @@ S_scan_const(pTHX_ char *start) and then encode the next character */ if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) { STRLEN len = 1; - const UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s); - const STRLEN need = UNISKIP(NATIVE_TO_UNI(uv)); + 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) */ const STRLEN off = d - SvPVX_const(sv); d = SvGROW(sv, SvLEN(sv) + (need-len)) + off; } - d = (char*)uvchr_to_utf8((U8*)d, uv); + d = (char*)uvchr_to_utf8((U8*)d, nextuv); has_utf8 = TRUE; } else { @@ -1905,7 +2255,7 @@ S_scan_const(pTHX_ char *start) 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, Nullsv, + sv, NULL, ( PL_lex_inwhat == OP_TRANS ? "tr" : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) @@ -1941,6 +2291,7 @@ S_scan_const(pTHX_ char *start) STATIC int S_intuit_more(pTHX_ register char *s) { + dVAR; if (PL_lex_brackets) return TRUE; if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{')) @@ -2003,8 +2354,10 @@ S_intuit_more(pTHX_ register char *s) case '$': weight -= seen[un_char] * 10; if (isALNUM_lazy_if(s+1,UTF)) { + int len; scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE); - if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV)) + len = (int)strlen(tmpbuf); + if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV)) weight -= 100; else weight -= 10; @@ -2093,24 +2446,29 @@ S_intuit_more(pTHX_ register char *s) */ STATIC int -S_intuit_method(pTHX_ char *start, GV *gv) +S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) { + dVAR; char *s = start + (*start == '$'); char tmpbuf[sizeof PL_tokenbuf]; STRLEN len; GV* indirgv; +#ifdef PERL_MAD + int soff; +#endif if (gv) { - CV *cv; - if (GvIO(gv)) + if (SvTYPE(gv) == SVt_PVGV && GvIO(gv)) return 0; - if ((cv = GvCVu(gv))) { - const char *proto = SvPVX_const(cv); - if (proto) { - if (*proto == ';') - proto++; - if (*proto == '*') - return 0; + if (cv) { + if (SvPOK(cv)) { + const char *proto = SvPVX_const(cv); + if (proto) { + if (*proto == ';') + proto++; + if (*proto == '*') + return 0; + } } } else gv = 0; @@ -2124,7 +2482,13 @@ S_intuit_method(pTHX_ char *start, GV *gv) if (*start == '$') { if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf)) return 0; - s = skipspace(s); +#ifdef PERL_MAD + len = start - SvPVX(PL_linestr); +#endif + s = PEEKSPACE(s); +#ifdef PERLMAD + start = SvPVX(PL_linestr) + len; +#endif PL_bufptr = start; PL_expect = XREF; return *s == '(' ? FUNCMETH : METHOD; @@ -2133,23 +2497,35 @@ S_intuit_method(pTHX_ char *start, GV *gv) if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') { len -= 2; tmpbuf[len] = '\0'; +#ifdef PERL_MAD + soff = s - SvPVX(PL_linestr); +#endif goto bare_package; } - indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV); + indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV); if (indirgv && GvCVu(indirgv)) return 0; /* filehandle or package name makes it a method */ if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) { - s = skipspace(s); +#ifdef PERL_MAD + soff = s - SvPVX(PL_linestr); +#endif + s = PEEKSPACE(s); if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>') return 0; /* no assumptions -- "=>" quotes bearword */ bare_package: - PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(tmpbuf,len)); - PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE; + NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE; + if (PL_madskills) + curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start)); PL_expect = XTERM; force_next(WORD); PL_bufptr = s; +#ifdef PERL_MAD + PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */ +#endif return *s == '(' ? FUNCMETH : METHOD; } } @@ -2166,6 +2542,7 @@ S_intuit_method(pTHX_ char *start, GV *gv) STATIC const char* S_incl_perldb(pTHX) { + dVAR; if (PL_perldb) { const char * const pdb = PerlEnv_getenv("PERL5DB"); @@ -2198,13 +2575,14 @@ S_incl_perldb(pTHX) SV * Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) { + dVAR; if (!funcp) - return Nullsv; + return NULL; if (!PL_rsfp_filters) PL_rsfp_filters = newAV(); if (!datasv) - datasv = NEWSV(255,0); + datasv = newSV(0); SvUPGRADE(datasv, SVt_PVIO); IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */ IoFLAGS(datasv) |= IOf_FAKE_DIRP; @@ -2220,6 +2598,7 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) void Perl_filter_del(pTHX_ filter_t funcp) { + dVAR; SV *datasv; #ifdef DEBUGGING @@ -2246,6 +2625,7 @@ Perl_filter_del(pTHX_ filter_t funcp) I32 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) { + dVAR; filter_t funcp; SV *datasv = NULL; @@ -2302,6 +2682,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) STATIC char * S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) { + dVAR; #ifdef PERL_CR_FILTER if (!PL_rsfp_filters) { filter_add(S_cr_textfilter,NULL); @@ -2313,7 +2694,7 @@ S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) if (FILTER_READ(0, sv, 0) > 0) return ( SvPVX(sv) ) ; else - return Nullch ; + return NULL ; } else return (sv_gets(sv, fp, append)); @@ -2322,6 +2703,7 @@ 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) { + dVAR; GV *gv; if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__")) @@ -2329,13 +2711,13 @@ S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) if (len > 2 && (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') && - (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV))) + (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV))) { return GvHV(gv); /* Foo:: */ } /* use constant CLASS => 'MyClass' */ - if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) { + 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); @@ -2345,16 +2727,203 @@ S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) return gv_stashpv(pkgname, FALSE); } +#ifdef PERL_MAD + /* + * Perl_madlex + * The intent of this yylex wrapper is to minimize the changes to the + * tokener when we aren't interested in collecting madprops. It remains + * to be seen how successful this strategy will be... + */ + +int +Perl_madlex(pTHX) +{ + int optype; + char *s = PL_bufptr; + + /* make sure PL_thiswhite is initialized */ + PL_thiswhite = 0; + PL_thismad = 0; + + /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */ + if (PL_pending_ident) + return S_pending_ident(aTHX); + + /* previous token ate up our whitespace? */ + if (!PL_lasttoke && PL_nextwhite) { + PL_thiswhite = PL_nextwhite; + PL_nextwhite = 0; + } + + /* isolate the token, and figure out where it is without whitespace */ + PL_realtokenstart = -1; + PL_thistoken = 0; + optype = yylex(); + s = PL_bufptr; + assert(PL_curforce < 0); + + if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */ + if (!PL_thistoken) { + if (PL_realtokenstart < 0 || !CopLINE(PL_curcop)) + PL_thistoken = newSVpvn("",0); + else { + char *tstart = SvPVX(PL_linestr) + PL_realtokenstart; + PL_thistoken = newSVpvn(tstart, s - tstart); + } + } + if (PL_thismad) /* install head */ + CURMAD('X', PL_thistoken); + } + + /* last whitespace of a sublex? */ + if (optype == ')' && PL_endwhite) { + CURMAD('X', PL_endwhite); + } + + if (!PL_thismad) { + + /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */ + if (!PL_thiswhite && !PL_endwhite && !optype) { + sv_free(PL_thistoken); + PL_thistoken = 0; + return 0; + } + + /* put off final whitespace till peg */ + if (optype == ';' && !PL_rsfp) { + PL_nextwhite = PL_thiswhite; + PL_thiswhite = 0; + } + else if (PL_thisopen) { + CURMAD('q', PL_thisopen); + if (PL_thistoken) + sv_free(PL_thistoken); + PL_thistoken = 0; + } + else { + /* Store actual token text as madprop X */ + CURMAD('X', PL_thistoken); + } + + if (PL_thiswhite) { + /* add preceding whitespace as madprop _ */ + CURMAD('_', PL_thiswhite); + } + + if (PL_thisstuff) { + /* add quoted material as madprop = */ + CURMAD('=', PL_thisstuff); + } + + if (PL_thisclose) { + /* add terminating quote as madprop Q */ + CURMAD('Q', PL_thisclose); + } + } + + /* special processing based on optype */ + + switch (optype) { + + /* opval doesn't need a TOKEN since it can already store mp */ + case WORD: + case METHOD: + case FUNCMETH: + case THING: + case PMFUNC: + case PRIVATEREF: + case FUNC0SUB: + case UNIOPSUB: + case LSTOPSUB: + if (yylval.opval) + append_madprops(PL_thismad, yylval.opval, 0); + PL_thismad = 0; + return optype; + + /* fake EOF */ + case 0: + optype = PEG; + if (PL_endwhite) { + addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0); + PL_endwhite = 0; + } + break; + + case ']': + case '}': + if (PL_faketokens) + break; + /* remember any fake bracket that lexer is about to discard */ + if (PL_lex_brackets == 1 && + ((expectation)PL_lex_brackstack[0] & XFAKEBRACK)) + { + s = PL_bufptr; + while (s < PL_bufend && (*s == ' ' || *s == '\t')) + s++; + if (*s == '}') { + PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr); + addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0); + PL_thiswhite = 0; + PL_bufptr = s - 1; + break; /* don't bother looking for trailing comment */ + } + else + s = PL_bufptr; + } + if (optype == ']') + break; + /* FALLTHROUGH */ + + /* attach a trailing comment to its statement instead of next token */ + case ';': + if (PL_faketokens) + break; + if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) { + s = PL_bufptr; + while (s < PL_bufend && (*s == ' ' || *s == '\t')) + s++; + if (*s == '\n' || *s == '#') { + while (s < PL_bufend && *s != '\n') + s++; + if (s < PL_bufend) + s++; + PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr); + addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0); + PL_thiswhite = 0; + PL_bufptr = s; + } + } + break; + + /* pval */ + case LABEL: + break; + + /* ival */ + default: + break; + + } + + /* Create new token struct. Note: opvals return early above. */ + yylval.tkval = newTOKEN(optype, yylval, PL_thismad); + PL_thismad = 0; + return optype; +} +#endif + STATIC char * S_tokenize_use(pTHX_ int is_use, char *s) { + dVAR; if (PL_expect != XSTATE) yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression", is_use ? "use" : "no")); - s = skipspace(s); + s = SKIPSPACE1(s); if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { s = force_version(s, TRUE); - if (*s == ';' || (s = skipspace(s), *s == ';')) { - PL_nextval[PL_nexttoke].opval = Nullop; + if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) { + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.opval = NULL; force_next(WORD); } else if (*s == 'v') { @@ -2408,17 +2977,14 @@ S_tokenize_use(pTHX_ int is_use, char *s) { int Perl_yylex(pTHX) { + dVAR; register char *s = PL_bufptr; register char *d; - register I32 tmp; STRLEN len; - GV *gv = Nullgv; - GV **gvp = 0; bool bof = FALSE; - I32 orig_keyword = 0; DEBUG_T( { - SV* tmp = newSVpvn("", 0); + SV* tmp = newSVpvs(""); PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n", (IV)CopLINE(PL_curcop), lex_state_names[PL_lex_state], @@ -2441,6 +3007,27 @@ Perl_yylex(pTHX) /* when we've already built the next token, just pull it out of the queue */ case LEX_KNOWNEXT: +#ifdef PERL_MAD + PL_lasttoke--; + 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_thismad->mad_val = 0; + mad_free(PL_thismad); + PL_thismad = 0; + } + } + if (!PL_lasttoke) { + PL_lex_state = PL_lex_defer; + PL_expect = PL_lex_expect; + PL_lex_defer = LEX_NORMAL; + if (!PL_nexttoke[PL_lasttoke].next_type) + return yylex(); + } +#else PL_nexttoke--; yylval = PL_nextval[PL_nexttoke]; if (!PL_nexttoke) { @@ -2448,7 +3035,13 @@ Perl_yylex(pTHX) PL_expect = PL_lex_expect; PL_lex_defer = LEX_NORMAL; } +#endif +#ifdef PERL_MAD + /* FIXME - can these be merged? */ + return(PL_nexttoke[PL_lasttoke].next_type); +#else return REPORT(PL_nexttype[PL_nexttoke]); +#endif /* interpolated case modifiers like \L \U, including \Q and \E. when we get here, PL_bufptr is at the \ @@ -2469,11 +3062,25 @@ Perl_yylex(pTHX) && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) { PL_bufptr += 2; PL_lex_state = LEX_INTERPCONCAT; +#ifdef PERL_MAD + if (PL_madskills) + PL_thistoken = newSVpvn("\\E",2); +#endif } return REPORT(')'); } +#ifdef PERL_MAD + while (PL_bufptr != PL_bufend && + PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') { + if (!PL_thiswhite) + PL_thiswhite = newSVpvn("",0); + sv_catpvn(PL_thiswhite, PL_bufptr, 2); + PL_bufptr += 2; + } +#else if (PL_bufptr != PL_bufend) PL_bufptr += 2; +#endif PL_lex_state = LEX_INTERPCONCAT; return yylex(); } @@ -2482,13 +3089,20 @@ Perl_yylex(pTHX) "### Saw case modifier\n"); }); s = PL_bufptr + 1; if (s[1] == '\\' && s[2] == 'E') { +#ifdef PERL_MAD + if (!PL_thiswhite) + PL_thiswhite = newSVpvn("",0); + sv_catpvn(PL_thiswhite, PL_bufptr, 4); +#endif PL_bufptr = s + 3; PL_lex_state = LEX_INTERPCONCAT; return yylex(); } else { - if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) - tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */ + I32 tmp; + if (!PL_madskills) /* when just compiling don't need correct */ + if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) + tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */ if ((*s == 'L' || *s == 'U') && (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) { PL_lex_casestack[--PL_lex_casemods] = '\0'; @@ -2499,26 +3113,40 @@ Perl_yylex(pTHX) PL_lex_casestack[PL_lex_casemods++] = *s; PL_lex_casestack[PL_lex_casemods] = '\0'; PL_lex_state = LEX_INTERPCONCAT; - PL_nextval[PL_nexttoke].ival = 0; + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.ival = 0; force_next('('); + start_force(PL_curforce); if (*s == 'l') - PL_nextval[PL_nexttoke].ival = OP_LCFIRST; + NEXTVAL_NEXTTOKE.ival = OP_LCFIRST; else if (*s == 'u') - PL_nextval[PL_nexttoke].ival = OP_UCFIRST; + NEXTVAL_NEXTTOKE.ival = OP_UCFIRST; else if (*s == 'L') - PL_nextval[PL_nexttoke].ival = OP_LC; + NEXTVAL_NEXTTOKE.ival = OP_LC; else if (*s == 'U') - PL_nextval[PL_nexttoke].ival = OP_UC; + NEXTVAL_NEXTTOKE.ival = OP_UC; else if (*s == 'Q') - PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA; + NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA; else Perl_croak(aTHX_ "panic: yylex"); + if (PL_madskills) { + SV* tmpsv = newSVpvn("",0); + Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s); + curmad('_', tmpsv); + } PL_bufptr = s + 1; } force_next(FUNC); if (PL_lex_starts) { s = PL_bufptr; PL_lex_starts = 0; +#ifdef PERL_MAD + if (PL_madskills) { + if (PL_thistoken) + sv_free(PL_thistoken); + PL_thistoken = newSVpvn("",0); + } +#endif /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ if (PL_lex_casemods == 1 && PL_lex_inpat) OPERATOR(','); @@ -2541,18 +3169,30 @@ Perl_yylex(pTHX) PL_lex_dojoin = (*PL_bufptr == '@'); PL_lex_state = LEX_INTERPNORMAL; if (PL_lex_dojoin) { - PL_nextval[PL_nexttoke].ival = 0; + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.ival = 0; force_next(','); + start_force(PL_curforce); force_ident("\"", '$'); - PL_nextval[PL_nexttoke].ival = 0; + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.ival = 0; force_next('$'); - PL_nextval[PL_nexttoke].ival = 0; + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.ival = 0; force_next('('); - PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */ + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */ force_next(FUNC); } if (PL_lex_starts++) { s = PL_bufptr; +#ifdef PERL_MAD + if (PL_madskills) { + if (PL_thistoken) + sv_free(PL_thistoken); + PL_thistoken = newSVpvn("",0); + } +#endif /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ if (!PL_lex_casemods && PL_lex_inpat) OPERATOR(','); @@ -2572,6 +3212,13 @@ Perl_yylex(pTHX) if (PL_lex_dojoin) { PL_lex_dojoin = FALSE; PL_lex_state = LEX_INTERPCONCAT; +#ifdef PERL_MAD + if (PL_madskills) { + if (PL_thistoken) + sv_free(PL_thistoken); + PL_thistoken = newSVpvn("",0); + } +#endif return REPORT(')'); } if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl @@ -2579,7 +3226,7 @@ Perl_yylex(pTHX) { if (PL_bufptr != PL_bufend) Perl_croak(aTHX_ "Bad evalled substitution pattern"); - PL_lex_repl = Nullsv; + PL_lex_repl = NULL; } /* FALLTHROUGH */ case LEX_INTERPCONCAT: @@ -2608,10 +3255,21 @@ Perl_yylex(pTHX) } if (s != PL_bufptr) { - PL_nextval[PL_nexttoke] = yylval; + start_force(PL_curforce); + if (PL_madskills) { + curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr)); + } + NEXTVAL_NEXTTOKE = yylval; PL_expect = XTERM; force_next(THING); if (PL_lex_starts++) { +#ifdef PERL_MAD + if (PL_madskills) { + if (PL_thistoken) + sv_free(PL_thistoken); + PL_thistoken = newSVpvn("",0); + } +#endif /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ if (!PL_lex_casemods && PL_lex_inpat) OPERATOR(','); @@ -2638,6 +3296,13 @@ Perl_yylex(pTHX) PL_oldbufptr = s; retry: +#ifdef PERL_MAD + if (PL_thistoken) { + sv_free(PL_thistoken); + PL_thistoken = 0; + } + PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */ +#endif switch (*s) { default: if (isIDFIRST_lazy_if(s,UTF)) @@ -2647,14 +3312,17 @@ Perl_yylex(pTHX) case 26: goto fake_eof; /* emulate EOF on ^D or ^Z */ case 0: +#ifdef PERL_MAD + if (PL_madskills) + PL_faketokens = 0; +#endif if (!PL_rsfp) { PL_last_uni = 0; PL_last_lop = 0; if (PL_lex_brackets) { - if (PL_lex_formbrack) - yyerror("Format not terminated"); - else - yyerror("Missing right curly or square bracket"); + yyerror(PL_lex_formbrack + ? "Format not terminated" + : "Missing right curly or square bracket"); } DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Tokener got EOF\n"); @@ -2667,23 +3335,27 @@ Perl_yylex(pTHX) PL_last_lop = 0; if (!PL_in_eval && !PL_preambled) { PL_preambled = TRUE; +#ifdef PERL_MAD + if (PL_madskills) + PL_faketokens = 1; +#endif sv_setpv(PL_linestr,incl_perldb()); if (SvCUR(PL_linestr)) - sv_catpvn(PL_linestr,";", 1); + sv_catpvs(PL_linestr,";"); if (PL_preambleav){ while(AvFILLp(PL_preambleav) >= 0) { SV *tmpsv = av_shift(PL_preambleav); sv_catsv(PL_linestr, tmpsv); - sv_catpvn(PL_linestr, ";", 1); + sv_catpvs(PL_linestr, ";"); sv_free(tmpsv); } sv_free((SV*)PL_preambleav); PL_preambleav = NULL; } if (PL_minus_n || PL_minus_p) { - sv_catpv(PL_linestr, "LINE: while (<>) {"); + sv_catpvs(PL_linestr, "LINE: while (<>) {"); if (PL_minus_l) - sv_catpv(PL_linestr,"chomp;"); + sv_catpvs(PL_linestr,"chomp;"); if (PL_minus_a) { if (PL_minus_F) { if ((*PL_splitstr == '/' || *PL_splitstr == '\'' @@ -2693,11 +3365,8 @@ Perl_yylex(pTHX) else { /* "q\0${splitstr}\0" is legal perl. Yes, even NUL bytes can be used as quoting characters. :-) */ - /* The count here deliberately includes the NUL - that terminates the C string constant. This - embeds the opening NUL into the string. */ const char *splits = PL_splitstr; - sv_catpvn(PL_linestr, "our @F=split(q", 15); + sv_catpvs(PL_linestr, "our @F=split(q\0"); do { /* Need to \ \s */ if (*splits == '\\') @@ -2707,32 +3376,37 @@ Perl_yylex(pTHX) /* This loop will embed the trailing NUL of PL_linestr as the last thing it does before terminating. */ - sv_catpvn(PL_linestr, ");", 2); + sv_catpvs(PL_linestr, ");"); } } else - sv_catpv(PL_linestr,"our @F=split(' ');"); + sv_catpvs(PL_linestr,"our @F=split(' ');"); } } - sv_catpvn(PL_linestr, "\n", 1); + 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 = Nullch; + PL_last_lop = PL_last_uni = NULL; if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV * const sv = NEWSV(85,0); + 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(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); + av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv); } goto retry; } do { bof = PL_rsfp ? TRUE : FALSE; - if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { + if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) { fake_eof: +#ifdef PERL_MAD + PL_realtokenstart = -1; +#endif if (PL_rsfp) { if (PL_preprocess && !PL_in_eval) (void)PerlProc_pclose(PL_rsfp); @@ -2740,20 +3414,24 @@ Perl_yylex(pTHX) PerlIO_clearerr(PL_rsfp); else (void)PerlIO_close(PL_rsfp); - PL_rsfp = Nullfp; + PL_rsfp = NULL; PL_doextract = FALSE; } if (!PL_in_eval && (PL_minus_n || PL_minus_p)) { +#ifdef PERL_MAD + if (PL_madskills) + PL_faketokens = 1; +#endif sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print;}" : ";}"); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = Nullch; + PL_last_lop = PL_last_uni = NULL; PL_minus_n = PL_minus_p = 0; goto retry; } PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); - PL_last_lop = PL_last_uni = Nullch; + PL_last_lop = PL_last_uni = NULL; sv_setpvn(PL_linestr,"",0); TOKEN(';'); /* not infinite loop because rsfp is NULL now */ } @@ -2794,11 +3472,15 @@ Perl_yylex(pTHX) } if (PL_doextract) { /* Incest with pod. */ +#ifdef PERL_MAD + if (PL_madskills) + sv_catsv(PL_thiswhite, PL_linestr); +#endif if (*s == '=' && strnEQ(s, "=cut", 4)) { sv_setpvn(PL_linestr, "", 0); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = Nullch; + PL_last_lop = PL_last_uni = NULL; PL_doextract = FALSE; } } @@ -2806,22 +3488,26 @@ Perl_yylex(pTHX) } while (PL_doextract); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV * const sv = NEWSV(85,0); + 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(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); + av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv); } PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = Nullch; + PL_last_lop = PL_last_uni = NULL; if (CopLINE(PL_curcop) == 1) { while (s < PL_bufend && isSPACE(*s)) s++; if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */ s++; - d = Nullch; +#ifdef PERL_MAD + if (PL_madskills) + PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart); +#endif + d = NULL; if (!PL_in_eval) { if (*s == '#' && *(s+1) == '!') d = s + 2; @@ -2852,7 +3538,8 @@ Perl_yylex(pTHX) * at least, set argv[0] to the basename of the Perl * interpreter. So, having found "#!", we'll set it right. */ - SV * const x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */ + SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, + SVt_PV)); /* $^X */ assert(SvPOK(x) || SvGMAGICAL(x)); if (sv_eq(x, CopFILESV(PL_curcop))) { sv_setpvn(x, ipath, ipathend - ipath); @@ -2893,7 +3580,7 @@ Perl_yylex(pTHX) } } if (d < ipath) - d = Nullch; + d = NULL; } #endif } @@ -2912,7 +3599,7 @@ Perl_yylex(pTHX) while (*c && !strchr("; \t\r\n\f\v#", *c)) c++; if (c < d) - d = Nullch; /* "perl" not in first word; ignore */ + d = NULL; /* "perl" not in first word; ignore */ else *s = '#'; /* Don't try to parse shebang line */ } @@ -2950,15 +3637,15 @@ Perl_yylex(pTHX) } #endif if (d) { - const U32 oldpdb = PL_perldb; - const bool oldn = PL_minus_n; - const bool oldp = PL_minus_p; - 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; + do { if (*d == 'M' || *d == 'm' || *d == 'C') { const char * const m = d; @@ -2984,20 +3671,12 @@ Perl_yylex(pTHX) sv_setpvn(PL_linestr, "", 0); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = Nullch; + PL_last_lop = PL_last_uni = NULL; PL_preambled = FALSE; if (PERLDB_LINE) (void)gv_fetchfile(PL_origfilename); goto retry; } - if (PL_doswitches && !switches_done) { - int argc = PL_origargc; - char **argv = PL_origargv; - do { - argc--,argv++; - } while (argc && argv[0][0] == '-' && argv[0][1]); - init_argv_symbols(argc,argv); - } } } } @@ -3018,24 +3697,46 @@ Perl_yylex(pTHX) #ifdef MACOS_TRADITIONAL case '\312': #endif +#ifdef PERL_MAD + PL_realtokenstart = -1; + s = SKIPSPACE0(s); +#else s++; +#endif goto retry; case '#': case '\n': +#ifdef PERL_MAD + PL_realtokenstart = -1; + if (PL_madskills) + PL_faketokens = 0; +#endif if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) { if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) { /* handle eval qq[#line 1 "foo"\n ...] */ CopLINE_dec(PL_curcop); incline(s); } - d = PL_bufend; - while (s < d && *s != '\n') - s++; - if (s < d) - s++; - else if (s > d) /* Found by Ilya: feed random input to Perl. */ - Perl_croak(aTHX_ "panic: input overflow"); - incline(s); + if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) { + s = SKIPSPACE0(s); + if (!PL_in_eval || PL_rsfp) + incline(s); + } + else { + d = s; + while (d < PL_bufend && *d != '\n') + d++; + if (d < PL_bufend) + d++; + else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */ + Perl_croak(aTHX_ "panic: input overflow"); +#ifdef PERL_MAD + if (PL_madskills) + PL_thiswhite = newSVpvn(s, d - s); +#endif + s = d; + incline(s); + } if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { PL_bufptr = s; PL_lex_state = LEX_FORMLINE; @@ -3043,13 +3744,48 @@ Perl_yylex(pTHX) } } else { +#ifdef PERL_MAD + if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) { + if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') { + PL_faketokens = 0; + s = SKIPSPACE0(s); + TOKEN(PEG); /* make sure any #! line is accessible */ + } + s = SKIPSPACE0(s); + } + else { +/* if (PL_madskills && PL_lex_formbrack) { */ + d = s; + while (d < PL_bufend && *d != '\n') + d++; + if (d < PL_bufend) + d++; + else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */ + Perl_croak(aTHX_ "panic: input overflow"); + if (PL_madskills && CopLINE(PL_curcop) >= 1) { + if (!PL_thiswhite) + PL_thiswhite = newSVpvn("",0); + if (CopLINE(PL_curcop) == 1) { + sv_setpvn(PL_thiswhite, "", 0); + PL_faketokens = 0; + } + sv_catpvn(PL_thiswhite, s, d - s); + } + s = d; +/* } + *s = '\0'; + PL_bufend = s; */ + } +#else *s = '\0'; PL_bufend = s; +#endif } goto retry; case '-': if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) { I32 ftst = 0; + char tmp; s++; PL_bufptr = s; @@ -3092,7 +3828,7 @@ Perl_yylex(pTHX) case 'T': ftst = OP_FTTEXT; break; case 'B': ftst = OP_FTBINARY; break; case 'M': case 'A': case 'C': - gv_fetchpv("\024",TRUE, SVt_PV); + gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV); switch (tmp) { case 'M': ftst = OP_FTMTIME; break; case 'A': ftst = OP_FTATIME; break; @@ -3120,49 +3856,53 @@ Perl_yylex(pTHX) s = --PL_bufptr; } } - tmp = *s++; - if (*s == tmp) { - s++; + { + const char tmp = *s++; + if (*s == tmp) { + s++; + if (PL_expect == XOPERATOR) + TERM(POSTDEC); + else + OPERATOR(PREDEC); + } + else if (*s == '>') { + s++; + s = SKIPSPACE1(s); + if (isIDFIRST_lazy_if(s,UTF)) { + s = force_word(s,METHOD,FALSE,TRUE,FALSE); + TOKEN(ARROW); + } + else if (*s == '$') + OPERATOR(ARROW); + else + TERM(ARROW); + } if (PL_expect == XOPERATOR) - TERM(POSTDEC); - else - OPERATOR(PREDEC); - } - else if (*s == '>') { - s++; - s = skipspace(s); - if (isIDFIRST_lazy_if(s,UTF)) { - s = force_word(s,METHOD,FALSE,TRUE,FALSE); - TOKEN(ARROW); + Aop(OP_SUBTRACT); + else { + if (isSPACE(*s) || !isSPACE(*PL_bufptr)) + check_uni(); + OPERATOR('-'); /* unary minus */ } - else if (*s == '$') - OPERATOR(ARROW); - else - TERM(ARROW); - } - if (PL_expect == XOPERATOR) - Aop(OP_SUBTRACT); - else { - if (isSPACE(*s) || !isSPACE(*PL_bufptr)) - check_uni(); - OPERATOR('-'); /* unary minus */ } case '+': - tmp = *s++; - if (*s == tmp) { - s++; + { + const char tmp = *s++; + if (*s == tmp) { + s++; + if (PL_expect == XOPERATOR) + TERM(POSTINC); + else + OPERATOR(PREINC); + } if (PL_expect == XOPERATOR) - TERM(POSTINC); - else - OPERATOR(PREINC); - } - if (PL_expect == XOPERATOR) - Aop(OP_ADD); - else { - if (isSPACE(*s) || !isSPACE(*PL_bufptr)) - check_uni(); - OPERATOR('+'); + Aop(OP_ADD); + else { + if (isSPACE(*s) || !isSPACE(*PL_bufptr)) + check_uni(); + OPERATOR('+'); + } } case '*': @@ -3201,17 +3941,29 @@ Perl_yylex(pTHX) PL_lex_brackets++; /* FALL THROUGH */ case '~': + if (s[1] == '~' + && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) + && FEATURE_IS_ENABLED("~~")) + { + s += 2; + Eop(OP_SMARTMATCH); + } case ',': - tmp = *s++; - OPERATOR(tmp); + { + const char tmp = *s++; + OPERATOR(tmp); + } case ':': if (s[1] == ':') { len = 0; - goto just_a_word; + goto just_a_word_zero_gv; } s++; switch (PL_expect) { OP *attrs; +#ifdef PERL_MAD + I32 stuffstart; +#endif case XOPERATOR: if (!PL_in_my || PL_lex_state != LEX_NORMAL) break; @@ -3223,9 +3975,13 @@ Perl_yylex(pTHX) case XATTRTERM: PL_expect = XTERMBLOCK; grabattrs: - s = skipspace(s); - attrs = Nullop; +#ifdef PERL_MAD + stuffstart = s - SvPVX(PL_linestr) - 1; +#endif + s = PEEKSPACE(s); + attrs = NULL; while (isIDFIRST_lazy_if(s,UTF)) { + I32 tmp; d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) { if (tmp < 0) tmp = -tmp; @@ -3262,16 +4018,18 @@ Perl_yylex(pTHX) attrs = append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, sv)); SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; + PL_lex_stuff = NULL; } else { if (len == 6 && strnEQ(s, "unique", len)) { - if (PL_in_my == KEY_our) + if (PL_in_my == KEY_our) { #ifdef USE_ITHREADS GvUNIQUE_on(cGVOPx_gv(yylval.opval)); #else - ; /* 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"); } @@ -3301,38 +4059,51 @@ Perl_yylex(pTHX) newSVOP(OP_CONST, 0, newSVpvn(s, len))); } - s = skipspace(d); + s = PEEKSPACE(d); if (*s == ':' && s[1] != ':') - s = skipspace(s+1); + s = PEEKSPACE(s+1); else if (s == d) break; /* require real whitespace or :'s */ + /* XXX losing whitespace on sequential attributes here */ } - tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */ - if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) { - const char q = ((*s == '\'') ? '"' : '\''); - /* If here for an expression, and parsed no attrs, back off. */ - if (tmp == '=' && !attrs) { - s = PL_bufptr; - break; + { + const char tmp + = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */ + if (*s != ';' && *s != '}' && *s != tmp + && (tmp != '=' || *s != ')')) { + const char q = ((*s == '\'') ? '"' : '\''); + /* If here for an expression, and parsed no attrs, back + off. */ + if (tmp == '=' && !attrs) { + s = PL_bufptr; + break; + } + /* MUST advance bufptr here to avoid bogus "at end of line" + 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" ); + if (attrs) + op_free(attrs); + OPERATOR(':'); } - /* MUST advance bufptr here to avoid bogus "at end of line" - context messages from yyerror(). - */ - PL_bufptr = s; - if (!*s) - yyerror("Unterminated attribute list"); - else - yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list", - q, *s, q)); - if (attrs) - op_free(attrs); - OPERATOR(':'); } got_attrs: if (attrs) { - PL_nextval[PL_nexttoke].opval = attrs; + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.opval = attrs; + CURMAD('_', PL_nextwhite); force_next(THING); } +#ifdef PERL_MAD + if (PL_madskills) { + PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart, + (s - SvPVX(PL_linestr)) - stuffstart); + } +#endif TOKEN(COLONATTR); } OPERATOR(':'); @@ -3342,18 +4113,22 @@ Perl_yylex(pTHX) PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */ else PL_expect = XTERM; - s = skipspace(s); + s = SKIPSPACE1(s); TOKEN('('); case ';': CLINE; - tmp = *s++; - OPERATOR(tmp); + { + const char tmp = *s++; + OPERATOR(tmp); + } case ')': - tmp = *s++; - s = skipspace(s); - if (*s == '{') - PREBLOCK(tmp); - TERM(tmp); + { + const char tmp = *s++; + s = SKIPSPACE1(s); + if (*s == '{') + PREBLOCK(tmp); + TERM(tmp); + } case ']': s++; if (PL_lex_brackets <= 0) @@ -3424,7 +4199,7 @@ Perl_yylex(pTHX) PL_lex_brackstack[PL_lex_brackets++] = XTERM; else PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; - s = skipspace(s); + s = SKIPSPACE1(s); if (*s == '}') { if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) { PL_expect = XTERM; @@ -3544,6 +4319,13 @@ Perl_yylex(pTHX) PL_expect &= XENUMMASK; PL_lex_state = LEX_INTERPEND; PL_bufptr = s; +#if 0 + if (PL_madskills) { + if (!PL_thiswhite) + PL_thiswhite = newSVpvn("",0); + sv_catpvn(PL_thiswhite,"}",1); + } +#endif return yylex(); /* ignore fake brackets */ } if (*s == '-' && s[1] == '>') @@ -3557,12 +4339,20 @@ Perl_yylex(pTHX) PL_bufptr = s; return yylex(); /* ignore fake brackets */ } + start_force(PL_curforce); + if (PL_madskills) { + curmad('X', newSVpvn(s-1,1)); + CURMAD('_', PL_thiswhite); + } force_next('}'); +#ifdef PERL_MAD + if (!PL_thistoken) + PL_thistoken = newSVpvn("",0); +#endif TOKEN(';'); case '&': s++; - tmp = *s++; - if (tmp == '&') + if (*s++ == '&') AOPERATOR(ANDAND); s--; if (PL_expect == XOPERATOR) { @@ -3588,47 +4378,58 @@ Perl_yylex(pTHX) case '|': s++; - tmp = *s++; - if (tmp == '|') + if (*s++ == '|') AOPERATOR(OROR); s--; BOop(OP_BIT_OR); case '=': s++; - tmp = *s++; - if (tmp == '=') - Eop(OP_EQ); - if (tmp == '>') - OPERATOR(','); - if (tmp == '~') - PMop(OP_MATCH); - if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) && strchr("+-*/%.^&|<",tmp)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp); - s--; - if (PL_expect == XSTATE && isALPHA(tmp) && - (s == PL_linestart+1 || s[-2] == '\n') ) { - if (PL_in_eval && !PL_rsfp) { - d = PL_bufend; - while (s < d) { - if (*s++ == '\n') { - incline(s); - if (strnEQ(s,"=cut",4)) { - s = strchr(s,'\n'); - if (s) - s++; - else - s = d; - incline(s); - goto retry; + const char tmp = *s++; + if (tmp == '=') + Eop(OP_EQ); + if (tmp == '>') + OPERATOR(','); + if (tmp == '~') + PMop(OP_MATCH); + if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) + && strchr("+-*/%.^&|<",tmp)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "Reversed %c= operator",(int)tmp); + s--; + if (PL_expect == XSTATE && isALPHA(tmp) && + (s == PL_linestart+1 || s[-2] == '\n') ) + { + if (PL_in_eval && !PL_rsfp) { + d = PL_bufend; + while (s < d) { + if (*s++ == '\n') { + incline(s); + if (strnEQ(s,"=cut",4)) { + s = strchr(s,'\n'); + if (s) + s++; + else + s = d; + incline(s); + goto retry; + } + } } + goto retry; + } +#ifdef PERL_MAD + if (PL_madskills) { + if (!PL_thiswhite) + PL_thiswhite = newSVpvn("",0); + sv_catpvn(PL_thiswhite, PL_linestart, + PL_bufend - PL_linestart); } +#endif + s = PL_bufend; + PL_doextract = TRUE; + goto retry; } - goto retry; - } - s = PL_bufend; - PL_doextract = TRUE; - goto retry; } if (PL_lex_brackets < PL_lex_formbrack) { const char *t; @@ -3647,27 +4448,30 @@ Perl_yylex(pTHX) OPERATOR(ASSIGNOP); case '!': s++; - tmp = *s++; - if (tmp == '=') { - /* was this !=~ where !~ was meant? - * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */ - - if (*s == '~' && ckWARN(WARN_SYNTAX)) { - const char *t = s+1; - - while (t < PL_bufend && isSPACE(*t)) - ++t; - - if (*t == '/' || *t == '?' || - ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) || - (*t == 't' && t[1] == 'r' && !isALNUM(t[2]))) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "!=~ should be !~"); - } - Eop(OP_NE); - } - if (tmp == '~') - PMop(OP_NOT); + { + const char tmp = *s++; + if (tmp == '=') { + /* was this !=~ where !~ was meant? + * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */ + + if (*s == '~' && ckWARN(WARN_SYNTAX)) { + const char *t = s+1; + + while (t < PL_bufend && isSPACE(*t)) + ++t; + + if (*t == '/' || *t == '?' || + ((*t == 'm' || *t == 's' || *t == 'y') + && !isALNUM(t[1])) || + (*t == 't' && t[1] == 'r' && !isALNUM(t[2]))) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "!=~ should be !~"); + } + Eop(OP_NE); + } + if (tmp == '~') + PMop(OP_NOT); + } s--; OPERATOR('!'); case '<': @@ -3681,25 +4485,29 @@ Perl_yylex(pTHX) TERM(sublex_start()); } s++; - tmp = *s++; - if (tmp == '<') - SHop(OP_LEFT_SHIFT); - if (tmp == '=') { - tmp = *s++; - if (tmp == '>') - Eop(OP_NCMP); - s--; - Rop(OP_LE); + { + char tmp = *s++; + if (tmp == '<') + SHop(OP_LEFT_SHIFT); + if (tmp == '=') { + tmp = *s++; + if (tmp == '>') + Eop(OP_NCMP); + s--; + Rop(OP_LE); + } } s--; Rop(OP_LT); case '>': s++; - tmp = *s++; - if (tmp == '>') - SHop(OP_RIGHT_SHIFT); - if (tmp == '=') - Rop(OP_GE); + { + const char tmp = *s++; + if (tmp == '>') + SHop(OP_RIGHT_SHIFT); + if (tmp == '=') + Rop(OP_GE); + } s--; Rop(OP_GT); @@ -3709,7 +4517,7 @@ Perl_yylex(pTHX) if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; - depcom(); + deprecate_old(commaless_variable_list); return REPORT(','); /* grandfather non-comma-format format */ } } @@ -3747,93 +4555,102 @@ Perl_yylex(pTHX) } d = s; - tmp = (I32)*s; - if (PL_lex_state == LEX_NORMAL) - s = skipspace(s); - - if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { - if (*s == '[') { - PL_tokenbuf[0] = '@'; - if (ckWARN(WARN_SYNTAX)) { - char *t; - for(t = s + 1; - isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$'; - t++) ; - if (*t++ == ',') { - PL_bufptr = skipspace(PL_bufptr); - while (t < PL_bufend && *t != ']') - t++; - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Multidimensional syntax %.*s not supported", - (t - PL_bufptr) + 1, PL_bufptr); - } - } - } - else if (*s == '{') { - char *t; - PL_tokenbuf[0] = '%'; - if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX) - && (t = strchr(s, '}')) && (t = strchr(t, '='))) - { - char tmpbuf[sizeof PL_tokenbuf]; - for (t++; isSPACE(*t); t++) ; - if (isIDFIRST_lazy_if(t,UTF)) { - STRLEN len; - t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len); - for (; isSPACE(*t); t++) ; - if (*t == ';' && get_cv(tmpbuf, FALSE)) + { + const char tmp = *s; + if (PL_lex_state == LEX_NORMAL) + s = SKIPSPACE1(s); + + if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) + && intuit_more(s)) { + if (*s == '[') { + PL_tokenbuf[0] = '@'; + if (ckWARN(WARN_SYNTAX)) { + char *t; + for(t = s + 1; + isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$'; + t++) ; + if (*t++ == ',') { + PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */ + while (t < PL_bufend && *t != ']') + t++; Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "You need to quote \"%s\"", tmpbuf); + "Multidimensional syntax %.*s not supported", + (int)((t - PL_bufptr) + 1), PL_bufptr); + } } } + else if (*s == '{') { + char *t; + PL_tokenbuf[0] = '%'; + if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX) + && (t = strchr(s, '}')) && (t = strchr(t, '='))) + { + char tmpbuf[sizeof PL_tokenbuf]; + for (t++; isSPACE(*t); t++) ; + if (isIDFIRST_lazy_if(t,UTF)) { + STRLEN dummylen; + t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, + &dummylen); + for (; isSPACE(*t); t++) ; + if (*t == ';' && get_cv(tmpbuf, FALSE)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "You need to quote \"%s\"", + tmpbuf); + } + } + } } - } - PL_expect = XOPERATOR; - if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) { - const bool islop = (PL_last_lop == PL_oldoldbufptr); - if (!islop || PL_last_lop_op == OP_GREPSTART) - PL_expect = XOPERATOR; - else if (strchr("$@\"'`q", *s)) - PL_expect = XTERM; /* e.g. print $fh "foo" */ - else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF)) - PL_expect = XTERM; /* e.g. print $fh &sub */ - else if (isIDFIRST_lazy_if(s,UTF)) { - char tmpbuf[sizeof PL_tokenbuf]; - scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); - if ((tmp = keyword(tmpbuf, len))) { - /* binary operators exclude handle interpretations */ - switch (tmp) { - case -KEY_x: - case -KEY_eq: - case -KEY_ne: - case -KEY_gt: - case -KEY_lt: - case -KEY_ge: - case -KEY_le: - case -KEY_cmp: - break; - default: - PL_expect = XTERM; /* e.g. print $fh length() */ - break; + PL_expect = XOPERATOR; + if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) { + const bool islop = (PL_last_lop == PL_oldoldbufptr); + if (!islop || PL_last_lop_op == OP_GREPSTART) + PL_expect = XOPERATOR; + else if (strchr("$@\"'`q", *s)) + PL_expect = XTERM; /* e.g. print $fh "foo" */ + else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF)) + PL_expect = XTERM; /* e.g. print $fh &sub */ + else if (isIDFIRST_lazy_if(s,UTF)) { + char tmpbuf[sizeof PL_tokenbuf]; + int t2; + scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); + if ((t2 = keyword(tmpbuf, len))) { + /* binary operators exclude handle interpretations */ + switch (t2) { + case -KEY_x: + case -KEY_eq: + case -KEY_ne: + case -KEY_gt: + case -KEY_lt: + case -KEY_ge: + case -KEY_le: + case -KEY_cmp: + break; + default: + PL_expect = XTERM; /* e.g. print $fh length() */ + break; + } + } + else { + PL_expect = XTERM; /* e.g. print $fh subr() */ } } - else { - PL_expect = XTERM; /* e.g. print $fh subr() */ - } + else if (isDIGIT(*s)) + PL_expect = XTERM; /* e.g. print $fh 3 */ + else if (*s == '.' && isDIGIT(s[1])) + PL_expect = XTERM; /* e.g. print $fh .3 */ + else if ((*s == '?' || *s == '-' || *s == '+') + && !isSPACE(s[1]) && s[1] != '=') + PL_expect = XTERM; /* e.g. print $fh -1 */ + else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' + && s[1] != '/') + PL_expect = XTERM; /* e.g. print $fh /.../ + XXX except DORDOR operator + */ + else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) + && s[2] != '=') + PL_expect = XTERM; /* print $fh <<"EOF" */ } - else if (isDIGIT(*s)) - PL_expect = XTERM; /* e.g. print $fh 3 */ - else if (*s == '.' && isDIGIT(s[1])) - PL_expect = XTERM; /* e.g. print $fh .3 */ - else if ((*s == '?' || *s == '-' || *s == '+') - && !isSPACE(s[1]) && s[1] != '=') - PL_expect = XTERM; /* e.g. print $fh -1 */ - else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/') - PL_expect = XTERM; /* e.g. print $fh /.../ - XXX except DORDOR operator */ - else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=') - PL_expect = XTERM; /* print $fh <<"EOF" */ } PL_pending_ident = '$'; TOKEN('$'); @@ -3847,7 +4664,7 @@ Perl_yylex(pTHX) PREREF('@'); } if (PL_lex_state == LEX_NORMAL) - s = skipspace(s); + s = SKIPSPACE1(s); if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { if (*s == '{') PL_tokenbuf[0] = '%'; @@ -3860,10 +4677,11 @@ Perl_yylex(pTHX) t++; if (*t == '}' || *t == ']') { t++; - PL_bufptr = skipspace(PL_bufptr); + PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Scalar value %.*s better written as $%.*s", - t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1); + (int)(t-PL_bufptr), PL_bufptr, + (int)(t-PL_bufptr-1), PL_bufptr+1); } } } @@ -3878,7 +4696,7 @@ Perl_yylex(pTHX) } case '?': /* may either be conditional or pattern */ if(PL_expect == XOPERATOR) { - tmp = *s++; + char tmp = *s++; if(tmp == '?') { OPERATOR('?'); } @@ -3920,7 +4738,7 @@ Perl_yylex(pTHX) goto rightbracket; } if (PL_expect == XOPERATOR || !isDIGIT(s[1])) { - tmp = *s++; + char tmp = *s++; if (*s == tmp) { s++; if (*s == tmp) { @@ -3945,12 +4763,12 @@ Perl_yylex(pTHX) TERM(THING); case '\'': - s = scan_str(s,FALSE,FALSE); + s = scan_str(s,!!PL_madskills,FALSE); DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } ); if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; - depcom(); + deprecate_old(commaless_variable_list); return REPORT(','); /* grandfather non-comma-format format */ } else @@ -3962,12 +4780,12 @@ Perl_yylex(pTHX) TERM(sublex_start()); case '"': - s = scan_str(s,FALSE,FALSE); + s = scan_str(s,!!PL_madskills,FALSE); DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } ); if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; - depcom(); + deprecate_old(commaless_variable_list); return REPORT(','); /* grandfather non-comma-format format */ } else @@ -3987,7 +4805,7 @@ Perl_yylex(pTHX) TERM(sublex_start()); case '`': - s = scan_str(s,FALSE,FALSE); + s = scan_str(s,!!PL_madskills,FALSE); DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } ); if (PL_expect == XOPERATOR) no_op("Backticks",s); @@ -4022,7 +4840,7 @@ Perl_yylex(pTHX) const char c = *start; GV *gv; *start = '\0'; - gv = gv_fetchpv(s, FALSE, SVt_PVCV); + gv = gv_fetchpv(s, 0, SVt_PVCV); *start = c; if (!gv) { s = scan_num(s, &yylval); @@ -4067,9 +4885,10 @@ Perl_yylex(pTHX) case 'z': case 'Z': keylookup: { - orig_keyword = 0; - gv = Nullgv; - gvp = 0; + I32 tmp; + I32 orig_keyword = 0; + GV *gv = NULL; + GV **gvp = NULL; PL_bufptr = s; s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); @@ -4111,11 +4930,11 @@ Perl_yylex(pTHX) } if (tmp < 0) { /* second-class keyword? */ - GV *ogv = Nullgv; /* override (winner) */ - GV *hgv = Nullgv; /* hidden (loser) */ + GV *ogv = NULL; /* override (winner) */ + GV *hgv = NULL; /* hidden (loser) */ if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) { CV *cv; - if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) && + if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) && (cv = GvCVu(gv))) { if (GvIMPORTED_CV(gv)) @@ -4138,27 +4957,17 @@ Perl_yylex(pTHX) else if (gv && !gvp && -tmp==KEY_lock /* XXX generalizable kludge */ && GvCVu(gv) - && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE)) + && !hv_fetchs(GvHVn(PL_incgv), "Thread.pm", FALSE)) { tmp = 0; /* any sub overrides "weak" keyword */ } - else if (gv && !gvp - && tmp == -KEY_err - && GvCVu(gv) - && PL_expect != XOPERATOR - && PL_expect != XTERMORDORDOR) - { - /* any sub overrides the "err" keyword, except when really an - * operator is expected */ - tmp = 0; - } else { /* no override */ tmp = -tmp; if (tmp == KEY_dump && ckWARN(WARN_MISC)) { Perl_warner(aTHX_ packWARN(WARN_MISC), "dump() better written as CORE::dump()"); } - gv = Nullgv; + gv = NULL; gvp = 0; if (hgv && tmp != KEY_x && tmp != KEY_CORE && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */ @@ -4172,10 +4981,25 @@ Perl_yylex(pTHX) switch (tmp) { default: /* not a keyword */ + /* Trade off - by using this evil construction we can pull the + variable gv into the block labelled keylookup. If not, then + we have to give it function scope so that the goto from the + earlier ':' case doesn't bypass the initialisation. */ + if (0) { + just_a_word_zero_gv: + gv = NULL; + gvp = NULL; + orig_keyword = 0; + } just_a_word: { SV *sv; int pkgname = 0; const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); + CV *cv; +#ifdef PERL_MAD + SV *nextPL_nextwhite = 0; +#endif + /* Get the rest if it looks like a package qualifier */ @@ -4204,28 +5028,35 @@ Perl_yylex(pTHX) unless name is "Foo::", in which case Foo is a bearword (and a package name). */ - if (len > 2 && + if (len > 2 && !PL_madskills && PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':') { - if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV)) + if (ckWARN(WARN_BAREWORD) + && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV)) Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword \"%s\" refers to nonexistent package", PL_tokenbuf); len -= 2; PL_tokenbuf[len] = '\0'; - gv = Nullgv; + gv = NULL; gvp = 0; } else { + if (!gv) { + /* Mustn't actually add anything to a symbol table. + But also don't want to "initialise" any placeholder + constants that might already be there into full + blown PVGVs with attached PVCV. */ + gv = gv_fetchpvn_flags(PL_tokenbuf, len, + GV_NOADD_NOINIT, SVt_PVCV); + } len = 0; - if (!gv) - gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV); } /* if we saw a global override before, get the right name */ if (gvp) { - sv = newSVpvn("CORE::GLOBAL::",14); + sv = newSVpvs("CORE::GLOBAL::"); sv_catpv(sv,PL_tokenbuf); } else { @@ -4234,6 +5065,13 @@ Perl_yylex(pTHX) and so the scalar will be created correctly. */ sv = newSVpv(PL_tokenbuf,len); } +#ifdef PERL_MAD + if (PL_madskills && !PL_thistoken) { + char *start = SvPVX(PL_linestr) + PL_realtokenstart; + PL_thistoken = newSVpv(start,s - start); + PL_realtokenstart = s - SvPVX(PL_linestr); + } +#endif /* Presume this is going to be a bareword of some sort. */ @@ -4250,6 +5088,20 @@ Perl_yylex(pTHX) if (len) goto safe_bareword; + /* Do the explicit type check so that we don't need to force + the initialisation of the symbol table to have a real GV. + Beware - gv may not really be a PVGV, cv may not really be + a PVCV, (because of the space optimisations that gv_init + understands) But they're true if for this symbol there is + respectively a typeglob and a subroutine. + */ + cv = gv ? ((SvTYPE(gv) == SVt_PVGV) + /* Real typeglob, so get the real subroutine: */ + ? GvCVu(gv) + /* A proxy for a subroutine in this package? */ + : SvOK(gv) ? (CV *) gv : NULL) + : NULL; + /* See if it's the indirect object for a list operator. */ if (PL_oldoldbufptr && @@ -4263,11 +5115,15 @@ Perl_yylex(pTHX) bool immediate_paren = *s == '('; /* (Now we can afford to cross potential line boundary.) */ - s = skipspace(s); + s = SKIPSPACE2(s,nextPL_nextwhite); +#ifdef PERL_MAD + PL_nextwhite = nextPL_nextwhite; /* assume no & deception */ +#endif /* Two barewords in a row may indicate method call. */ - if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv))) + if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && + (tmp = intuit_method(s, gv, cv))) return REPORT(tmp); /* If not a declared subroutine, it's an indirect object. */ @@ -4276,7 +5132,7 @@ Perl_yylex(pTHX) if ( ( !immediate_paren && (PL_last_lop_op == OP_SORT || - ((!gv || !GvCVu(gv)) && + ((!gv || !cv) && (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)))) || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0' @@ -4289,7 +5145,13 @@ Perl_yylex(pTHX) } PL_expect = XOPERATOR; +#ifdef PERL_MAD + if (isSPACE(*s)) + s = SKIPSPACE2(s,nextPL_nextwhite); + PL_nextwhite = nextPL_nextwhite; +#else s = skipspace(s); +#endif /* Is this a word before a => operator? */ if (*s == '=' && s[1] == '>' && !pkgname) { @@ -4303,15 +5165,39 @@ Perl_yylex(pTHX) /* If followed by a paren, it's certainly a subroutine. */ if (*s == '(') { CLINE; - if (gv && GvCVu(gv)) { + if (cv) { for (d = s + 1; SPACE_OR_TAB(*d); d++) ; - if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) { + 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; } } - PL_nextval[PL_nexttoke].opval = yylval.opval; +#ifdef PERL_MAD + if (PL_madskills) { + PL_nextwhite = PL_thiswhite; + PL_thiswhite = 0; + } + start_force(PL_curforce); +#endif + NEXTVAL_NEXTTOKE.opval = yylval.opval; PL_expect = XOPERATOR; +#ifdef PERL_MAD + if (PL_madskills) { + PL_nextwhite = nextPL_nextwhite; + curmad('X', PL_thistoken); + PL_thistoken = newSVpvn("",0); + } +#endif force_next(WORD); yylval.ival = 0; TOKEN('&'); @@ -4319,7 +5205,7 @@ Perl_yylex(pTHX) /* If followed by var or block, call it a method (unless sub) */ - if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) { + if ((*s == '$' || *s == '{') && (!gv || !cv)) { PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_METHOD; PREBLOCK(METHOD); @@ -4329,38 +5215,48 @@ Perl_yylex(pTHX) if (!orig_keyword && (isIDFIRST_lazy_if(s,UTF) || *s == '$') - && (tmp = intuit_method(s,gv))) + && (tmp = intuit_method(s, gv, cv))) return REPORT(tmp); /* Not a method, so call it a subroutine (if defined) */ - if (gv && GvCVu(gv)) { - CV* cv; + if (cv) { if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS)) Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of -%s resolved as -&%s()", PL_tokenbuf, PL_tokenbuf); /* Check for a constant sub */ - cv = GvCV(gv); - if ((sv = cv_const_sv(cv))) { + if ((sv = gv_const_sv(gv))) { its_constant: SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv); - ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv); + ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv); yylval.opval->op_private = 0; TOKEN(WORD); } /* Resolve to GV now. */ + if (SvTYPE(gv) != SVt_PVGV) { + gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV); + assert (SvTYPE(gv) == SVt_PVGV); + /* cv must have been some sort of placeholder, so + now needs replacing with a real code reference. */ + cv = GvCV(gv); + } + op_free(yylval.opval); yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); yylval.opval->op_private |= OPpENTERSUB_NOPAREN; PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_ENTERSUB; /* Is there a prototype? */ - if (SvPOK(cv)) { - STRLEN len; - const char *proto = SvPV_const((SV*)cv, len); - if (!len) + if ( +#ifdef PERL_MAD + cv && +#endif + SvPOK(cv)) { + STRLEN protolen; + const char *proto = SvPV_const((SV*)cv, protolen); + if (!protolen) TERM(FUNC0SUB); if (*proto == '$' && proto[1] == '\0') OPERATOR(UNIOPSUB); @@ -4372,10 +5268,68 @@ Perl_yylex(pTHX) PREBLOCK(LSTOPSUB); } } - PL_nextval[PL_nexttoke].opval = yylval.opval; +#ifdef PERL_MAD + { + if (PL_madskills) { + PL_nextwhite = PL_thiswhite; + PL_thiswhite = 0; + } + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.opval = yylval.opval; + PL_expect = XTERM; + if (PL_madskills) { + PL_nextwhite = nextPL_nextwhite; + curmad('X', PL_thistoken); + PL_thistoken = newSVpvn("",0); + } + force_next(WORD); + TOKEN(NOAMP); + } + } + + /* Guess harder when madskills require "best effort". */ + if (PL_madskills && (!gv || !GvCVu(gv))) { + int probable_sub = 0; + if (strchr("\"'`$@%0123456789!*+{[<", *s)) + probable_sub = 1; + else if (isALPHA(*s)) { + char tmpbuf[1024]; + STRLEN tmplen; + d = s; + d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen); + if (!keyword(tmpbuf,tmplen)) + probable_sub = 1; + else { + while (d < PL_bufend && isSPACE(*d)) + d++; + if (*d == '=' && d[1] == '>') + probable_sub = 1; + } + } + 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; + 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; + PL_expect = XTERM; + PL_nextwhite = nextPL_nextwhite; + curmad('X', PL_thistoken); + PL_thistoken = newSVpvn("",0); + force_next(WORD); + TOKEN(NOAMP); + } +#else + NEXTVAL_NEXTTOKE.opval = yylval.opval; PL_expect = XTERM; force_next(WORD); TOKEN(NOAMP); +#endif } /* Call it a bare word */ @@ -4431,7 +5385,8 @@ Perl_yylex(pTHX) const char *pname = "main"; if (PL_tokenbuf[2] == 'D') pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash); - gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO); + gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD, + SVt_PVIO); GvMULTI_on(gv); if (!GvIO(gv)) GvIOp(gv) = newIO(); @@ -4503,7 +5458,22 @@ Perl_yylex(pTHX) } } #endif - PL_rsfp = Nullfp; +#ifdef PERL_MAD + if (PL_madskills) { + if (PL_realtokenstart >= 0) { + char *tstart = SvPVX(PL_linestr) + PL_realtokenstart; + if (!PL_endwhite) + PL_endwhite = newSVpvn("",0); + 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) ; + } +#endif + PL_rsfp = NULL; } goto fake_eof; } @@ -4560,14 +5530,35 @@ Perl_yylex(pTHX) case KEY_bless: LOP(OP_BLESS,XTERM); + case KEY_break: + FUN0(OP_BREAK); + case KEY_chop: UNI(OP_CHOP); case KEY_continue: + /* When 'use switch' is in effect, continue has a dual + life as a control operator. */ + { + if (!FEATURE_IS_ENABLED("switch")) + PREBLOCK(CONTINUE); + else { + /* We have to disambiguate the two senses of + "continue". If the next token is a '{' then + treat it as the start of a continue block; + otherwise treat it as a control operator. + */ + s = skipspace(s); + if (*s == '{') PREBLOCK(CONTINUE); + else + FUN0(OP_CONTINUE); + } + } case KEY_chdir: - (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */ + /* may use HOME */ + (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV); UNI(OP_CHDIR); case KEY_close: @@ -4609,8 +5600,11 @@ Perl_yylex(pTHX) case KEY_chroot: UNI(OP_CHROOT); + case KEY_default: + PREBLOCK(DEFAULT); + case KEY_do: - s = skipspace(s); + s = SKIPSPACE1(s); if (*s == '{') PRETERMBLOCK(DO); if (*s != '\'') @@ -4634,7 +5628,7 @@ Perl_yylex(pTHX) UNI(OP_DELETE); case KEY_dbmopen: - gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV); + gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV); LOP(OP_DBMOPEN,XTERM); case KEY_dbmclose: @@ -4658,10 +5652,12 @@ Perl_yylex(pTHX) UNI(OP_EXISTS); case KEY_exit: + if (PL_madskills) + UNI(OP_INT); UNI(OP_EXIT); case KEY_eval: - s = skipspace(s); + s = SKIPSPACE1(s); PL_expect = (*s == '{') ? XTERMBLOCK : XTERM; UNIBRACK(OP_ENTEREVAL); @@ -4702,23 +5698,30 @@ Perl_yylex(pTHX) case KEY_for: case KEY_foreach: yylval.ival = CopLINE(PL_curcop); - s = skipspace(s); + s = SKIPSPACE1(s); if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) { char *p = s; +#ifdef PERL_MAD + int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */ +#endif + if ((PL_bufend - p) >= 3 && strnEQ(p, "my", 2) && isSPACE(*(p + 2))) p += 2; else if ((PL_bufend - p) >= 4 && strnEQ(p, "our", 3) && isSPACE(*(p + 3))) p += 3; - p = skipspace(p); + p = PEEKSPACE(p); if (isIDFIRST_lazy_if(p,UTF)) { p = scan_ident(p, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE); - p = skipspace(p); + p = PEEKSPACE(p); } if (*p != '$') Perl_croak(aTHX_ "Missing $ on loop variable"); +#ifdef PERL_MAD + s = SvPVX(PL_linestr) + soff; +#endif } OPERATOR(FOR); @@ -4831,6 +5834,10 @@ Perl_yylex(pTHX) case KEY_getlogin: FUN0(OP_GETLOGIN); + case KEY_given: + yylval.ival = CopLINE(PL_curcop); + OPERATOR(GIVEN); + case KEY_glob: set_csh(); LOP(OP_GLOB,XTERM); @@ -4926,8 +5933,11 @@ Perl_yylex(pTHX) case KEY_our: case KEY_my: PL_in_my = tmp; - s = skipspace(s); + s = SKIPSPACE1(s); if (isIDFIRST_lazy_if(s,UTF)) { +#ifdef PERL_MAD + char* start = s; +#endif s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3)) goto really_sub; @@ -4938,6 +5948,13 @@ Perl_yylex(pTHX) sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf); yyerror(tmpbuf); } +#ifdef PERL_MAD + if (PL_madskills) { /* just add type to declarator token */ + sv_catsv(PL_thistoken, PL_nextwhite); + PL_nextwhite = 0; + sv_catpvn(PL_thistoken, start, s - start); + } +#endif } yylval.ival = 1; OPERATOR(MY); @@ -4954,13 +5971,13 @@ Perl_yylex(pTHX) OPERATOR(USE); case KEY_not: - if (*s == '(' || (s = skipspace(s), *s == '(')) + if (*s == '(' || (s = SKIPSPACE1(s), *s == '(')) FUN1(OP_NOT); else OPERATOR(NOTOP); case KEY_open: - s = skipspace(s); + s = SKIPSPACE1(s); if (isIDFIRST_lazy_if(s,UTF)) { const char *t; for (d = s; isALNUM_lazy_if(d,UTF); d++) ; @@ -4969,10 +5986,10 @@ Perl_yylex(pTHX) /* [perl #16184] */ && !(t[0] == '=' && t[1] == '>') ) { - int len = (int)(d-s); + int parms_len = (int)(d-s); Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE), "Precedence problem: open %.*s should be open(%.*s)", - len, s, len, s); + parms_len, s, parms_len, s); } } LOP(OP_OPEN,XTERM); @@ -5021,7 +6038,7 @@ Perl_yylex(pTHX) LOP(OP_PIPE_OP,XTERM); case KEY_q: - s = scan_str(s,FALSE,FALSE); + s = scan_str(s,!!PL_madskills,FALSE); if (!s) missingterm((char*)0); yylval.ival = OP_CONST; @@ -5031,13 +6048,13 @@ Perl_yylex(pTHX) UNI(OP_QUOTEMETA); case KEY_qw: - s = scan_str(s,FALSE,FALSE); + s = scan_str(s,!!PL_madskills,FALSE); if (!s) missingterm((char*)0); PL_expect = XOPERATOR; force_next(')'); if (SvCUR(PL_lex_stuff)) { - OP *words = Nullop; + OP *words = NULL; int warned = 0; d = SvPV_force(PL_lex_stuff, len); while (len) { @@ -5070,19 +6087,20 @@ Perl_yylex(pTHX) } } if (words) { - PL_nextval[PL_nexttoke].opval = words; + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.opval = words; force_next(THING); } } if (PL_lex_stuff) { SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; + PL_lex_stuff = NULL; } PL_expect = XTERM; TOKEN('('); case KEY_qq: - s = scan_str(s,FALSE,FALSE); + s = scan_str(s,!!PL_madskills,FALSE); if (!s) missingterm((char*)0); yylval.ival = OP_STRINGIFY; @@ -5095,7 +6113,7 @@ Perl_yylex(pTHX) TERM(sublex_start()); case KEY_qx: - s = scan_str(s,FALSE,FALSE); + s = scan_str(s,!!PL_madskills,FALSE); if (!s) missingterm((char*)0); yylval.ival = OP_BACKTICK; @@ -5106,7 +6124,7 @@ Perl_yylex(pTHX) OLDLOP(OP_RETURN); case KEY_require: - s = skipspace(s); + s = SKIPSPACE1(s); if (isDIGIT(*s)) { s = force_version(s, FALSE); } @@ -5188,6 +6206,10 @@ Perl_yylex(pTHX) else TOKEN(1); /* force error */ + case KEY_say: + checkcomma(s,PL_tokenbuf,"filehandle"); + LOP(OP_SAY,XREF); + case KEY_chomp: UNI(OP_CHOMP); @@ -5274,7 +6296,7 @@ Perl_yylex(pTHX) case KEY_sort: checkcomma(s,PL_tokenbuf,"subroutine name"); - s = skipspace(s); + s = SKIPSPACE1(s); if (*s == ';' || *s == ')') /* probably a close */ Perl_croak(aTHX_ "sort is now a reserved word"); PL_expect = XTERM; @@ -5315,25 +6337,56 @@ Perl_yylex(pTHX) bool have_name, have_proto, bad_proto; const int key = tmp; +#ifdef PERL_MAD + SV *tmpwhite = 0; + + char *tstart = SvPVX(PL_linestr) + PL_realtokenstart; + SV *subtoken = newSVpvn(tstart, s - tstart); + PL_thistoken = 0; + + d = s; + s = SKIPSPACE2(s,tmpwhite); +#else s = skipspace(s); +#endif if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' || (*s == ':' && s[1] == ':')) { +#ifdef PERL_MAD + SV *nametoke; +#endif + PL_expect = XBLOCK; attrful = XATTRBLOCK; /* remember buffer pos'n for later force_word */ tboffset = s - PL_oldbufptr; d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); +#ifdef PERL_MAD + if (PL_madskills) + nametoke = newSVpvn(s, d - s); +#endif if (strchr(tmpbuf, ':')) sv_setpv(PL_subname, tmpbuf); else { sv_setsv(PL_subname,PL_curstname); - sv_catpvn(PL_subname,"::",2); + sv_catpvs(PL_subname,"::"); sv_catpvn(PL_subname,tmpbuf,len); } - s = skipspace(d); have_name = TRUE; + +#ifdef PERL_MAD + + start_force(0); + CURMAD('X', nametoke); + CURMAD('_', tmpwhite); + (void) force_word(PL_oldbufptr + tboffset, WORD, + FALSE, TRUE, TRUE); + + s = SKIPSPACE2(d,tmpwhite); +#else + s = skipspace(d); +#endif } else { if (key == KEY_my) @@ -5347,9 +6400,14 @@ Perl_yylex(pTHX) if (key == KEY_format) { if (*s == '=') PL_lex_formbrack = PL_lex_brackets + 1; +#ifdef PERL_MAD + PL_thistoken = subtoken; + s = d; +#else if (have_name) (void) force_word(PL_oldbufptr + tboffset, WORD, FALSE, TRUE, TRUE); +#endif OPERATOR(FORMAT); } @@ -5357,7 +6415,7 @@ Perl_yylex(pTHX) if (*s == '(') { char *p; - s = scan_str(s,FALSE,FALSE); + s = scan_str(s,!!PL_madskills,FALSE); if (!s) Perl_croak(aTHX_ "Prototype not terminated"); /* strip spaces and check for bad characters */ @@ -5379,7 +6437,21 @@ Perl_yylex(pTHX) SvCUR_set(PL_lex_stuff, tmp); have_proto = TRUE; +#ifdef PERL_MAD + start_force(0); + CURMAD('q', PL_thisopen); + CURMAD('_', tmpwhite); + CURMAD('=', PL_thisstuff); + CURMAD('Q', PL_thisclose); + NEXTVAL_NEXTTOKE.opval = + (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff); + PL_lex_stuff = Nullsv; + force_next(THING); + + s = SKIPSPACE2(s,tmpwhite); +#else s = skipspace(s); +#endif } else have_proto = FALSE; @@ -5393,19 +6465,33 @@ Perl_yylex(pTHX) Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname); } +#ifdef PERL_MAD + start_force(0); + if (tmpwhite) { + if (PL_madskills) + curmad('^', newSVpvn("",0)); + CURMAD('_', tmpwhite); + } + force_next(0); + + PL_thistoken = subtoken; +#else if (have_proto) { - PL_nextval[PL_nexttoke].opval = + NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff); - PL_lex_stuff = Nullsv; + PL_lex_stuff = NULL; force_next(THING); } +#endif if (!have_name) { sv_setpv(PL_subname, PL_curstash ? "__ANON__" : "__ANON__::__ANON__"); TOKEN(ANONSUB); } +#ifndef PERL_MAD (void) force_word(PL_oldbufptr + tboffset, WORD, FALSE, TRUE, TRUE); +#endif if (key == KEY_my) TOKEN(MYSUB); TOKEN(SUB); @@ -5503,6 +6589,10 @@ Perl_yylex(pTHX) case KEY_vec: LOP(OP_VEC,XTERM); + case KEY_when: + yylval.ival = CopLINE(PL_curcop); + OPERATOR(WHEN); + case KEY_while: yylval.ival = CopLINE(PL_curcop); OPERATOR(WHILE); @@ -5526,10 +6616,11 @@ Perl_yylex(pTHX) char ctl_l[2]; ctl_l[0] = toCTRL('L'); ctl_l[1] = '\0'; - gv_fetchpv(ctl_l,TRUE, SVt_PV); + gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV); } #else - gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */ + /* Make sure $^L is defined */ + gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV); #endif UNI(OP_ENTERWRITE); @@ -5556,12 +6647,14 @@ Perl_yylex(pTHX) static int S_pending_ident(pTHX) { + dVAR; register char *d; register I32 tmp = 0; /* pit holds the identifier we read and pending_ident is reset */ char pit = PL_pending_ident; PL_pending_ident = 0; + /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */ DEBUG_T({ PerlIO_printf(Perl_debug_log, "### Pending identifier '%s'\n", PL_tokenbuf); }); @@ -5606,12 +6699,12 @@ S_pending_ident(pTHX) tmp = pad_findmy(PL_tokenbuf); if (tmp != NOT_IN_PAD) { /* might be an "our" variable" */ - if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) { + if (PAD_COMPNAME_FLAGS_isOUR(tmp)) { /* build ops for a bareword */ HV * const stash = PAD_COMPNAME_OURSTASH(tmp); HEK * const stashname = HvNAME_HEK(stash); SV * const sym = newSVhek(stashname); - sv_catpvn(sym, "::", 2); + sv_catpvs(sym, "::"); sv_catpv(sym, PL_tokenbuf+1); yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym); yylval.opval->op_private = OPpCONST_ENTERED; @@ -5655,7 +6748,7 @@ S_pending_ident(pTHX) table. */ if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) { - GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV); + GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV); if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) && ckWARN(WARN_AMBIGUOUS)) { @@ -5669,10 +6762,26 @@ 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_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE, - ((PL_tokenbuf[0] == '$') ? SVt_PV - : (PL_tokenbuf[0] == '@') ? SVt_PVAV - : SVt_PVHV)); + gv_fetchpv( + PL_tokenbuf+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 + * created and the only reference in the entire program was + * the single statement with the defined %foo::bar:: test. + * It appears that all code in the wild doing this actually + * wants to know whether sub-packages have been loaded, so + * by avoiding auto-vivifying symbol tables, we ensure that + * defined %foo::bar:: continues to be false, and the existing + * 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] == ':' + ? 0 + : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD), + ((PL_tokenbuf[0] == '$') ? SVt_PV + : (PL_tokenbuf[0] == '@') ? SVt_PVAV + : SVt_PVHV)); return WORD; } @@ -5683,6 +6792,7 @@ S_pending_ident(pTHX) I32 Perl_keyword (pTHX_ const char *name, I32 len) { + dVAR; switch (len) { case 1: /* 5 tokens of length 1 */ @@ -5863,7 +6973,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; } - case 3: /* 28 tokens of length 3 */ + case 3: /* 29 tokens of length 3 */ switch (name[0]) { case 'E': @@ -5952,7 +7062,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) case 'r': if (name[2] == 'r') { /* err */ - return -KEY_err; + return (FEATURE_IS_ENABLED("err") ? -KEY_err : 0); } goto unknown; @@ -6088,6 +7198,14 @@ Perl_keyword (pTHX_ const char *name, I32 len) case 's': switch (name[1]) { + case 'a': + if (name[2] == 'y') + { /* say */ + return (FEATURE_IS_ENABLED("say") ? -KEY_say : 0); + } + + goto unknown; + case 'i': if (name[2] == 'n') { /* sin */ @@ -6148,7 +7266,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; } - case 4: /* 40 tokens of length 4 */ + case 4: /* 41 tokens of length 4 */ switch (name[0]) { case 'C': @@ -6578,8 +7696,9 @@ Perl_keyword (pTHX_ const char *name, I32 len) } case 'w': - if (name[1] == 'a') + switch (name[1]) { + case 'a': switch (name[2]) { case 'i': @@ -6601,6 +7720,12 @@ Perl_keyword (pTHX_ const char *name, I32 len) default: goto unknown; } + + case 'h': + if (name[2] == 'e' && + name[3] == 'n') + { /* when */ + return (FEATURE_IS_ENABLED("switch") ? KEY_when : 0); } goto unknown; @@ -6609,7 +7734,11 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; } - case 5: /* 36 tokens of length 5 */ + default: + goto unknown; + } + + case 5: /* 38 tokens of length 5 */ switch (name[0]) { case 'B': @@ -6662,8 +7791,10 @@ Perl_keyword (pTHX_ const char *name, I32 len) } case 'b': - if (name[1] == 'l' && - name[2] == 'e' && + switch (name[1]) + { + case 'l': + if (name[2] == 'e' && name[3] == 's' && name[4] == 's') { /* bless */ @@ -6672,6 +7803,20 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; + case 'r': + if (name[2] == 'e' && + name[3] == 'a' && + name[4] == 'k') + { /* break */ + return (FEATURE_IS_ENABLED("switch") ? -KEY_break : 0); + } + + goto unknown; + + default: + goto unknown; + } + case 'c': switch (name[1]) { @@ -6785,6 +7930,17 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; } + case 'g': + if (name[1] == 'i' && + name[2] == 'v' && + name[3] == 'e' && + name[4] == 'n') + { /* given */ + return (FEATURE_IS_ENABLED("switch") ? KEY_given : 0); + } + + goto unknown; + case 'i': switch (name[1]) { @@ -7521,7 +8677,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; } - case 7: /* 28 tokens of length 7 */ + case 7: /* 29 tokens of length 7 */ switch (name[0]) { case 'D': @@ -7592,9 +8748,22 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; case 'e': - if (name[2] == 'f' && - name[3] == 'i' && - name[4] == 'n' && + if (name[2] == 'f') + { + switch (name[3]) + { + case 'a': + if (name[4] == 'u' && + name[5] == 'l' && + name[6] == 't') + { /* default */ + return (FEATURE_IS_ENABLED("switch") ? KEY_default : 0); + } + + goto unknown; + + case 'i': + if (name[4] == 'n' && name[5] == 'e' && name[6] == 'd') { /* defined */ @@ -7606,6 +8775,13 @@ Perl_keyword (pTHX_ const char *name, I32 len) default: goto unknown; } + } + + goto unknown; + + default: + goto unknown; + } case 'f': if (name[1] == 'o' && @@ -8979,21 +10155,22 @@ unknown: } STATIC void -S_checkcomma(pTHX_ register char *s, const char *name, const char *what) +S_checkcomma(pTHX_ const char *s, const char *name, const char *what) { - const char *w; + dVAR; 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++) ; + while (isSPACE(*w)) + ++w; if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (...) interpreted as function",name); @@ -9006,17 +10183,18 @@ S_checkcomma(pTHX_ register 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 == ',') { - int kw; - *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */ - kw = keyword(w, s - w) || get_cv(w, FALSE) != 0; - *s = ','; - if (kw) + GV* gv; + if (keyword(w, s - w)) + return; + + gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV); + if (gv && GvCVu(gv)) return; Perl_croak(aTHX_ "No comma allowed after %s", what); } @@ -9097,14 +10275,14 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv, /* Check the eval first */ if (!PL_in_eval && SvTRUE(ERRSV)) { - sv_catpv(ERRSV, "Propagated"); + sv_catpvs(ERRSV, "Propagated"); yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */ (void)POPs; - res = SvREFCNT_inc(sv); + res = SvREFCNT_inc_simple(sv); } else { res = POPs; - (void)SvREFCNT_inc(res); + SvREFCNT_inc_simple_void(res); } PUTBACK ; @@ -9129,6 +10307,7 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv, STATIC char * S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) { + dVAR; register char *d = dest; register char * const e = d + destlen - 3; /* two-character token, ending NUL */ for (;;) { @@ -9166,15 +10345,14 @@ S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_packag STATIC char * S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni) { - register char *d; - register char *e; - char *bracket = Nullch; + dVAR; + char *bracket = NULL; char funny = *s++; + register char *d = dest; + register char * const e = d + destlen + 3; /* two-character token, ending NUL */ if (isSPACE(*s)) - s = skipspace(s); - d = dest; - e = d + destlen - 3; /* two-character token, ending NUL */ + s = PEEKSPACE(s); if (isDIGIT(*s)) { while (isDIGIT(*s)) { if (d >= e) @@ -9249,15 +10427,15 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL if (isIDFIRST_lazy_if(d,UTF)) { d++; if (UTF) { - e = s; - while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') { - e += UTF8SKIP(e); - while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e)) - e += UTF8SKIP(e); + char *end = s; + while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') { + end += UTF8SKIP(end); + while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end)) + end += UTF8SKIP(end); } - Copy(s, d, e - s, char); - d += e - s; - s = e; + Copy(s, d, end - s, char); + d += end - s; + s = end; } else { while ((isALNUM(*s) || *s == ':') && d < e) @@ -9323,6 +10501,7 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL void Perl_pmflag(pTHX_ U32* pmfl, int ch) { + PERL_UNUSED_CONTEXT; if (ch == 'i') *pmfl |= PMf_FOLD; else if (ch == 'g') @@ -9342,11 +10521,17 @@ Perl_pmflag(pTHX_ U32* pmfl, int ch) STATIC char * S_scan_pat(pTHX_ char *start, I32 type) { + dVAR; PMOP *pm; - char *s = scan_str(start,FALSE,FALSE); + char *s = scan_str(start,!!PL_madskills,FALSE); + const char * const valid_flags = (type == OP_QR) ? "iomsx" : "iogcmsx"; +#ifdef PERL_MAD + char *modstart; +#endif + if (!s) { - char * const delimiter = skipspace(start); + 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" ); @@ -9355,19 +10540,22 @@ S_scan_pat(pTHX_ char *start, I32 type) pm = (PMOP*)newPMOP(type, 0); if (PL_multi_open == '?') pm->op_pmflags |= PMf_ONCE; - if(type == OP_QR) { - while (*s && strchr("iomsx", *s)) - pmflag(&pm->op_pmflags,*s++); - } - else { - while (*s && strchr("iogcmsx", *s)) - pmflag(&pm->op_pmflags,*s++); +#ifdef PERL_MAD + modstart = s; +#endif + while (*s && strchr(valid_flags, *s)) + pmflag(&pm->op_pmflags,*s++); +#ifdef PERL_MAD + if (PL_madskills && modstart != s) { + SV* tmptoken = newSVpvn(modstart, s - modstart); + append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0); } +#endif /* issue a warning if /c is specified,but /g is not */ if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL) && ckWARN(WARN_REGEXP)) { - Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g); + Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" ); } pm->op_pmpermflags = pm->op_pmflags; @@ -9385,29 +10573,51 @@ S_scan_subst(pTHX_ char *start) register PMOP *pm; I32 first_start; I32 es = 0; +#ifdef PERL_MAD + char *modstart; +#endif yylval.ival = OP_NULL; - s = scan_str(start,FALSE,FALSE); + s = scan_str(start,!!PL_madskills,FALSE); if (!s) Perl_croak(aTHX_ "Substitution pattern not terminated"); if (s[-1] == PL_multi_open) s--; +#ifdef PERL_MAD + if (PL_madskills) { + CURMAD('q', PL_thisopen); + CURMAD('_', PL_thiswhite); + CURMAD('E', PL_thisstuff); + CURMAD('Q', PL_thisclose); + PL_realtokenstart = s - SvPVX(PL_linestr); + } +#endif first_start = PL_multi_start; - s = scan_str(s,FALSE,FALSE); + s = scan_str(s,!!PL_madskills,FALSE); if (!s) { if (PL_lex_stuff) { SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; + PL_lex_stuff = NULL; } Perl_croak(aTHX_ "Substitution replacement not terminated"); } PL_multi_start = first_start; /* so whole substitution is taken together */ pm = (PMOP*)newPMOP(OP_SUBST, 0); + +#ifdef PERL_MAD + if (PL_madskills) { + CURMAD('z', PL_thisopen); + CURMAD('R', PL_thisstuff); + CURMAD('Z', PL_thisclose); + } + modstart = s; +#endif + while (*s) { if (*s == 'e') { s++; @@ -9419,24 +10629,30 @@ S_scan_subst(pTHX_ char *start) break; } - /* /c is not meaningful with s/// */ - if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) - { - Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst); +#ifdef PERL_MAD + if (PL_madskills) { + if (modstart != s) + curmad('m', newSVpvn(modstart, s - modstart)); + append_madprops(PL_thismad, (OP*)pm, 0); + PL_thismad = 0; + } +#endif + if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) { + Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" ); } if (es) { - SV *repl; + SV * const repl = newSVpvs(""); + PL_sublex_info.super_bufptr = s; PL_sublex_info.super_bufend = PL_bufend; PL_multi_end = 0; pm->op_pmflags |= PMf_EVAL; - repl = newSVpvn("",0); while (es-- > 0) sv_catpv(repl, es ? "eval " : "do "); - sv_catpvn(repl, "{ ", 2); + sv_catpvs(repl, "{"); sv_catsv(repl, PL_lex_repl); - sv_catpvn(repl, " };", 2); + sv_catpvs(repl, "}"); SvEVALED_on(repl); SvREFCNT_dec(PL_lex_repl); PL_lex_repl = repl; @@ -9451,31 +10667,53 @@ S_scan_subst(pTHX_ char *start) STATIC char * S_scan_trans(pTHX_ char *start) { + dVAR; register char* s; OP *o; short *tbl; I32 squash; I32 del; I32 complement; +#ifdef PERL_MAD + char *modstart; +#endif yylval.ival = OP_NULL; - s = scan_str(start,FALSE,FALSE); + s = scan_str(start,!!PL_madskills,FALSE); if (!s) Perl_croak(aTHX_ "Transliteration pattern not terminated"); + if (s[-1] == PL_multi_open) s--; +#ifdef PERL_MAD + if (PL_madskills) { + CURMAD('q', PL_thisopen); + CURMAD('_', PL_thiswhite); + CURMAD('E', PL_thisstuff); + CURMAD('Q', PL_thisclose); + PL_realtokenstart = s - SvPVX(PL_linestr); + } +#endif - s = scan_str(s,FALSE,FALSE); + s = scan_str(s,!!PL_madskills,FALSE); if (!s) { if (PL_lex_stuff) { SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; + PL_lex_stuff = NULL; } Perl_croak(aTHX_ "Transliteration replacement not terminated"); } + if (PL_madskills) { + CURMAD('z', PL_thisopen); + CURMAD('R', PL_thisstuff); + CURMAD('Z', PL_thisclose); + } complement = del = squash = 0; +#ifdef PERL_MAD + modstart = s; +#endif while (1) { switch (*s) { case 'c': @@ -9503,23 +10741,39 @@ S_scan_trans(pTHX_ char *start) PL_lex_op = o; yylval.ival = OP_TRANS; + +#ifdef PERL_MAD + if (PL_madskills) { + if (modstart != s) + curmad('m', newSVpvn(modstart, s - modstart)); + append_madprops(PL_thismad, o, 0); + PL_thismad = 0; + } +#endif + return s; } STATIC char * S_scan_heredoc(pTHX_ register char *s) { + dVAR; SV *herewas; I32 op_type = OP_SCALAR; I32 len; SV *tmpstr; char term; - const char newline[] = "\n"; const char *found_newline; register char *d; register char *e; char *peek; const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR)); +#ifdef PERL_MAD + I32 stuffstart = s - SvPVX(PL_linestr); + char *tstart; + + PL_realtokenstart = -1; +#endif s += 2; d = PL_tokenbuf; @@ -9552,6 +10806,16 @@ S_scan_heredoc(pTHX_ register char *s) *d++ = '\n'; *d = '\0'; len = d - PL_tokenbuf; + +#ifdef PERL_MAD + if (PL_madskills) { + tstart = PL_tokenbuf + !outer; + PL_thisclose = newSVpvn(tstart, len - !outer); + tstart = SvPVX(PL_linestr) + stuffstart; + PL_thisopen = newSVpvn(tstart, s - tstart); + stuffstart = s - SvPVX(PL_linestr); + } +#endif #ifndef PERL_STRICT_CR d = strchr(s, '\r'); if (d) { @@ -9576,16 +10840,39 @@ S_scan_heredoc(pTHX_ register char *s) s = olds; } #endif - if ( outer || !(found_newline = ninstr(s,PL_bufend,newline,newline+1)) ) { +#ifdef PERL_MAD + found_newline = 0; +#endif + if ( outer || !(found_newline = memchr(s, '\n', PL_bufend - s)) ) { herewas = newSVpvn(s,PL_bufend-s); } else { +#ifdef PERL_MAD + herewas = newSVpvn(s-1,found_newline-s+1); +#else s--; herewas = newSVpvn(s,found_newline-s); +#endif + } +#ifdef PERL_MAD + if (PL_madskills) { + tstart = SvPVX(PL_linestr) + stuffstart; + if (PL_thisstuff) + sv_catpvn(PL_thisstuff, tstart, s - tstart); + else + PL_thisstuff = newSVpvn(tstart, s - tstart); } +#endif s += SvCUR(herewas); - tmpstr = NEWSV(87,79); +#ifdef PERL_MAD + stuffstart = s - SvPVX(PL_linestr); + + if (found_newline) + s--; +#endif + + tmpstr = newSV(79); sv_upgrade(tmpstr, SVt_PVIV); if (term == '\'') { op_type = OP_CONST; @@ -9601,8 +10888,8 @@ S_scan_heredoc(pTHX_ register char *s) PL_multi_open = PL_multi_close = '<'; term = *PL_tokenbuf; if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) { - char *bufptr = PL_sublex_info.super_bufptr; - char *bufend = PL_sublex_info.super_bufend; + char * const bufptr = PL_sublex_info.super_bufptr; + char * const bufend = PL_sublex_info.super_bufend; char * const olds = s - SvCUR(herewas); s = strchr(bufptr, '\n'); if (!s) @@ -9638,6 +10925,15 @@ S_scan_heredoc(pTHX_ register char *s) missingterm(PL_tokenbuf); } sv_setpvn(tmpstr,d+1,s-d); +#ifdef PERL_MAD + if (PL_madskills) { + if (PL_thisstuff) + sv_catpvn(PL_thisstuff, d + 1, s - d); + else + PL_thisstuff = newSVpvn(d + 1, s - d); + stuffstart = s - SvPVX(PL_linestr); + } +#endif s += len - 1; CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */ @@ -9645,19 +10941,31 @@ S_scan_heredoc(pTHX_ register char *s) sv_setsv(PL_linestr,herewas); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = Nullch; + PL_last_lop = PL_last_uni = NULL; } else sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */ while (s >= PL_bufend) { /* multiple line string? */ +#ifdef PERL_MAD + if (PL_madskills) { + tstart = SvPVX(PL_linestr) + stuffstart; + if (PL_thisstuff) + sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart); + else + PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart); + } +#endif if (!outer || !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) { CopLINE_set(PL_curcop, (line_t)PL_multi_start); missingterm(PL_tokenbuf); } +#ifdef PERL_MAD + stuffstart = s - SvPVX(PL_linestr); +#endif CopLINE_inc(PL_curcop); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = Nullch; + PL_last_lop = PL_last_uni = NULL; #ifndef PERL_STRICT_CR if (PL_bufend - PL_linestart >= 2) { if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') || @@ -9674,13 +10982,13 @@ S_scan_heredoc(pTHX_ register char *s) PL_bufend[-1] = '\n'; #endif if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV *sv = NEWSV(88,0); + 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(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv); + av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop),sv); } if (*s == term && memEQ(s,PL_tokenbuf,len)) { STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr); @@ -9731,14 +11039,14 @@ retval: STATIC char * S_scan_inputsymbol(pTHX_ char *start) { + dVAR; register char *s = start; /* current position in buffer */ - register char *d; - const char *e; char *end; I32 len; - d = PL_tokenbuf; /* start of temp holding space */ - e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */ + char *d = PL_tokenbuf; /* start of temp holding space */ + const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */ + end = strchr(s, '\n'); if (!end) end = PL_bufend; @@ -9777,14 +11085,14 @@ S_scan_inputsymbol(pTHX_ char *start) if (d - PL_tokenbuf != len) { yylval.ival = OP_GLOB; set_csh(); - s = scan_str(start,FALSE,FALSE); + s = scan_str(start,!!PL_madskills,FALSE); if (!s) Perl_croak(aTHX_ "Glob not terminated"); return s; } else { bool readline_overriden = FALSE; - GV *gv_readline = Nullgv; + GV *gv_readline; GV **gvp; /* we're in a filehandle read situation */ d = PL_tokenbuf; @@ -9794,10 +11102,11 @@ S_scan_inputsymbol(pTHX_ char *start) Copy("ARGV",d,5,char); /* Check whether readline() is overriden */ - if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV)) + gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV); + if ((gv_readline && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)) || - ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE)) + ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE)) && (gv_readline = *gvp) != (GV*)&PL_sv_undef && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))) readline_overriden = TRUE; @@ -9812,17 +11121,17 @@ S_scan_inputsymbol(pTHX_ char *start) add symbol table ops */ if ((tmp = pad_findmy(d)) != NOT_IN_PAD) { - if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) { - HV *stash = PAD_COMPNAME_OURSTASH(tmp); - HEK *stashname = HvNAME_HEK(stash); - SV *sym = sv_2mortal(newSVhek(stashname)); - sv_catpvn(sym, "::", 2); + if (PAD_COMPNAME_FLAGS_isOUR(tmp)) { + HV * const stash = PAD_COMPNAME_OURSTASH(tmp); + HEK * const stashname = HvNAME_HEK(stash); + SV * const sym = sv_2mortal(newSVhek(stashname)); + sv_catpvs(sym, "::"); sv_catpv(sym, d+1); d = SvPVX(sym); goto intro_sym; } else { - OP *o = newOP(OP_PADSV, 0); + OP * const o = newOP(OP_PADSV, 0); o->op_targ = tmp; PL_lex_op = readline_overriden ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, @@ -9858,7 +11167,7 @@ intro_sym: /* If it's none of the above, it must be a literal filehandle ( or ) so build a simple readline OP */ else { - GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO); + GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO); PL_lex_op = readline_overriden ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, @@ -9919,6 +11228,7 @@ intro_sym: STATIC char * 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 */ register char *s = start; /* current position in the buffer */ @@ -9930,11 +11240,24 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) U8 termstr[UTF8_MAXBYTES]; /* terminating string */ STRLEN termlen; /* length of terminating string */ char *last = NULL; /* last position for nesting bracket */ +#ifdef PERL_MAD + int stuffstart; + char *tstart; +#endif /* skip space before the delimiter */ - if (isSPACE(*s)) - s = skipspace(s); + if (isSPACE(*s)) { + s = PEEKSPACE(s); + } +#ifdef PERL_MAD + if (PL_realtokenstart >= 0) { + stuffstart = PL_realtokenstart; + PL_realtokenstart = -1; + } + else + stuffstart = start - SvPVX(PL_linestr); +#endif /* mark where we are, in case we need to report errors */ CLINE; @@ -9961,9 +11284,9 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) PL_multi_close = term; - /* create a new SV to hold the contents. 87 is leak category, I'm - assuming. 79 is the SV's initial length. What a random number. */ - sv = NEWSV(87,79); + /* 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); SvIV_set(sv, termcode); (void)SvPOK_only(sv); /* validate pointer */ @@ -9972,6 +11295,13 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) if (keep_delims) sv_catpvn(sv, s, termlen); s += termlen; +#ifdef PERL_MAD + tstart = SvPVX(PL_linestr) + stuffstart; + if (!PL_thisopen && !keep_delims) { + PL_thisopen = newSVpvn(tstart, s - tstart); + stuffstart = s - SvPVX(PL_linestr); + } +#endif for (;;) { if (PL_encoding && !UTF) { bool cont = TRUE; @@ -9980,8 +11310,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) int offset = s - SvPVX_const(PL_linestr); const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr, &offset, (char*)termstr, termlen); - const char *ns = SvPVX_const(PL_linestr) + offset; - char *svlast = SvEND(sv) - 1; + const char * const ns = SvPVX_const(PL_linestr) + offset; + char * const svlast = SvEND(sv) - 1; for (; s < ns; s++) { if (*s == '\n' && !PL_rsfp) @@ -10136,38 +11466,75 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* if we're out of file, or a read fails, bail and reset the current line marker so we can report where the unterminated string began */ +#ifdef PERL_MAD + if (PL_madskills) { + char *tstart = SvPVX(PL_linestr) + stuffstart; + if (PL_thisstuff) + sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart); + else + PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart); + } +#endif if (!PL_rsfp || !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) { sv_free(sv); CopLINE_set(PL_curcop, (line_t)PL_multi_start); - return Nullch; + return NULL; } +#ifdef PERL_MAD + stuffstart = 0; +#endif /* we read a line, so increment our line counter */ CopLINE_inc(PL_curcop); /* update debugger info */ if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV *sv = NEWSV(88,0); + SV * const line_sv = newSV(0); - sv_upgrade(sv, SVt_PVMG); - sv_setsv(sv,PL_linestr); - (void)SvIOK_on(sv); - SvIV_set(sv, 0); - av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv); + 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); } /* having changed the buffer, we must update PL_bufend */ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = Nullch; + PL_last_lop = PL_last_uni = NULL; } /* at this point, we have successfully read the delimited string */ if (!PL_encoding || UTF) { +#ifdef PERL_MAD + if (PL_madskills) { + char *tstart = SvPVX(PL_linestr) + stuffstart; + if (PL_thisstuff) + sv_catpvn(PL_thisstuff, tstart, s - tstart); + else + PL_thisstuff = newSVpvn(tstart, s - tstart); + if (!PL_thisclose && !keep_delims) + PL_thisclose = newSVpvn(s,termlen); + } +#endif + if (keep_delims) sv_catpvn(sv, s, termlen); s += termlen; } +#ifdef PERL_MAD + else { + if (PL_madskills) { + char *tstart = SvPVX(PL_linestr) + stuffstart; + if (PL_thisstuff) + sv_catpvn(PL_thisstuff, tstart, s - tstart - termlen); + else + PL_thisstuff = newSVpvn(tstart, s - tstart - termlen); + if (!PL_thisclose && !keep_delims) + PL_thisclose = newSVpvn(s - termlen,termlen); + } + } +#endif if (has_utf8 || PL_encoding) SvUTF8_on(sv); @@ -10215,13 +11582,14 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) char * Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) { + dVAR; register const char *s = start; /* current position in buffer */ register char *d; /* destination in temp buffer */ register char *e; /* end of temp buffer */ NV nv; /* number read, as a double */ - SV *sv = Nullsv; /* place to put the converted number */ + SV *sv = NULL; /* place to put the converted number */ bool floatit; /* boolean: int or float? */ - const char *lastub = 0; /* position of last underbar */ + const char *lastub = NULL; /* position of last underbar */ static char const number_too_long[] = "Number too long"; /* We use the first character to decide what type of number this is */ @@ -10384,7 +11752,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); } - sv = NEWSV(92,0); + sv = newSV(0); if (overflowed) { if (n > 4294967295.0 && ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ packWARN(WARN_PORTABLE), @@ -10403,9 +11771,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, Nullsv, NULL); + sv, NULL, NULL); else if (PL_hints & HINT_NEW_BINARY) - sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL); + sv = new_constant(start, s - start, "binary", sv, NULL, NULL); } break; @@ -10537,7 +11905,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) /* make an sv from the string */ - sv = NEWSV(92,0); + sv = newSV(0); /* We try to do an integer conversion first if no characters @@ -10546,7 +11914,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) if (!floatit) { UV uv; - int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv); + const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv); if (flags == IS_NUMBER_IN_UV) { if (uv <= IV_MAX) @@ -10572,13 +11940,13 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) (PL_hints & HINT_NEW_INTEGER) ) sv = new_constant(PL_tokenbuf, d - PL_tokenbuf, (floatit ? "float" : "integer"), - sv, Nullsv, NULL); + sv, NULL, NULL); break; /* if it starts with a v, it could be a v-string */ case 'v': vstring: - sv = NEWSV(92,5); /* preallocate storage space */ + sv = newSV(5); /* preallocate storage space */ s = scan_vstring(s,sv); break; } @@ -10588,7 +11956,7 @@ vstring: if (sv) lvalp->opval = newSVOP(OP_CONST, 0, sv); else - lvalp->opval = Nullop; + lvalp->opval = NULL; return (char *)s; } @@ -10596,11 +11964,21 @@ vstring: STATIC char * S_scan_formline(pTHX_ register char *s) { + dVAR; register char *eol; register char *t; - SV *stuff = newSVpvn("",0); + SV * const stuff = newSVpvs(""); bool needargs = FALSE; bool eofmt = FALSE; +#ifdef PERL_MAD + char *tokenstart = s; + SV* savewhite; + + if (PL_madskills) { + savewhite = PL_thiswhite; + PL_thiswhite = 0; + } +#endif while (!needargs) { if (*s == '.') { @@ -10646,10 +12024,22 @@ S_scan_formline(pTHX_ register char *s) } s = (char*)eol; if (PL_rsfp) { +#ifdef PERL_MAD + if (PL_madskills) { + if (PL_thistoken) + sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart); + else + PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart); + } +#endif s = filter_gets(PL_linestr, PL_rsfp, 0); +#ifdef PERL_MAD + tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); +#else PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); +#endif PL_bufend = PL_bufptr + SvCUR(PL_linestr); - PL_last_lop = PL_last_uni = Nullch; + PL_last_lop = PL_last_uni = NULL; if (!s) { s = PL_bufptr; break; @@ -10662,7 +12052,8 @@ S_scan_formline(pTHX_ register char *s) PL_expect = XTERM; if (needargs) { PL_lex_state = LEX_NORMAL; - PL_nextval[PL_nexttoke].ival = 0; + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.ival = 0; force_next(','); } else @@ -10673,9 +12064,11 @@ S_scan_formline(pTHX_ register char *s) else if (PL_encoding) sv_recode_to_utf8(stuff, PL_encoding); } - PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff); + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff); force_next(THING); - PL_nextval[PL_nexttoke].ival = OP_FORMLINE; + start_force(PL_curforce); + NEXTVAL_NEXTTOKE.ival = OP_FORMLINE; force_next(LSTOP); } else { @@ -10684,6 +12077,15 @@ S_scan_formline(pTHX_ register char *s) PL_lex_formbrack = 0; PL_bufptr = s; } +#ifdef PERL_MAD + if (PL_madskills) { + if (PL_thistoken) + sv_catpvn(PL_thistoken, tokenstart, s - tokenstart); + else + PL_thistoken = newSVpvn(tokenstart, s - tokenstart); + PL_thiswhite = savewhite; + } +#endif return s; } @@ -10691,16 +12093,22 @@ 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) { + dVAR; const I32 oldsavestack_ix = PL_savestack_ix; - CV* outsidecv = PL_compcv; + CV* const outsidecv = PL_compcv; if (PL_compcv) { assert(SvTYPE(PL_compcv) == SVt_PVCV); @@ -10709,13 +12117,13 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) save_item(PL_subname); SAVESPTR(PL_compcv); - PL_compcv = (CV*)NEWSV(1104,0); + PL_compcv = (CV*)newSV(0); sv_upgrade((SV *)PL_compcv, 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(outsidecv); + CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv); CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax; return oldsavestack_ix; @@ -10727,6 +12135,7 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) int Perl_yywarn(pTHX_ const char *s) { + dVAR; PL_in_eval |= EVAL_WARNONLY; yyerror(s); PL_in_eval &= ~EVAL_WARNONLY; @@ -10736,6 +12145,7 @@ Perl_yywarn(pTHX_ const char *s) int Perl_yyerror(pTHX_ const char *s) { + dVAR; const char *where = NULL; const char *context = NULL; int contlen = -1; @@ -10788,7 +12198,7 @@ Perl_yyerror(pTHX_ const char *s) where = "within string"; } else { - SV *where_sv = sv_2mortal(newSVpvn("next char ", 10)); + SV * const where_sv = sv_2mortal(newSVpvs("next char ")); if (yychar < 32) Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar)); else if (isPRINT_LC(yychar)) @@ -10823,7 +12233,7 @@ Perl_yyerror(pTHX_ const char *s) OutCopFILE(PL_curcop)); } PL_in_my = 0; - PL_in_my_stash = Nullhv; + PL_in_my_stash = NULL; return 0; } #ifdef __SC__ @@ -10833,6 +12243,7 @@ Perl_yyerror(pTHX_ const char *s) STATIC char* S_swallow_bom(pTHX_ U8 *s) { + dVAR; const STRLEN slen = SvCUR(PL_linestr); switch (s[0]) { case 0xFF: @@ -10854,9 +12265,18 @@ S_swallow_bom(pTHX_ U8 *s) PL_bufend - (char*)s - 1, &newlen); sv_setpvn(PL_linestr, (const char*)news, newlen); +#ifdef PERL_MAD + s = (U8*)SvPVX(PL_linestr); + Copy(news, s, newlen, U8); + s[newlen] = '\0'; +#endif Safefree(news); SvUTF8_on(PL_linestr); s = (U8*)SvPVX(PL_linestr); +#ifdef PERL_MAD + /* FIXME - is this a general bug fix? */ + s[newlen] = '\0'; +#endif PL_bufend = SvPVX(PL_linestr) + newlen; } #else @@ -10932,7 +12352,8 @@ S_swallow_bom(pTHX_ U8 *s) static void restore_rsfp(pTHX_ void *f) { - PerlIO *fp = (PerlIO*)f; + dVAR; + PerlIO * const fp = (PerlIO*)f; if (PL_rsfp == PerlIO_stdin()) PerlIO_clearerr(PL_rsfp); @@ -10945,6 +12366,7 @@ restore_rsfp(pTHX_ void *f) static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) { + dVAR; const STRLEN old = SvCUR(sv); const I32 count = FILTER_READ(idx+1, sv, maxlen); DEBUG_P(PerlIO_printf(Perl_debug_log, @@ -10966,6 +12388,7 @@ utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen) { + dVAR; const STRLEN old = SvCUR(sv); const I32 count = FILTER_READ(idx+1, sv, maxlen); DEBUG_P(PerlIO_printf(Perl_debug_log, @@ -10991,7 +12414,7 @@ vstring, as well as updating the passed in sv. Function must be called like - sv = NEWSV(92,5); + sv = newSV(5); s = scan_vstring(s,sv); The sv should already be large enough to store the vstring @@ -11002,6 +12425,7 @@ passed in, for performance reasons. char * Perl_scan_vstring(pTHX_ const char *s, SV *sv) { + dVAR; const char *pos = s; const char *start = s; if (*pos == 'v') pos++; /* get past 'v' */ @@ -11020,16 +12444,15 @@ Perl_scan_vstring(pTHX_ const char *s, SV *sv) } if (!isALPHA(*pos)) { - UV rev; U8 tmpbuf[UTF8_MAXBYTES+1]; - U8 *tmpend; if (*s == 'v') s++; /* get past 'v' */ sv_setpvn(sv, "", 0); for (;;) { - rev = 0; + U8 *tmpend; + UV rev = 0; { /* this is atoi() that tolerates underscores */ const char *end = pos;