X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=4e9020187d7fb2989400e92899ebd5ca1573fbee;hb=50fc42481ed636dd7d07a6d83c1edcbf9d141c4d;hp=aa3e64b55fcb83fadfd00d726e23d029652b0b45;hpb=b4748376b6239962bd75b743e5a7b14788a2970c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index aa3e64b..4e90201 100644 --- a/toke.c +++ b/toke.c @@ -1,6 +1,6 @@ /* toke.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -13,7 +13,7 @@ /* * This file is the lexer for Perl. It's closely linked to the - * parser, perly.y. + * parser, perly.y. * * The main routine is yylex(), which returns the next token. */ @@ -39,7 +39,7 @@ static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen); /*#define UTF (SvUTF8(PL_linestr) && !(PL_hints & HINT_BYTE))*/ #define UTF (PL_hints & HINT_UTF8) -/* In variables name $^X, these are the legal values for X. +/* In variables name $^X, these are the legal values for X. * 1999-02-27 mjd-perl-patch@plover.com */ #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x))) @@ -79,13 +79,13 @@ static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen); # endif YYSTYPE* yylval_pointer[YYMAXLEVEL]; int* yychar_pointer[YYMAXLEVEL]; -int yyactlevel = 0; +int yyactlevel = -1; # undef yylval # undef yychar # define yylval (*yylval_pointer[yyactlevel]) # define yychar (*yychar_pointer[yyactlevel]) # define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel] -# undef yylex +# undef yylex # define yylex() Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]) #endif @@ -126,31 +126,42 @@ int yyactlevel = 0; * 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 = 0; (*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 = 0; /* 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 * @@ -274,7 +304,6 @@ S_missingterm(pTHX_ char *s) void Perl_deprecate(pTHX_ char *s) { - dTHR; if (ckWARN(WARN_DEPRECATED)) Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s); } @@ -337,7 +366,6 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) void Perl_lex_start(pTHX_ SV *line) { - dTHR; char *s; STRLEN len; @@ -361,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); @@ -403,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; @@ -433,7 +464,6 @@ Perl_lex_end(pTHX) STATIC void S_incline(pTHX_ char *s) { - dTHR; char *t; char *n; char *e; @@ -447,9 +477,9 @@ S_incline(pTHX_ char *s) s += 4; else return; - if (*s == ' ' || *s == '\t') + if (SPACE_OR_TAB(*s)) s++; - else + else return; while (SPACE_OR_TAB(*s)) s++; if (!isDIGIT(*s)) @@ -495,7 +525,6 @@ S_incline(pTHX_ char *s) STATIC char * S_skipspace(pTHX_ register char *s) { - dTHR; if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; @@ -550,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 @@ -614,7 +644,6 @@ S_check_uni(pTHX) { char *s; char *t; - dTHR; if (PL_oldoldbufptr != PL_last_uni) return; @@ -626,8 +655,8 @@ S_check_uni(pTHX) if (ckWARN_d(WARN_AMBIGUOUS)){ char ch = *s; *s = '\0'; - Perl_warner(aTHX_ WARN_AMBIGUOUS, - "Warning: Use of \"%s\" without parens is ambiguous", + Perl_warner(aTHX_ WARN_AMBIGUOUS, + "Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni); *s = ch; } @@ -680,9 +709,9 @@ S_uni(pTHX_ I32 f, char *s) STATIC I32 S_lop(pTHX_ I32 f, int x, char *s) { - dTHR; yylval.ival = f; CLINE; + REPORT("lop", f) PL_expect = x; PL_bufptr = s; PL_last_lop = PL_oldbufptr; @@ -707,7 +736,7 @@ S_lop(pTHX_ I32 f, int x, char *s) * handles the token correctly. */ -STATIC void +STATIC void S_force_next(pTHX_ I32 type) { PL_nexttype[PL_nexttoke] = type; @@ -740,7 +769,7 @@ S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow { register char *s; STRLEN len; - + start = skipspace(start); s = start; if (isIDFIRST_lazy_if(s,UTF) || @@ -782,7 +811,6 @@ S_force_ident(pTHX_ register char *s, int kind) PL_nextval[PL_nexttoke].opval = o; force_next(WORD); if (kind) { - dTHR; /* just for in_eval */ 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. @@ -822,7 +850,7 @@ Perl_str_to_version(pTHX_ SV *sv) return retval; } -/* +/* * S_force_version * Forces the next token to be a version number. */ @@ -855,7 +883,7 @@ S_force_version(pTHX_ char *s) /* NOTE: The parser sees the package name and the VERSION swapped */ PL_nextval[PL_nexttoke].opval = version; - force_next(WORD); + force_next(WORD); return (s); } @@ -963,7 +991,7 @@ S_sublex_start(pTHX) SvUTF8_on(nsv); SvREFCNT_dec(sv); sv = nsv; - } + } yylval.opval = (OP*)newSVOP(op_type, 0, sv); PL_lex_stuff = Nullsv; return THING; @@ -995,7 +1023,6 @@ S_sublex_start(pTHX) STATIC I32 S_sublex_push(pTHX) { - dTHR; ENTER; PL_lex_state = PL_sublex_info.super_state; @@ -1010,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); @@ -1021,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; @@ -1053,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; } @@ -1069,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; @@ -1169,7 +1203,7 @@ S_sublex_done(pTHX) } (end switch) } (end if backslash) } (end while character to read) - + */ STATIC char * @@ -1181,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) @@ -1205,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 */ @@ -1241,11 +1287,11 @@ S_scan_const(pTHX_ char *start) dorange = FALSE; didrange = TRUE; continue; - } + } /* range begins (ignore - as first or last char) */ else if (*s == '-' && s+1 < send && s != start) { - if (didrange) { + if (didrange) { Perl_croak(aTHX_ "Ambiguous range in transliteration operator"); } if (utf) { @@ -1280,9 +1326,9 @@ S_scan_const(pTHX_ char *start) while (count && (c = *regparse)) { if (c == '\\' && regparse[1]) regparse++; - else if (c == '{') + else if (c == '{') count++; - else if (c == '}') + else if (c == '}') count--; regparse++; } @@ -1319,28 +1365,6 @@ S_scan_const(pTHX_ char *start) break; /* in regexp, $ might be tail anchor */ } - /* (now in tr/// code again) */ - - if (*s & 0x80 && this_utf8) { - STRLEN len; - UV uv; - - uv = utf8_to_uv((U8*)s, send - s, &len, UTF8_CHECK_ONLY); - if (len == (STRLEN)-1) { - /* Illegal UTF8 (a high-bit byte), make it valid. */ - char *old_pvx = SvPVX(sv); - /* need space for one extra char (NOTE: SvCUR() not set here) */ - d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx); - d = (char*)uv_to_utf8((U8*)d, (U8)*s++); - } - else { - while (len--) - *d++ = *s++; - } - has_utf8 = TRUE; - continue; - } - /* backslashes */ if (*s == '\\' && s+1 < send) { s++; @@ -1356,7 +1380,6 @@ S_scan_const(pTHX_ char *start) if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat && isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) { - dTHR; /* only for ckWARN */ if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s); *--s = '$'; @@ -1381,14 +1404,12 @@ S_scan_const(pTHX_ char *start) /* FALL THROUGH */ default: { - dTHR; if (ckWARN(WARN_MISC) && isALNUM(*s)) - Perl_warner(aTHX_ WARN_MISC, + Perl_warner(aTHX_ WARN_MISC, "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 */ @@ -1413,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); - has_utf8 = TRUE; } s = e + 1; } @@ -1427,34 +1447,47 @@ S_scan_const(pTHX_ char *start) NUM_ESCAPE_INSERT: /* Insert oct or hex escaped character. - * There will always enough room in sv since such escapes will - * be longer than any utf8 sequence they can end up as - */ - if (uv > 127 || has_utf8) { - if (!this_utf8 && !has_utf8 && uv > 255) { - /* might need to recode whatever we have accumulated so far - * if it contains any hibit chars + * There will always enough room in sv since such + * escapes will be longer than any UT-F8 sequence + * they can end up as. */ + + /* This spot is wrong for EBCDIC. Characters like + * the lowercase letters and digits are >127 in EBCDIC, + * so here they would need to be mapped to the Unicode + * repertoire. --jhi */ + + if (uv > 127) { + if (!has_utf8 && uv > 255) { + /* Might need to recode whatever we have + * accumulated so far if it contains any + * hibit chars. + * + * (Can't we keep track of that and avoid + * this rescan? --jhi) */ int hicount = 0; char *c; + for (c = SvPVX(sv); c < d; c++) { - if (*c & 0x80) + if (UTF8_IS_CONTINUED(*c)) hicount++; } if (hicount) { char *old_pvx = SvPVX(sv); char *src, *dst; - d = SvGROW(sv, SvCUR(sv) + hicount + 1) + (d - old_pvx); + + d = SvGROW(sv, + SvLEN(sv) + hicount + 1) + + (d - old_pvx); src = d - 1; d += hicount; dst = d - 1; while (src < dst) { - if (*src & 0x80) { - dst--; - uv_to_utf8((U8*)dst, (U8)*src--); - dst--; + if (UTF8_IS_CONTINUED(*src)) { + *dst-- = UTF8_EIGHT_BIT_LO(*src); + *dst-- = UTF8_EIGHT_BIT_HI(*src--); } else { *dst-- = *src--; @@ -1465,7 +1498,14 @@ S_scan_const(pTHX_ char *start) if (has_utf8 || uv > 255) { d = (char*)uv_to_utf8((U8*)d, uv); - this_utf8 = TRUE; + 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; @@ -1484,15 +1524,17 @@ S_scan_const(pTHX_ char *start) SV *res; STRLEN len; char *str; - + if (!e) { yyerror("Missing right brace on \\N{}"); e = s - 1; goto cont_scan; } res = newSVpvn(s + 1, e - s - 1); - res = new_constant( Nullch, 0, "charnames", + 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); @@ -1508,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); @@ -1528,7 +1570,7 @@ S_scan_const(pTHX_ char *start) *d = *s++; if (isLOWER(*d)) *d = toUPPER(*d); - *d = toCTRL(*d); + *d = toCTRL(*d); d++; #else { @@ -1575,7 +1617,34 @@ S_scan_const(pTHX_ char *start) continue; } /* end if (backslash) */ - *d++ = *s++; + default_action: + if (UTF8_IS_CONTINUED(*s) && (this_utf8 || has_utf8)) { + STRLEN len = (STRLEN) -1; + UV uv; + if (this_utf8) { + uv = utf8_to_uv((U8*)s, send - s, &len, 0); + } + if (len == (STRLEN)-1) { + /* Illegal UTF8 (a high-bit byte), make it valid. */ + char *old_pvx = SvPVX(sv); + /* need space for one extra char (NOTE: SvCUR() not set here) */ + d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx); + d = (char*)uv_to_utf8((U8*)d, (U8)*s++); + } + else { + while (len--) + *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++; } /* while loop to process each character */ /* terminate the string and set up the sv */ @@ -1594,9 +1663,9 @@ S_scan_const(pTHX_ char *start) /* return the substring (via yylval) only if we parsed anything */ if (s > PL_bufptr) { if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) - sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"), + sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"), sv, Nullsv, - ( PL_lex_inwhat == OP_TRANS + ( PL_lex_inwhat == OP_TRANS ? "tr" : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) ? "s" @@ -1867,7 +1936,7 @@ S_incl_perldb(pTHX) /* Encoded script support. filter_add() effectively inserts a - * 'pre-processing' function into the current source input stream. + * 'pre-processing' function into the current source input stream. * Note that the filter function only applies to the current source file * (e.g., it will not affect files 'require'd or 'use'd by this one). * @@ -1903,7 +1972,7 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) av_store(PL_rsfp_filters, 0, datasv) ; return(datasv); } - + /* Delete most recently added instance of this filter function. */ void @@ -1930,8 +1999,8 @@ Perl_filter_del(pTHX_ filter_t funcp) /* Invoke the n'th filter function for the current rsfp. */ I32 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) - - + + /* 0 = read one text line */ { filter_t funcp; @@ -1944,7 +2013,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) /* Note that we append to the line. This is handy. */ DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: from rsfp\n", idx)); - if (maxlen) { + if (maxlen) { /* Want a block */ int len ; int old_len = SvCUR(buf_sv) ; @@ -2067,24 +2136,21 @@ 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) { - dTHR; int r; + yyactlevel++; yylval_pointer[yyactlevel] = lvalp; yychar_pointer[yyactlevel] = lcharp; - yyactlevel++; if (yyactlevel >= YYMAXLEVEL) Perl_croak(aTHX_ "panic: YYMAXLEVEL"); r = Perl_yylex(aTHX); - yyactlevel--; + if (yyactlevel > 0) + yyactlevel--; return r; } @@ -2093,21 +2159,16 @@ Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp) #ifdef __SC__ #pragma segment Perl_yylex #endif - int -#ifdef USE_PURE_BISON -Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp) -#else Perl_yylex(pTHX) -#endif { - dTHR; register char *s; register char *d; register I32 tmp; 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) { @@ -2142,7 +2203,7 @@ Perl_yylex(pTHX) } } - /* + /* build the ops for accesses to a my() variable. Deny my($a) or my($b) in a sort block, *if* $a or $b is @@ -2460,7 +2521,7 @@ Perl_yylex(pTHX) PL_last_lop = 0; if (PL_lex_brackets) yyerror("Missing right curly or square bracket"); - DEBUG_T( { PerlIO_printf(Perl_debug_log, + DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Tokener got EOF\n"); } ) TOKEN(0); @@ -2518,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); @@ -2528,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 */ @@ -2549,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")) @@ -2591,9 +2656,10 @@ 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; } - } + } incline(s); } while (PL_doextract); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; @@ -2605,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++; @@ -2748,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); @@ -2766,7 +2834,7 @@ Perl_yylex(pTHX) case '\r': #ifdef PERL_STRICT_CR Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r'); - Perl_croak(aTHX_ + Perl_croak(aTHX_ "\t(Maybe you didn't strip carriage returns after a network transfer?)\n"); #endif case ' ': case '\t': case '\f': case 013: @@ -2813,7 +2881,7 @@ Perl_yylex(pTHX) if (strnEQ(s,"=>",2)) { s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE); - DEBUG_T( { PerlIO_printf(Perl_debug_log, + DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Saw unary minus before =>, forcing word '%s'\n", s); } ) OPERATOR('-'); /* unary minus */ @@ -2858,18 +2926,18 @@ Perl_yylex(pTHX) } if (ftst) { PL_last_lop_op = ftst; - DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### Saw file test %c\n", ftst); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw file test %c\n", (int)ftst); } ) - if (*s == '(' && ckWARN(WARN_AMBIGUOUS)) - Perl_warner(aTHX_ WARN_AMBIGUOUS, - "Ambiguous -%c() resolved as a file test", - tmp); FTST(ftst); } else { /* 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", + (int)ftst); + } ) s -= 2; } } @@ -3000,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(). */ @@ -3023,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] != ':') @@ -3569,8 +3649,8 @@ Perl_yylex(pTHX) case '?': /* may either be conditional or pattern */ if (PL_expect != XOPERATOR) { /* Disable warning on "study /blah/" */ - if (PL_oldoldbufptr == PL_last_uni - && (*PL_last_uni != 's' || s - PL_last_uni < 5 + if (PL_oldoldbufptr == PL_last_uni + && (*PL_last_uni != 's' || s - PL_last_uni < 5 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy_if(PL_last_uni+5,UTF))) check_uni(); @@ -3615,7 +3695,7 @@ Perl_yylex(pTHX) case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': s = scan_num(s, &yylval); - DEBUG_T( { PerlIO_printf(Perl_debug_log, + DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Saw number in '%s'\n", s); } ) if (PL_expect == XOPERATOR) @@ -3624,8 +3704,8 @@ Perl_yylex(pTHX) case '\'': s = scan_str(s,FALSE,FALSE); - DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### Saw string in '%s'\n", s); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw string before '%s'\n", s); } ) if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { @@ -3643,8 +3723,8 @@ Perl_yylex(pTHX) case '"': s = scan_str(s,FALSE,FALSE); - DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### Saw string in '%s'\n", s); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw string before '%s'\n", s); } ) if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { @@ -3659,7 +3739,7 @@ Perl_yylex(pTHX) missingterm((char*)0); yylval.ival = OP_CONST; for (d = SvPV(PL_lex_stuff, len); len; len--, d++) { - if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) { + if (*d == '$' || *d == '@' || *d == '\\' || UTF8_IS_CONTINUED(*d)) { yylval.ival = OP_STRINGIFY; break; } @@ -3668,8 +3748,8 @@ Perl_yylex(pTHX) case '`': s = scan_str(s,FALSE,FALSE); - DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### Saw backtick string in '%s'\n", s); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw backtick string before '%s'\n", s); } ) if (PL_expect == XOPERATOR) no_op("Backticks",s); @@ -3786,6 +3866,8 @@ Perl_yylex(pTHX) CLINE; yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0)); yylval.opval->op_private = OPpCONST_BARE; + if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len)) + SvUTF8_on(((SVOP*)yylval.opval)->op_sv); TERM(WORD); } @@ -3870,7 +3952,7 @@ Perl_yylex(pTHX) PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':') { if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV)) - Perl_warner(aTHX_ WARN_BAREWORD, + Perl_warner(aTHX_ WARN_BAREWORD, "Bareword \"%s\" refers to nonexistent package", PL_tokenbuf); len -= 2; @@ -3927,10 +4009,10 @@ Perl_yylex(pTHX) /* If not a declared subroutine, it's an indirect object. */ /* (But it's an indir obj regardless for sort.) */ - if ((PL_last_lop_op == OP_SORT || - (!immediate_paren && (!gv || !GvCVu(gv)))) && + if ( !immediate_paren && (PL_last_lop_op == OP_SORT || + ((!gv || !GvCVu(gv)) && (PL_last_lop_op != OP_MAPSTART && - PL_last_lop_op != OP_GREPSTART)) + PL_last_lop_op != OP_GREPSTART)))) { PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR; goto bareword; @@ -3945,6 +4027,8 @@ Perl_yylex(pTHX) if (*s == '=' && s[1] == '>') { CLINE; sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf); + if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len)) + SvUTF8_on(((SVOP*)yylval.opval)->op_sv); TERM(WORD); } @@ -4107,15 +4191,15 @@ 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); } } #endif +#ifdef PERLIO_LAYERS + if (UTF && !IN_BYTE) + PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8"); +#endif PL_rsfp = Nullfp; } goto fake_eof; @@ -4266,7 +4350,7 @@ Perl_yylex(pTHX) case KEY_exists: UNI(OP_EXISTS); - + case KEY_exit: UNI(OP_EXIT); @@ -4470,7 +4554,7 @@ Perl_yylex(pTHX) case KEY_last: s = force_word(s,WORD,TRUE,FALSE,FALSE); LOOPX(OP_LAST); - + case KEY_lc: UNI(OP_LC); @@ -4615,7 +4699,7 @@ Perl_yylex(pTHX) case KEY_pos: UNI(OP_POS); - + case KEY_pack: LOP(OP_PACK,XTERM); @@ -4646,6 +4730,7 @@ Perl_yylex(pTHX) int warned = 0; d = SvPV_force(PL_lex_stuff, len); while (len) { + SV *sv; for (; isSPACE(*d) && len; --len, ++d) ; if (len) { char *b = d; @@ -4666,8 +4751,11 @@ Perl_yylex(pTHX) else { for (; !isSPACE(*d) && len; --len, ++d) ; } + sv = newSVpvn(b, d-b); + if (DO_UTF8(PL_lex_stuff)) + SvUTF8_on(sv); words = append_elem(OP_LIST, words, - newSVOP(OP_CONST, 0, tokeq(newSVpvn(b, d-b)))); + newSVOP(OP_CONST, 0, tokeq(sv))); } } if (words) { @@ -4675,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('('); @@ -4777,7 +4866,7 @@ Perl_yylex(pTHX) case KEY_chomp: UNI(OP_CHOMP); - + case KEY_scalar: UNI(OP_SCALAR); @@ -4945,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; @@ -5066,7 +5151,7 @@ Perl_yylex(pTHX) case KEY_umask: if (ckWARN(WARN_UMASK)) { for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ; - if (*d != '0' && isDIGIT(*d)) + if (*d != '0' && isDIGIT(*d)) Perl_warner(aTHX_ WARN_UMASK, "umask: argument is missing initial 0"); } @@ -5121,7 +5206,7 @@ Perl_yylex(pTHX) { static char ctl_l[2]; - if (ctl_l[0] == '\0') + if (ctl_l[0] == '\0') ctl_l[0] = toCTRL('L'); gv_fetchpv(ctl_l,TRUE, SVt_PV); } @@ -5493,7 +5578,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) case 'p': switch (len) { case 3: - if (strEQ(d,"pop")) return -KEY_pop; + if (strEQ(d,"pop")) return -KEY_pop; if (strEQ(d,"pos")) return KEY_pos; break; case 4: @@ -5759,7 +5844,6 @@ S_checkcomma(pTHX_ register char *s, char *name, char *what) char *w; if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ - dTHR; /* only for ckWARN */ if (ckWARN(WARN_SYNTAX)) { int level = 1; for (w = s+2; *w && level; w++) { @@ -5814,14 +5898,14 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, SV **cvp; SV *cv, *typesv; const char *why1, *why2, *why3; - + if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { SV *msg; why2 = strEQ(key,"charnames") ? "(possibly a missing \"use charnames ...\")" : ""; - msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s", + msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s", (type ? type: "undef"), why2); /* This is convoluted and evil ("goto considered harmful") @@ -5832,7 +5916,7 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, goto msgdone; report: - msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s", + msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s", (type ? type: "undef"), why1, why2, why3); msgdone: yyerror(SvPVX(msg)); @@ -5854,11 +5938,11 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, typesv = sv_2mortal(newSVpv(type, 0)); else typesv = &PL_sv_undef; - + PUSHSTACKi(PERLSI_OVERLOAD); ENTER ; SAVETMPS; - + PUSHMARK(SP) ; EXTEND(sp, 3); if (pv) @@ -5868,9 +5952,9 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, PUSHs(typesv); PUTBACK; call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL)); - + SPAGAIN ; - + /* Check the eval first */ if (!PL_in_eval && SvTRUE(ERRSV)) { STRLEN n_a; @@ -5883,12 +5967,12 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, res = POPs; (void)SvREFCNT_inc(res); } - + PUTBACK ; FREETMPS ; LEAVE ; POPSTACK; - + if (!SvOK(res)) { why1 = "Call to &{$^H{"; why2 = key; @@ -5899,7 +5983,7 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, return res; } - + STATIC char * S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) { @@ -5919,9 +6003,9 @@ S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_packag *d++ = *s++; *d++ = *s++; } - else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) { + else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { char *t = s + UTF8SKIP(s); - while (*t & 0x80 && is_utf8_mark((U8*)t)) + while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t)) t += UTF8SKIP(t); if (d + (t - s) > e) Perl_croak(aTHX_ ident_too_long); @@ -5971,9 +6055,9 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des *d++ = *s++; *d++ = *s++; } - else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) { + else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { char *t = s + UTF8SKIP(s); - while (*t & 0x80 && is_utf8_mark((U8*)t)) + while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t)) t += UTF8SKIP(t); if (d + (t - s) > e) Perl_croak(aTHX_ ident_too_long); @@ -6026,7 +6110,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des e = s; while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') { e += UTF8SKIP(e); - while (e < send && *e & 0x80 && is_utf8_mark((U8*)e)) + while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e)) e += UTF8SKIP(e); } Copy(s, d, e - s, char); @@ -6042,7 +6126,6 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des *d = '\0'; while (s < send && SPACE_OR_TAB(*s)) s++; if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { - dTHR; /* only for ckWARN */ if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) { const char *brack = *s == '[' ? "[...]" : "{...}"; Perl_warner(aTHX_ WARN_AMBIGUOUS, @@ -6053,8 +6136,8 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK); return s; } - } - /* Handle extended ${^Foo} variables + } + /* Handle extended ${^Foo} variables * 1999-02-27 mjd-perl-patch@plover.com */ else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */ && isALNUM(*s)) @@ -6074,7 +6157,6 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des if (funny == '#') funny = '@'; if (PL_lex_state == LEX_NORMAL) { - dTHR; /* only for ckWARN */ if (ckWARN(WARN_AMBIGUOUS) && (keyword(dest, d - dest) || get_cv(dest, FALSE))) { @@ -6120,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 == '?') @@ -6157,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--; @@ -6170,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 */ @@ -6224,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') @@ -6263,7 +6324,12 @@ S_scan_trans(pTHX_ char *start) squash = OPpTRANS_SQUASH; s++; } - o->op_private = del|squash|complement; + + 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); PL_lex_op = o; yylval.ival = OP_TRANS; @@ -6273,7 +6339,6 @@ S_scan_trans(pTHX_ char *start) STATIC char * S_scan_heredoc(pTHX_ register char *s) { - dTHR; SV *herewas; I32 op_type = OP_SCALAR; I32 len; @@ -6406,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 */ @@ -6417,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') || @@ -6458,6 +6525,8 @@ retval: Renew(SvPVX(tmpstr), SvLEN(tmpstr), char); } SvREFCNT_dec(herewas); + if (UTF && !IN_BYTE && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr))) + SvUTF8_on(tmpstr); PL_lex_stuff = tmpstr; yylval.ival = op_type; return s; @@ -6608,24 +6677,23 @@ S_scan_inputsymbol(pTHX_ char *start) calls scan_str(). s/// makes yylex() call scan_subst() which calls scan_str(). tr/// and y/// make yylex() call scan_trans() which calls scan_str(). - + It skips whitespace before the string starts, and treats the first character as the delimiter. If the delimiter is one of ([{< then the corresponding "close" character )]}> is used as the closing 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 * S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) { - dTHR; SV *sv; /* scalar value: string */ char *tmps; /* temp string, used for delimiter matching */ register char *s = start; /* current position in the buffer */ @@ -6643,7 +6711,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* after skipping whitespace, the next character is the terminator */ term = *s; - if ((term & 0x80) && UTF) + if (UTF8_IS_CONTINUED(term) && UTF) has_utf8 = TRUE; /* mark where we are */ @@ -6690,7 +6758,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) have found the terminator */ else if (*s == term) break; - else if (!has_utf8 && (*s & 0x80) && UTF) + else if (!has_utf8 && UTF8_IS_CONTINUED(*s) && UTF) has_utf8 = TRUE; *to = *s; } @@ -6719,7 +6787,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) break; else if (*s == PL_multi_open) brackets++; - else if (!has_utf8 && (*s & 0x80) && UTF) + else if (!has_utf8 && UTF8_IS_CONTINUED(*s) && UTF) has_utf8 = TRUE; *to = *s; } @@ -6774,8 +6842,9 @@ 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 */ if (keep_delims) @@ -6794,7 +6863,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* decide whether this is the first or second quoted string we've read for this op */ - + if (PL_lex_stuff) PL_lex_repl = sv; else @@ -6823,7 +6892,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) try converting the number to an integer and see if it can do so without loss of precision. */ - + char * Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) { @@ -6841,7 +6910,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) switch (*s) { default: Perl_croak(aTHX_ "panic: scan_num"); - + /* if it starts with a 0, it could be an octal number, a decimal in 0.13 disguise, or a hexadecimal number, or a binary number. */ case '0': @@ -6856,7 +6925,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) we in octal/hex/binary?" indicator to disallow hex characters when in octal mode. */ - dTHR; NV n = 0.0; UV u = 0; I32 shift; @@ -6944,7 +7012,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) if ((x >> shift) != u && !(PL_hints & HINT_NEW_BINARY)) { - dTHR; overflowed = TRUE; n = (NV) u; if (ckWARN_d(WARN_OVERFLOW)) @@ -6976,7 +7043,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) out: sv = NEWSV(92,0); if (overflowed) { - dTHR; if (ckWARN(WARN_PORTABLE) && n > 4294967295.0) Perl_warner(aTHX_ WARN_PORTABLE, "%s number > %s non-portable", @@ -6985,7 +7051,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) } else { #if UVSIZE > 4 - dTHR; if (ckWARN(WARN_PORTABLE) && u > 0xffffffff) Perl_warner(aTHX_ WARN_PORTABLE, "%s number > %s non-portable", @@ -7011,11 +7076,10 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) /* read next group of digits and _ and copy into d */ while (isDIGIT(*s) || *s == '_') { - /* skip underscores, checking for misplaced ones + /* skip underscores, checking for misplaced ones if -w is on */ if (*s == '_') { - dTHR; /* only for ckWARN */ if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3) Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number"); lastub = ++s; @@ -7031,7 +7095,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) /* final misplaced underbar check */ if (lastub && s - lastub != 3) { - dTHR; if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number"); } @@ -7140,7 +7203,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) compilers have issues. Then we try casting it back and see if it was the same [1]. We only do this if we know we specifically read an integer. If floatit is true, then we - don't need to do the conversion at all. + don't need to do the conversion at all. [1] Note that this is lossy if our NVs cannot preserve our UVs. There are metaconfig defines NV_PRESERVES_UV (a boolean) @@ -7151,7 +7214,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) Maybe could do some tricks with DBL_DIG, LDBL_DIG and DBL_MANT_DIG and LDBL_MANT_DIG (these are already available as NV_DIG and NV_MANT_DIG)? - + --jhi */ { @@ -7168,7 +7231,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) #endif if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) - sv = new_constant(PL_tokenbuf, d - PL_tokenbuf, + sv = new_constant(PL_tokenbuf, d - PL_tokenbuf, (floatit ? "float" : "integer"), sv, Nullsv, NULL); break; @@ -7182,10 +7245,9 @@ vstring: while (isDIGIT(*pos) || *pos == '_') pos++; if (!isALPHA(*pos)) { - UV rev; - U8 tmpbuf[UTF8_MAXLEN]; + UV rev, revmax = 0; + U8 tmpbuf[UTF8_MAXLEN+1]; U8 *tmpend; - bool utf8 = FALSE; s++; /* get past 'v' */ sv = NEWSV(92,5); @@ -7212,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; @@ -7226,9 +7289,10 @@ vstring: SvPOK_on(sv); SvREADONLY_on(sv); - if (utf8) { + if (revmax > 127) { SvUTF8_on(sv); - sv_utf8_downgrade(sv, TRUE); + if (revmax < 256) + sv_utf8_downgrade(sv, TRUE); } } } @@ -7248,7 +7312,6 @@ vstring: STATIC char * S_scan_formline(pTHX_ register char *s) { - dTHR; register char *eol; register char *t; SV *stuff = newSVpvn("",0); @@ -7296,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"); @@ -7339,7 +7403,6 @@ S_set_csh(pTHX) I32 Perl_start_subparse(pTHX_ I32 is_format, U32 flags) { - dTHR; I32 oldsavestack_ix = PL_savestack_ix; CV* outsidecv = PL_compcv; AV* comppadlist; @@ -7392,10 +7455,12 @@ 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) { - dTHR; PL_in_eval |= EVAL_WARNONLY; yyerror(s); PL_in_eval &= ~EVAL_WARNONLY; @@ -7405,7 +7470,6 @@ Perl_yywarn(pTHX_ char *s) int Perl_yyerror(pTHX_ char *s) { - dTHR; char *where = NULL; char *context = NULL; int contlen = -1; @@ -7482,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) @@ -7489,8 +7556,8 @@ S_swallow_bom(pTHX_ U8 *s) STRLEN slen; slen = SvCUR(PL_linestr); switch (*s) { - case 0xFF: - if (s[1] == 0xFE) { + case 0xFF: + if (s[1] == 0xFE) { /* UTF-16 little-endian */ if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */ Perl_croak(aTHX_ "Unsupported script encoding"); @@ -7592,7 +7659,7 @@ utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen) if (!*SvPV_nolen(sv)) /* Game over, but don't feed an odd-length string to utf16_to_utf8 */ return count; - + tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen); sv_usepvn(sv, (char*)tmps, tend - tmps); }