X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=4e9020187d7fb2989400e92899ebd5ca1573fbee;hb=50fc42481ed636dd7d07a6d83c1edcbf9d141c4d;hp=cde1861c9b389d8e6fdfd21a87a80e61b9b620f4;hpb=ba7cea30a89067841f31af65f8c824ae4dcff245;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index cde1861..4e90201 100644 --- a/toke.c +++ b/toke.c @@ -126,31 +126,42 @@ int yyactlevel = -1; * Also see LOP and lop() below. */ -#define TOKEN(retval) return (PL_bufptr = s,(int)retval) -#define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval) -#define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval)) -#define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval) -#define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval) -#define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval) -#define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval) -#define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX) -#define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP) -#define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0) -#define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1) -#define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP)) -#define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP)) -#define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP)) -#define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP)) -#define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP) -#define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP)) -#define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP)) -#define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP) -#define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP) +/* Note that REPORT() and REPORT2() will be expressions that supply + * their own trailing comma, not suitable for statements as such. */ +#ifdef DEBUGGING /* Serve -DT. */ +# define REPORT(x,retval) tokereport(x,s,(int)retval), +# define REPORT2(x,retval) tokereport(x,s, yylval.ival), +#else +# define REPORT(x,retval) +# define REPORT2(x,retval) +#endif + +#define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval) +#define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval) +#define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)) +#define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval) +#define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval) +#define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval) +#define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval) +#define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX) +#define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERM,PL_bufptr = s,(int)UNIOP) +#define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0) +#define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1) +#define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP)) +#define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP)) +#define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP)) +#define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP)) +#define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP) +#define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP)) +#define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP)) +#define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP) +#define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP) /* This bit of chicanery makes a unary function followed by * a parenthesis into a function with one argument, highest precedence. */ #define UNI(f) return(yylval.ival = f, \ + REPORT("uni",f) \ PL_expect = XTERM, \ PL_bufptr = s, \ PL_last_uni = PL_oldbufptr, \ @@ -158,6 +169,7 @@ int yyactlevel = -1; (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) ) #define UNIBRACK(f) return(yylval.ival = f, \ + REPORT("uni",f) \ PL_bufptr = s, \ PL_last_uni = PL_oldbufptr, \ (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) ) @@ -165,6 +177,24 @@ int yyactlevel = -1; /* grandfather return to old style */ #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP) +STATIC void +S_tokereport(pTHX_ char *thing, char* s, I32 rv) +{ + SV *report; + DEBUG_T({ + report = newSVpv(thing, 0); + Perl_sv_catpvf(aTHX_ report, ":line %i:%i:", CopLINE(PL_curcop), rv); + + if (s - PL_bufptr > 0) + sv_catpvn(report, PL_bufptr, s - PL_bufptr); + else { + if (PL_oldbufptr && *PL_oldbufptr) + sv_catpv(report, PL_tokenbuf); + } + PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report)); + }) +} + /* * S_ao * @@ -359,6 +389,8 @@ Perl_lex_start(pTHX_ SV *line) SAVEPPTR(PL_bufend); SAVEPPTR(PL_oldbufptr); SAVEPPTR(PL_oldoldbufptr); + SAVEPPTR(PL_last_lop); + SAVEPPTR(PL_last_uni); SAVEPPTR(PL_linestart); SAVESPTR(PL_linestr); SAVEPPTR(PL_lex_brackstack); @@ -401,6 +433,7 @@ Perl_lex_start(pTHX_ SV *line) 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; SvREFCNT_dec(PL_rs); PL_rs = newSVpvn("\n", 1); PL_rsfp = 0; @@ -444,7 +477,7 @@ S_incline(pTHX_ char *s) s += 4; else return; - if (*s == ' ' || *s == '\t') + if (SPACE_OR_TAB(*s)) s++; else return; @@ -546,6 +579,7 @@ S_skipspace(pTHX_ register char *s) 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; /* Close the filehandle. Could be from -P preprocessor, * STDIN, or a regular file. If we were reading code from @@ -677,6 +711,7 @@ S_lop(pTHX_ I32 f, int x, char *s) { yylval.ival = f; CLINE; + REPORT("lop", f) PL_expect = x; PL_bufptr = s; PL_last_lop = PL_oldbufptr; @@ -1002,6 +1037,8 @@ S_sublex_push(pTHX) SAVEPPTR(PL_bufptr); SAVEPPTR(PL_oldbufptr); SAVEPPTR(PL_oldoldbufptr); + SAVEPPTR(PL_last_lop); + SAVEPPTR(PL_last_uni); SAVEPPTR(PL_linestart); SAVESPTR(PL_linestr); SAVEPPTR(PL_lex_brackstack); @@ -1013,6 +1050,7 @@ S_sublex_push(pTHX) 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; SAVEFREESV(PL_linestr); PL_lex_dojoin = FALSE; @@ -1045,8 +1083,11 @@ STATIC I32 S_sublex_done(pTHX) { if (!PL_lex_starts++) { + SV *sv = newSVpvn("",0); + if (SvUTF8(PL_linestr)) + SvUTF8_on(sv); PL_expect = XOPERATOR; - yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0)); + yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); return THING; } @@ -1061,6 +1102,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; SAVEFREESV(PL_linestr); PL_lex_dojoin = FALSE; PL_lex_brackets = 0; @@ -1173,7 +1215,8 @@ S_scan_const(pTHX_ char *start) register char *d = SvPVX(sv); /* destination for copies */ bool dorange = FALSE; /* are we in a translit range? */ bool didrange = FALSE; /* did we just finish a range? */ - bool has_utf8 = FALSE; /* embedded \x{} */ + bool has_utf8 = (PL_linestr && SvUTF8(PL_linestr)); + /* the constant is UTF8 */ UV uv; I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) @@ -1197,6 +1240,17 @@ S_scan_const(pTHX_ char *start) I32 min; /* first character in range */ I32 max; /* last character in range */ + if (utf) { + char *c = (char*)utf8_hop((U8*)d, -1); + char *e = d++; + while (e-- > c) + *(e + 1) = *e; + *c = (char)0xff; + /* mark the range as done, and continue */ + dorange = FALSE; + didrange = TRUE; + continue; + } i = d - SvPVX(sv); /* remember current offset */ SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */ d = SvPVX(sv) + i; /* refresh d after realloc */ @@ -1313,8 +1367,6 @@ S_scan_const(pTHX_ char *start) /* backslashes */ if (*s == '\\' && s+1 < send) { - bool to_be_utf8 = FALSE; - s++; /* some backslashes we leave behind */ @@ -1357,8 +1409,7 @@ S_scan_const(pTHX_ char *start) "Unrecognized escape \\%c passed through", *s); /* default action is to copy the quoted character */ - *d++ = *s++; - continue; + goto default_action; } /* \132 indicates an octal constant */ @@ -1383,7 +1434,6 @@ S_scan_const(pTHX_ char *start) else { STRLEN len = 1; /* allow underscores */ uv = (UV)scan_hex(s + 1, e - s - 1, &len); - to_be_utf8 = TRUE; } s = e + 1; } @@ -1407,7 +1457,7 @@ S_scan_const(pTHX_ char *start) * repertoire. --jhi */ if (uv > 127) { - if (!has_utf8 && (to_be_utf8 || uv > 255)) { + if (!has_utf8 && uv > 255) { /* Might need to recode whatever we have * accumulated so far if it contains any * hibit chars. @@ -1425,11 +1475,9 @@ S_scan_const(pTHX_ char *start) if (hicount) { char *old_pvx = SvPVX(sv); char *src, *dst; - U8 tmpbuf[UTF8_MAXLEN+1]; - U8 *tmpend; d = SvGROW(sv, - SvCUR(sv) + hicount + 1) + + SvLEN(sv) + hicount + 1) + (d - old_pvx); src = d - 1; @@ -1438,10 +1486,8 @@ S_scan_const(pTHX_ char *start) while (src < dst) { if (UTF8_IS_CONTINUED(*src)) { - tmpend = uv_to_utf8(tmpbuf, (U8)*src--); - dst -= tmpend - tmpbuf; - Copy((char *)tmpbuf, dst+1, - tmpend - tmpbuf, char); + *dst-- = UTF8_EIGHT_BIT_LO(*src); + *dst-- = UTF8_EIGHT_BIT_HI(*src--); } else { *dst-- = *src--; @@ -1450,9 +1496,16 @@ S_scan_const(pTHX_ char *start) } } - if (to_be_utf8 || (has_utf8 && uv > 127) || uv > 255) { + if (has_utf8 || uv > 255) { d = (char*)uv_to_utf8((U8*)d, uv); has_utf8 = TRUE; + if (PL_lex_inwhat == OP_TRANS && + PL_sublex_info.sub_op) { + PL_sublex_info.sub_op->op_private |= + (PL_lex_repl ? OPpTRANS_FROM_UTF + : OPpTRANS_TO_UTF); + utf = TRUE; + } } else { *d++ = (char)uv; @@ -1480,6 +1533,8 @@ S_scan_const(pTHX_ char *start) res = newSVpvn(s + 1, e - s - 1); res = new_constant( Nullch, 0, "charnames", res, Nullsv, "\\N{...}" ); + if (has_utf8) + sv_utf8_upgrade(res); str = SvPV(res,len); if (!has_utf8 && SvUTF8(res)) { char *ostart = SvPVX(sv); @@ -1495,7 +1550,7 @@ S_scan_const(pTHX_ char *start) if (len > e - s + 4) { char *odest = SvPVX(sv); - SvGROW(sv, (SvCUR(sv) + len - (e - s + 4))); + SvGROW(sv, (SvLEN(sv) + len - (e - s + 4))); d = SvPVX(sv) + (d - odest); } Copy(str, d, len, char); @@ -1562,8 +1617,7 @@ S_scan_const(pTHX_ char *start) continue; } /* end if (backslash) */ - /* (now in tr/// code again) */ - + default_action: if (UTF8_IS_CONTINUED(*s) && (this_utf8 || has_utf8)) { STRLEN len = (STRLEN) -1; UV uv; @@ -1582,10 +1636,15 @@ S_scan_const(pTHX_ char *start) *d++ = *s++; } has_utf8 = TRUE; + if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { + PL_sublex_info.sub_op->op_private |= + (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF); + utf = TRUE; + } continue; } - *d++ = *s++; + *d++ = *s++; } /* while loop to process each character */ /* terminate the string and set up the sv */ @@ -2077,9 +2136,6 @@ S_find_in_my_stash(pTHX_ char *pkgname, I32 len) */ #ifdef USE_PURE_BISON -#ifdef __SC__ -#pragma segment Perl_yylex_r -#endif int Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp) { @@ -2093,7 +2149,8 @@ Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp) r = Perl_yylex(aTHX); - yyactlevel--; + if (yyactlevel > 0) + yyactlevel--; return r; } @@ -2111,6 +2168,7 @@ Perl_yylex(pTHX) STRLEN len; GV *gv = Nullgv; GV **gvp = 0; + bool bof = FALSE; /* check if there's an identifier for us to look at */ if (PL_pending_ident) { @@ -2521,6 +2579,7 @@ Perl_yylex(pTHX) sv_catpv(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; if (PERLDB_LINE && PL_curstash != PL_debstash) { SV *sv = NEWSV(85,0); @@ -2531,8 +2590,35 @@ Perl_yylex(pTHX) goto retry; } do { - bool bof = PL_rsfp ? TRUE : FALSE; - if (bof) { + bof = PL_rsfp ? TRUE : FALSE; + if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { + fake_eof: + if (PL_rsfp) { + if (PL_preprocess && !PL_in_eval) + (void)PerlProc_pclose(PL_rsfp); + else if ((PerlIO *)PL_rsfp == PerlIO_stdin()) + PerlIO_clearerr(PL_rsfp); + else + (void)PerlIO_close(PL_rsfp); + PL_rsfp = Nullfp; + PL_doextract = FALSE; + } + if (!PL_in_eval && (PL_minus_n || PL_minus_p)) { + sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : ""); + sv_catpv(PL_linestr,";}"); + PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); + PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; + 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; + sv_setpv(PL_linestr,""); + TOKEN(';'); /* not infinite loop because rsfp is NULL now */ + } + /* if it looks like the start of a BOM, check if it in fact is */ + else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) { #ifdef PERLIO_IS_STDIO # ifdef __GNU_LIBRARY__ # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */ @@ -2552,38 +2638,14 @@ Perl_yylex(pTHX) * Workaround? Maybe attach some extra state to PL_rsfp? */ if (!PL_preprocess) - bof = PerlIO_tell(PL_rsfp) == 0; + bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr); #else - bof = PerlIO_tell(PL_rsfp) == 0; + bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr); #endif - } - s = filter_gets(PL_linestr, PL_rsfp, 0); - if (s == Nullch) { - fake_eof: - if (PL_rsfp) { - if (PL_preprocess && !PL_in_eval) - (void)PerlProc_pclose(PL_rsfp); - else if ((PerlIO *)PL_rsfp == PerlIO_stdin()) - PerlIO_clearerr(PL_rsfp); - else - (void)PerlIO_close(PL_rsfp); - PL_rsfp = Nullfp; - PL_doextract = FALSE; - } - if (!PL_in_eval && (PL_minus_n || PL_minus_p)) { - sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : ""); - sv_catpv(PL_linestr,";}"); - PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); + if (bof) { PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - PL_minus_n = PL_minus_p = 0; - goto retry; + s = swallow_bom((U8*)s); } - PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); - sv_setpv(PL_linestr,""); - TOKEN(';'); /* not infinite loop because rsfp is NULL now */ - } else if (bof) { - PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - s = swallow_bom((U8*)s); } if (PL_doextract) { if (*s == '#' && s[1] == '!' && instr(s,"perl")) @@ -2594,6 +2656,7 @@ Perl_yylex(pTHX) sv_setpv(PL_linestr, ""); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; PL_doextract = FALSE; } } @@ -2608,6 +2671,7 @@ Perl_yylex(pTHX) av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); } PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; if (CopLINE(PL_curcop) == 1) { while (s < PL_bufend && isSPACE(*s)) s++; @@ -2751,6 +2815,7 @@ Perl_yylex(pTHX) sv_setpv(PL_linestr, ""); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; PL_preambled = FALSE; if (PERLDB_LINE) (void)gv_fetchfile(PL_origfilename); @@ -2862,7 +2927,7 @@ Perl_yylex(pTHX) if (ftst) { PL_last_lop_op = ftst; DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### Saw file test %c\n", ftst); + "### Saw file test %c\n", (int)ftst); } ) FTST(ftst); } @@ -2870,7 +2935,8 @@ Perl_yylex(pTHX) /* Assume it was a minus followed by a one-letter named * subroutine call (or a -bareword), then. */ DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### %c looked like a file test but was not\n", ftst); + "### %c looked like a file test but was not\n", + (int)ftst); } ) s -= 2; } @@ -3002,10 +3068,6 @@ Perl_yylex(pTHX) if (*d == '(') { d = scan_str(d,TRUE,TRUE); if (!d) { - if (PL_lex_stuff) { - SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; - } /* MUST advance bufptr here to avoid bogus "at end of line" context messages from yyerror(). */ @@ -3025,9 +3087,25 @@ Perl_yylex(pTHX) PL_lex_stuff = Nullsv; } else { - attrs = append_elem(OP_LIST, attrs, - newSVOP(OP_CONST, 0, - newSVpvn(s, len))); + if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len)) + CvLVALUE_on(PL_compcv); + else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len)) + CvLOCKED_on(PL_compcv); + else if (!PL_in_my && len == 6 && strnEQ(s, "method", len)) + CvMETHOD_on(PL_compcv); +#ifdef USE_ITHREADS + else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "shared", len)) + GvSHARED_on(cGVOPx_gv(yylval.opval)); +#endif + /* After we've set the flags, it could be argued that + we don't need to do the attributes.pm-based setting + process, and shouldn't bother appending recognized + flags. To experiment with that, uncomment the + following "else": */ + else + attrs = append_elem(OP_LIST, attrs, + newSVOP(OP_CONST, 0, + newSVpvn(s, len))); } s = skipspace(d); if (*s == ':' && s[1] != ':') @@ -3134,9 +3212,6 @@ Perl_yylex(pTHX) if (*d == '}') { char minus = (PL_tokenbuf[0] == '-'); s = force_word(s + minus, WORD, FALSE, TRUE, FALSE); - if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, 0) && - PL_nextval[PL_nexttoke-1].opval) - SvUTF8_on(((SVOP*)PL_nextval[PL_nexttoke-1].opval)->op_sv); if (minus) force_next('-'); } @@ -3630,7 +3705,7 @@ Perl_yylex(pTHX) case '\'': s = scan_str(s,FALSE,FALSE); DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### Saw string in '%s'\n", s); + "### Saw string before '%s'\n", s); } ) if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { @@ -3649,7 +3724,7 @@ Perl_yylex(pTHX) case '"': s = scan_str(s,FALSE,FALSE); DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### Saw string in '%s'\n", s); + "### Saw string before '%s'\n", s); } ) if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { @@ -3674,7 +3749,7 @@ Perl_yylex(pTHX) case '`': s = scan_str(s,FALSE,FALSE); DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### Saw backtick string in '%s'\n", s); + "### Saw backtick string before '%s'\n", s); } ) if (PL_expect == XOPERATOR) no_op("Backticks",s); @@ -4116,10 +4191,6 @@ Perl_yylex(pTHX) (void)PerlIO_seek(PL_rsfp, 0L, 0); } if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) { -#if defined(__BORLANDC__) - /* XXX see note in do_binmode() */ - ((FILE*)PL_rsfp)->flags |= _F_BIN; -#endif if (loc > 0) PerlIO_seek(PL_rsfp, loc, 0); } @@ -4692,9 +4763,10 @@ Perl_yylex(pTHX) force_next(THING); } } - if (PL_lex_stuff) + if (PL_lex_stuff) { SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; + PL_lex_stuff = Nullsv; + } PL_expect = XTERM; TOKEN('('); @@ -4962,12 +5034,8 @@ Perl_yylex(pTHX) char *p; s = scan_str(s,FALSE,FALSE); - if (!s) { - if (PL_lex_stuff) - SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; + if (!s) Perl_croak(aTHX_ "Prototype not terminated"); - } /* strip spaces */ d = SvPVX(PL_lex_stuff); tmp = 0; @@ -6134,12 +6202,8 @@ S_scan_pat(pTHX_ char *start, I32 type) char *s; s = scan_str(start,FALSE,FALSE); - if (!s) { - if (PL_lex_stuff) - SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; + if (!s) Perl_croak(aTHX_ "Search pattern not terminated"); - } pm = (PMOP*)newPMOP(type, 0); if (PL_multi_open == '?') @@ -6171,12 +6235,8 @@ S_scan_subst(pTHX_ char *start) s = scan_str(start,FALSE,FALSE); - if (!s) { - if (PL_lex_stuff) - SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; + if (!s) Perl_croak(aTHX_ "Substitution pattern not terminated"); - } if (s[-1] == PL_multi_open) s--; @@ -6184,12 +6244,10 @@ S_scan_subst(pTHX_ char *start) first_start = PL_multi_start; s = scan_str(s,FALSE,FALSE); if (!s) { - if (PL_lex_stuff) + if (PL_lex_stuff) { SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; - if (PL_lex_repl) - SvREFCNT_dec(PL_lex_repl); - PL_lex_repl = Nullsv; + PL_lex_stuff = Nullsv; + } Perl_croak(aTHX_ "Substitution replacement not terminated"); } PL_multi_start = first_start; /* so whole substitution is taken together */ @@ -6238,35 +6296,24 @@ S_scan_trans(pTHX_ char *start) I32 squash; I32 del; I32 complement; - I32 utf8; - I32 count = 0; yylval.ival = OP_NULL; s = scan_str(start,FALSE,FALSE); - if (!s) { - if (PL_lex_stuff) - SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; + if (!s) Perl_croak(aTHX_ "Transliteration pattern not terminated"); - } if (s[-1] == PL_multi_open) s--; s = scan_str(s,FALSE,FALSE); if (!s) { - if (PL_lex_stuff) + if (PL_lex_stuff) { SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = Nullsv; - if (PL_lex_repl) - SvREFCNT_dec(PL_lex_repl); - PL_lex_repl = Nullsv; + PL_lex_stuff = Nullsv; + } Perl_croak(aTHX_ "Transliteration replacement not terminated"); } - New(803,tbl,256,short); - o = newPVOP(OP_TRANS, 0, (char*)tbl); - complement = del = squash = 0; while (strchr("cds", *s)) { if (*s == 'c') @@ -6277,6 +6324,9 @@ S_scan_trans(pTHX_ char *start) squash = OPpTRANS_SQUASH; s++; } + + New(803, tbl, complement&&!del?258:256, short); + o = newPVOP(OP_TRANS, 0, (char*)tbl); o->op_private = del|squash|complement| (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)| (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0); @@ -6421,6 +6471,7 @@ 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; } else sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */ @@ -6432,6 +6483,7 @@ S_scan_heredoc(pTHX_ register char *s) } CopLINE_inc(PL_curcop); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; #ifndef PERL_STRICT_CR if (PL_bufend - PL_linestart >= 2) { if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') || @@ -6632,11 +6684,11 @@ S_scan_inputsymbol(pTHX_ char *start) delimiter. It allows quoting of delimiters, and if the string has balanced delimiters ([{<>}]) it allows nesting. - The lexer always reads these strings into lex_stuff, except in the - case of the operators which take *two* arguments (s/// and tr///) - when it checks to see if lex_stuff is full (presumably with the 1st - arg to s or tr) and if so puts the string into lex_repl. - + On success, the SV with the resulting string is put into lex_stuff or, + if that is already non-NULL, into lex_repl. The second case occurs only + when parsing the RHS of the special constructs s/// and tr/// (y///). + For convenience, the terminating delimiter character is stuffed into + SvIVX of the SV. */ STATIC char * @@ -6790,6 +6842,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* having changed the buffer, we must update PL_bufend */ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_last_lop = PL_last_uni = Nullch; } /* at this point, we have successfully read the delimited string */ @@ -7192,10 +7245,9 @@ vstring: while (isDIGIT(*pos) || *pos == '_') pos++; if (!isALPHA(*pos)) { - UV rev; + UV rev, revmax = 0; U8 tmpbuf[UTF8_MAXLEN+1]; U8 *tmpend; - bool utf8 = FALSE; s++; /* get past 'v' */ sv = NEWSV(92,5); @@ -7222,7 +7274,8 @@ vstring: } } tmpend = uv_to_utf8(tmpbuf, rev); - utf8 = utf8 || rev > 127; + if (rev > revmax) + revmax = rev; sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); if (*pos == '.' && isDIGIT(pos[1])) s = ++pos; @@ -7236,9 +7289,9 @@ vstring: SvPOK_on(sv); SvREADONLY_on(sv); - if (utf8) { + if (revmax > 127) { SvUTF8_on(sv); - if (!UTF||IN_BYTE) + if (revmax < 256) sv_utf8_downgrade(sv, TRUE); } } @@ -7306,6 +7359,7 @@ S_scan_formline(pTHX_ register char *s) s = filter_gets(PL_linestr, PL_rsfp, 0); 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; if (!s) { s = PL_bufptr; yyerror("Format not terminated"); @@ -7401,6 +7455,9 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) return oldsavestack_ix; } +#ifdef __SC__ +#pragma segment Perl_yylex +#endif int Perl_yywarn(pTHX_ char *s) { @@ -7489,6 +7546,9 @@ Perl_yyerror(pTHX_ char *s) PL_in_my_stash = Nullhv; return 0; } +#ifdef __SC__ +#pragma segment Main +#endif STATIC char* S_swallow_bom(pTHX_ U8 *s)