X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d2f449dd43c68ee43aecff7e17640d02830ae584..b815e894e1fc82c49b9845b9884350949cec1752:/toke.c diff --git a/toke.c b/toke.c index 9821201..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))) @@ -69,26 +69,24 @@ static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen); #define LEX_FORMLINE 1 #define LEX_KNOWNEXT 0 -/* XXX If this causes problems, set i_unistd=undef in the hint file. */ -#ifdef I_UNISTD -# include /* Needed for execv() */ -#endif - - #ifdef ff_next #undef ff_next #endif #ifdef USE_PURE_BISON -YYSTYPE* yylval_pointer = NULL; -int* yychar_pointer = NULL; +# ifndef YYMAXLEVEL +# define YYMAXLEVEL 100 +# endif +YYSTYPE* yylval_pointer[YYMAXLEVEL]; +int* yychar_pointer[YYMAXLEVEL]; +int yyactlevel = -1; # undef yylval # undef yychar -# define yylval (*yylval_pointer) -# define yychar (*yychar_pointer) -# define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer +# define yylval (*yylval_pointer[yyactlevel]) +# define yychar (*yychar_pointer[yyactlevel]) +# define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel] # undef yylex -# define yylex() Perl_yylex(aTHX_ yylval_pointer, yychar_pointer) +# define yylex() Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]) #endif #include "keywords.h" @@ -123,36 +121,47 @@ int* yychar_pointer = NULL; * Aop : addition-level operator * Mop : multiplication-level operator * Eop : equality-testing operator - * Rop : relational operator <= != gt + * Rop : relational operator <= != gt * * 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, \ @@ -160,6 +169,7 @@ int* yychar_pointer = NULL; (*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) ) @@ -167,6 +177,24 @@ int* yychar_pointer = NULL; /* 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 * @@ -276,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); } @@ -339,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; @@ -357,13 +383,14 @@ Perl_lex_start(pTHX_ SV *line) SAVEVPTR(PL_nextval[toke]); } SAVEI32(PL_nexttoke); - PL_nexttoke = 0; } SAVECOPLINE(PL_curcop); SAVEPPTR(PL_bufptr); SAVEPPTR(PL_bufend); SAVEPPTR(PL_oldbufptr); SAVEPPTR(PL_oldoldbufptr); + SAVEPPTR(PL_last_lop); + SAVEPPTR(PL_last_uni); SAVEPPTR(PL_linestart); SAVESPTR(PL_linestr); SAVEPPTR(PL_lex_brackstack); @@ -391,6 +418,7 @@ Perl_lex_start(pTHX_ SV *line) PL_lex_stuff = Nullsv; PL_lex_repl = Nullsv; PL_lex_inpat = 0; + PL_nexttoke = 0; PL_lex_inwhat = 0; PL_sublex_info.sub_inwhat = 0; PL_linestr = line; @@ -405,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; @@ -435,7 +464,6 @@ Perl_lex_end(pTHX) STATIC void S_incline(pTHX_ char *s) { - dTHR; char *t; char *n; char *e; @@ -449,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)) @@ -497,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++; @@ -552,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 @@ -616,7 +644,6 @@ S_check_uni(pTHX) { char *s; char *t; - dTHR; if (PL_oldoldbufptr != PL_last_uni) return; @@ -628,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; } @@ -682,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; @@ -709,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; @@ -742,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) || @@ -784,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. @@ -809,10 +835,10 @@ Perl_str_to_version(pTHX_ SV *sv) bool utf = SvUTF8(sv) ? TRUE : FALSE; char *end = start + len; while (start < end) { - I32 skip; + STRLEN skip; UV n; if (utf) - n = utf8_to_uv((U8*)start, &skip, 0); + n = utf8_to_uv((U8*)start, len, &skip, 0); else { n = *(U8*)start; skip = 1; @@ -824,7 +850,7 @@ Perl_str_to_version(pTHX_ SV *sv) return retval; } -/* +/* * S_force_version * Forces the next token to be a version number. */ @@ -844,7 +870,7 @@ S_force_version(pTHX_ char *s) for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++); if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) { SV *ver; - s = scan_num(s); + s = scan_num(s, &yylval); version = yylval.opval; ver = cSVOPx(version)->op_sv; if (SvPOK(ver) && !SvNIOK(ver)) { @@ -857,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); } @@ -965,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; @@ -997,7 +1023,6 @@ S_sublex_start(pTHX) STATIC I32 S_sublex_push(pTHX) { - dTHR; ENTER; PL_lex_state = PL_sublex_info.super_state; @@ -1012,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); @@ -1023,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; @@ -1055,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; } @@ -1071,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; @@ -1171,7 +1203,7 @@ S_sublex_done(pTHX) } (end switch) } (end if backslash) } (end while character to read) - + */ STATIC char * @@ -1183,14 +1215,14 @@ 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_utf = FALSE; /* embedded \x{} */ - I32 len; /* ? */ + 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) ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) : UTF; - I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) + I32 this_utf8 = (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; @@ -1208,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 */ @@ -1244,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) { @@ -1283,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++; } @@ -1305,9 +1348,11 @@ S_scan_const(pTHX_ char *start) *d++ = *s++; } - /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */ + /* check for embedded arrays + (@foo, @:foo, @'foo, @{foo}, @$foo, @+, @-) + */ else if (*s == '@' && s[1] - && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$", s[1]))) + && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1]))) break; /* check for embedded scalars. only stop if we're sure it's a @@ -1320,25 +1365,6 @@ S_scan_const(pTHX_ char *start) break; /* in regexp, $ might be tail anchor */ } - /* (now in tr/// code again) */ - - if (*s & 0x80 && thisutf) { - (void)utf8_to_uv((U8*)s, &len, 0); - if (len == 1) { - /* illegal UTF8, 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_utf = TRUE; - continue; - } - /* backslashes */ if (*s == '\\' && s+1 < send) { s++; @@ -1354,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 = '$'; @@ -1379,22 +1404,22 @@ 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 */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': - len = 0; /* disallow underscores */ - uv = (UV)scan_oct(s, 3, &len); - s += len; + { + STRLEN len = 0; /* disallow underscores */ + uv = (UV)scan_oct(s, 3, &len); + s += len; + } goto NUM_ESCAPE_INSERT; /* \x24 indicates a hex constant */ @@ -1406,46 +1431,63 @@ S_scan_const(pTHX_ char *start) yyerror("Missing right brace on \\x{}"); e = s; } - len = 1; /* allow underscores */ - uv = (UV)scan_hex(s + 1, e - s - 1, &len); - s = e + 1; + else { + STRLEN len = 1; /* allow underscores */ + uv = (UV)scan_hex(s + 1, e - s - 1, &len); + } + s = e + 1; } else { - len = 0; /* disallow underscores */ - uv = (UV)scan_hex(s, 2, &len); - s += len; + { + STRLEN len = 0; /* disallow underscores */ + uv = (UV)scan_hex(s, 2, &len); + s += len; + } } NUM_ESCAPE_INSERT: /* Insert oct or hex escaped character. - * There will always enough room in sv since such escapes will - * be longer than any utf8 sequence they can end up as - */ + * 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 (!thisutf && !has_utf && uv > 255) { - /* might need to recode whatever we have accumulated so far - * if it contains any hibit chars + 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--; @@ -1454,9 +1496,16 @@ S_scan_const(pTHX_ char *start) } } - if (thisutf || uv > 255) { + if (has_utf8 || uv > 255) { d = (char*)uv_to_utf8((U8*)d, uv); - has_utf = 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; @@ -1475,30 +1524,33 @@ 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_utf && SvUTF8(res)) { + if (!has_utf8 && SvUTF8(res)) { char *ostart = SvPVX(sv); SvCUR_set(sv, d - ostart); SvPOK_on(sv); + *d = '\0'; sv_utf8_upgrade(sv); /* this just broke our allocation above... */ SvGROW(sv, send - start); d = SvPVX(sv) + SvCUR(sv); - has_utf = TRUE; + has_utf8 = TRUE; } 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); @@ -1518,11 +1570,13 @@ S_scan_const(pTHX_ char *start) *d = *s++; if (isLOWER(*d)) *d = toUPPER(*d); - *d = toCTRL(*d); + *d = toCTRL(*d); d++; #else - len = *s++; - *d++ = toCTRL(len); + { + U8 c = *s++; + *d++ = toCTRL(c); + } #endif continue; @@ -1563,14 +1617,41 @@ 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 */ *d = '\0'; SvCUR_set(sv, d - SvPVX(sv)); SvPOK_on(sv); - if (has_utf) + if (has_utf8) SvUTF8_on(sv); /* shrink the sv if we allocated more than we used */ @@ -1582,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" @@ -1855,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). * @@ -1891,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 @@ -1918,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; @@ -1932,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) ; @@ -2054,28 +2135,40 @@ S_find_in_my_stash(pTHX_ char *pkgname, I32 len) if we already built the token before, use it. */ +#ifdef USE_PURE_BISON +int +Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp) +{ + int r; + + yyactlevel++; + yylval_pointer[yyactlevel] = lvalp; + yychar_pointer[yyactlevel] = lcharp; + if (yyactlevel >= YYMAXLEVEL) + Perl_croak(aTHX_ "panic: YYMAXLEVEL"); + + r = Perl_yylex(aTHX); + + if (yyactlevel > 0) + yyactlevel--; + + return r; +} +#endif + #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; - -#ifdef USE_PURE_BISON - yylval_pointer = lvalp; - yychar_pointer = lcharp; -#endif + bool bof = FALSE; /* check if there's an identifier for us to look at */ if (PL_pending_ident) { @@ -2083,6 +2176,9 @@ Perl_yylex(pTHX) char pit = PL_pending_ident; PL_pending_ident = 0; + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Tokener saw identifier '%s'\n", PL_tokenbuf); }) + /* if we're in a my(), we can't allow dynamics here. $foo'bar has already been turned into $foo::bar, so just check for colons. @@ -2107,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 @@ -2220,6 +2316,10 @@ Perl_yylex(pTHX) PL_expect = PL_lex_expect; PL_lex_defer = LEX_NORMAL; } + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr, + (IV)PL_nexttype[PL_nexttoke]); }) + return(PL_nexttype[PL_nexttoke]); /* interpolated case modifiers like \L \U, including \Q and \E. @@ -2251,6 +2351,8 @@ Perl_yylex(pTHX) return yylex(); } else { + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Saw case modifier at '%s'\n", PL_bufptr); }) s = PL_bufptr + 1; if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */ @@ -2301,6 +2403,8 @@ Perl_yylex(pTHX) case LEX_INTERPSTART: if (PL_bufptr == PL_bufend) return sublex_done(); + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Interpolated variable at '%s'\n", PL_bufptr); }) PL_expect = XTERM; PL_lex_dojoin = (*PL_bufptr == '@'); PL_lex_state = LEX_INTERPNORMAL; @@ -2397,7 +2501,7 @@ Perl_yylex(pTHX) s = PL_bufptr; PL_oldoldbufptr = PL_oldbufptr; PL_oldbufptr = s; - DEBUG_p( { + DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n", exp_name[PL_expect], s); } ) @@ -2417,6 +2521,9 @@ 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, + "### Tokener got EOF\n"); + } ) TOKEN(0); } if (s++ < PL_bufend) @@ -2472,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); @@ -2482,10 +2590,8 @@ Perl_yylex(pTHX) goto retry; } do { - bool bof; - bof = PL_rsfp && (PerlIO_tell(PL_rsfp) == 0); /* *Before* read! */ - s = filter_gets(PL_linestr, PL_rsfp, 0); - if (s == Nullch) { + 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) @@ -2502,15 +2608,44 @@ Perl_yylex(pTHX) 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 */ - } else if (bof) { - PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - s = swallow_bom((U8*)s); + } + /* 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 */ +# define FTELL_FOR_PIPE_IS_BROKEN +# endif +# else +# ifdef __GLIBC__ +# if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */ +# define FTELL_FOR_PIPE_IS_BROKEN +# endif +# endif +# endif +#endif +#ifdef FTELL_FOR_PIPE_IS_BROKEN + /* This loses the possibility to detect the bof + * situation on perl -P when the libc5 is being used. + * Workaround? Maybe attach some extra state to PL_rsfp? + */ + if (!PL_preprocess) + bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr); +#else + bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr); +#endif + 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")) @@ -2521,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; @@ -2535,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++; @@ -2648,7 +2785,7 @@ Perl_yylex(pTHX) else newargv = PL_origargv; newargv[0] = ipath; - PerlProc_execv(ipath, newargv); + PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv)); Perl_croak(aTHX_ "Can't exec %s", ipath); } #endif @@ -2678,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); @@ -2696,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: @@ -2732,6 +2870,8 @@ Perl_yylex(pTHX) goto retry; case '-': if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) { + I32 ftst = 0; + s++; PL_bufptr = s; tmp = *s++; @@ -2741,42 +2881,65 @@ Perl_yylex(pTHX) if (strnEQ(s,"=>",2)) { s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw unary minus before =>, forcing word '%s'\n", s); + } ) OPERATOR('-'); /* unary minus */ } PL_last_uni = PL_oldbufptr; - PL_last_lop_op = OP_FTEREAD; /* good enough */ switch (tmp) { - case 'r': FTST(OP_FTEREAD); - case 'w': FTST(OP_FTEWRITE); - case 'x': FTST(OP_FTEEXEC); - case 'o': FTST(OP_FTEOWNED); - case 'R': FTST(OP_FTRREAD); - case 'W': FTST(OP_FTRWRITE); - case 'X': FTST(OP_FTREXEC); - case 'O': FTST(OP_FTROWNED); - case 'e': FTST(OP_FTIS); - case 'z': FTST(OP_FTZERO); - case 's': FTST(OP_FTSIZE); - case 'f': FTST(OP_FTFILE); - case 'd': FTST(OP_FTDIR); - case 'l': FTST(OP_FTLINK); - case 'p': FTST(OP_FTPIPE); - case 'S': FTST(OP_FTSOCK); - case 'u': FTST(OP_FTSUID); - case 'g': FTST(OP_FTSGID); - case 'k': FTST(OP_FTSVTX); - case 'b': FTST(OP_FTBLK); - case 'c': FTST(OP_FTCHR); - case 't': FTST(OP_FTTTY); - case 'T': FTST(OP_FTTEXT); - case 'B': FTST(OP_FTBINARY); - case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME); - case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME); - case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME); + case 'r': ftst = OP_FTEREAD; break; + case 'w': ftst = OP_FTEWRITE; break; + case 'x': ftst = OP_FTEEXEC; break; + case 'o': ftst = OP_FTEOWNED; break; + case 'R': ftst = OP_FTRREAD; break; + case 'W': ftst = OP_FTRWRITE; break; + case 'X': ftst = OP_FTREXEC; break; + case 'O': ftst = OP_FTROWNED; break; + case 'e': ftst = OP_FTIS; break; + case 'z': ftst = OP_FTZERO; break; + case 's': ftst = OP_FTSIZE; break; + case 'f': ftst = OP_FTFILE; break; + case 'd': ftst = OP_FTDIR; break; + case 'l': ftst = OP_FTLINK; break; + case 'p': ftst = OP_FTPIPE; break; + case 'S': ftst = OP_FTSOCK; break; + case 'u': ftst = OP_FTSUID; break; + case 'g': ftst = OP_FTSGID; break; + case 'k': ftst = OP_FTSVTX; break; + case 'b': ftst = OP_FTBLK; break; + case 'c': ftst = OP_FTCHR; break; + case 't': ftst = OP_FTTTY; break; + case 'T': ftst = OP_FTTEXT; break; + case 'B': ftst = OP_FTBINARY; break; + case 'M': case 'A': case 'C': + gv_fetchpv("\024",TRUE, SVt_PV); + switch (tmp) { + case 'M': ftst = OP_FTMTIME; break; + case 'A': ftst = OP_FTATIME; break; + case 'C': ftst = OP_FTCTIME; break; + default: break; + } + break; default: - Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp); break; } + if (ftst) { + PL_last_lop_op = ftst; + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw file test %c\n", (int)ftst); + } ) + 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; + } } tmp = *s++; if (*s == tmp) { @@ -2905,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(). */ @@ -2928,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] != ':') @@ -3474,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(); @@ -3519,13 +3694,19 @@ Perl_yylex(pTHX) /* FALL THROUGH */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': - s = scan_num(s); + s = scan_num(s, &yylval); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw number in '%s'\n", s); + } ) if (PL_expect == XOPERATOR) no_op("Number",s); TERM(THING); case '\'': s = scan_str(s,FALSE,FALSE); + 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) { PL_expect = XTERM; @@ -3542,6 +3723,9 @@ Perl_yylex(pTHX) case '"': s = scan_str(s,FALSE,FALSE); + 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) { PL_expect = XTERM; @@ -3555,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; } @@ -3564,6 +3748,9 @@ Perl_yylex(pTHX) case '`': s = scan_str(s,FALSE,FALSE); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw backtick string before '%s'\n", s); + } ) if (PL_expect == XOPERATOR) no_op("Backticks",s); if (!s) @@ -3589,7 +3776,7 @@ Perl_yylex(pTHX) while (isDIGIT(*start) || *start == '_') start++; if (*start == '.' && isDIGIT(start[1])) { - s = scan_num(s); + s = scan_num(s, &yylval); TERM(THING); } /* avoid v123abc() or $h{v1}, allow C */ @@ -3600,7 +3787,7 @@ Perl_yylex(pTHX) gv = gv_fetchpv(s, FALSE, SVt_PVCV); *start = c; if (!gv) { - s = scan_num(s); + s = scan_num(s, &yylval); TERM(THING); } } @@ -3679,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); } @@ -3763,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; @@ -3820,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; @@ -3838,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); } @@ -4000,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; @@ -4159,7 +4350,7 @@ Perl_yylex(pTHX) case KEY_exists: UNI(OP_EXISTS); - + case KEY_exit: UNI(OP_EXIT); @@ -4363,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); @@ -4508,7 +4699,7 @@ Perl_yylex(pTHX) case KEY_pos: UNI(OP_POS); - + case KEY_pack: LOP(OP_PACK,XTERM); @@ -4539,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; @@ -4559,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) { @@ -4568,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('('); @@ -4670,7 +4866,7 @@ Perl_yylex(pTHX) case KEY_chomp: UNI(OP_CHOMP); - + case KEY_scalar: UNI(OP_SCALAR); @@ -4838,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; @@ -4959,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"); } @@ -5014,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); } @@ -5160,7 +5352,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) if (strEQ(d,"exit")) return -KEY_exit; if (strEQ(d,"eval")) return KEY_eval; if (strEQ(d,"exec")) return -KEY_exec; - if (strEQ(d,"each")) return KEY_each; + if (strEQ(d,"each")) return -KEY_each; break; case 5: if (strEQ(d,"elsif")) return KEY_elsif; @@ -5304,7 +5496,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) break; case 'k': if (len == 4) { - if (strEQ(d,"keys")) return KEY_keys; + if (strEQ(d,"keys")) return -KEY_keys; if (strEQ(d,"kill")) return -KEY_kill; } break; @@ -5386,11 +5578,11 @@ 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: - if (strEQ(d,"push")) return KEY_push; + if (strEQ(d,"push")) return -KEY_push; if (strEQ(d,"pack")) return -KEY_pack; if (strEQ(d,"pipe")) return -KEY_pipe; break; @@ -5497,7 +5689,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) case 'h': switch (len) { case 5: - if (strEQ(d,"shift")) return KEY_shift; + if (strEQ(d,"shift")) return -KEY_shift; break; case 6: if (strEQ(d,"shmctl")) return -KEY_shmctl; @@ -5526,7 +5718,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) case 'p': if (strEQ(d,"split")) return KEY_split; if (strEQ(d,"sprintf")) return -KEY_sprintf; - if (strEQ(d,"splice")) return KEY_splice; + if (strEQ(d,"splice")) return -KEY_splice; break; case 'q': if (strEQ(d,"sqrt")) return -KEY_sqrt; @@ -5606,7 +5798,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) if (strEQ(d,"unlink")) return -KEY_unlink; break; case 7: - if (strEQ(d,"unshift")) return KEY_unshift; + if (strEQ(d,"unshift")) return -KEY_unshift; if (strEQ(d,"ucfirst")) return -KEY_ucfirst; break; } @@ -5652,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++) { @@ -5707,18 +5898,27 @@ 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; - why1 = "%^H is not consistent"; why2 = strEQ(key,"charnames") - ? " (missing \"use charnames ...\"?)" + ? "(possibly a missing \"use charnames ...\")" : ""; - why3 = ""; + msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s", + (type ? type: "undef"), why2); + + /* This is convoluted and evil ("goto considered harmful") + * but I do not understand the intricacies of all the different + * failure modes of %^H in here. The goal here is to make + * the most probable error message user-friendly. --jhi */ + + 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)); SvREFCNT_dec(msg); return sv; @@ -5738,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) @@ -5752,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; @@ -5767,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; @@ -5783,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) { @@ -5803,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); @@ -5855,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); @@ -5910,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); @@ -5926,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, @@ -5937,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)) @@ -5958,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))) { @@ -6004,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 == '?') @@ -6041,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--; @@ -6054,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 */ @@ -6108,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') @@ -6147,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; @@ -6157,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; @@ -6290,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 */ @@ -6301,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') || @@ -6342,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; @@ -6492,31 +6677,30 @@ 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 */ register char term; /* terminating character */ register char *to; /* current position in the sv's data */ I32 brackets = 1; /* bracket nesting level */ - bool has_utf = FALSE; /* is there any utf8 content? */ + bool has_utf8 = FALSE; /* is there any utf8 content? */ /* skip space before the delimiter */ if (isSPACE(*s)) @@ -6527,8 +6711,8 @@ 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) - has_utf = TRUE; + if (UTF8_IS_CONTINUED(term) && UTF) + has_utf8 = TRUE; /* mark where we are */ PL_multi_start = CopLINE(PL_curcop); @@ -6574,8 +6758,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) have found the terminator */ else if (*s == term) break; - else if (!has_utf && (*s & 0x80) && UTF) - has_utf = TRUE; + else if (!has_utf8 && UTF8_IS_CONTINUED(*s) && UTF) + has_utf8 = TRUE; *to = *s; } } @@ -6603,8 +6787,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) break; else if (*s == PL_multi_open) brackets++; - else if (!has_utf && (*s & 0x80) && UTF) - has_utf = TRUE; + else if (!has_utf8 && UTF8_IS_CONTINUED(*s) && UTF) + has_utf8 = TRUE; *to = *s; } } @@ -6658,13 +6842,14 @@ 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) sv_catpvn(sv, s, 1); - if (has_utf) + if (has_utf8) SvUTF8_on(sv); PL_multi_end = CopLINE(PL_curcop); s++; @@ -6678,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 @@ -6707,9 +6892,9 @@ 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) +Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) { register char *s = start; /* current position in buffer */ register char *d; /* destination in temp buffer */ @@ -6725,7 +6910,7 @@ Perl_scan_num(pTHX_ char *start) 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': @@ -6740,7 +6925,6 @@ Perl_scan_num(pTHX_ char *start) we in octal/hex/binary?" indicator to disallow hex characters when in octal mode. */ - dTHR; NV n = 0.0; UV u = 0; I32 shift; @@ -6828,7 +7012,6 @@ Perl_scan_num(pTHX_ char *start) if ((x >> shift) != u && !(PL_hints & HINT_NEW_BINARY)) { - dTHR; overflowed = TRUE; n = (NV) u; if (ckWARN_d(WARN_OVERFLOW)) @@ -6860,7 +7043,6 @@ Perl_scan_num(pTHX_ char *start) 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", @@ -6869,7 +7051,6 @@ Perl_scan_num(pTHX_ char *start) } else { #if UVSIZE > 4 - dTHR; if (ckWARN(WARN_PORTABLE) && u > 0xffffffff) Perl_warner(aTHX_ WARN_PORTABLE, "%s number > %s non-portable", @@ -6895,11 +7076,10 @@ Perl_scan_num(pTHX_ char *start) /* 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; @@ -6915,7 +7095,6 @@ Perl_scan_num(pTHX_ char *start) /* final misplaced underbar check */ if (lastub && s - lastub != 3) { - dTHR; if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number"); } @@ -7024,7 +7203,7 @@ Perl_scan_num(pTHX_ char *start) 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) @@ -7035,7 +7214,7 @@ Perl_scan_num(pTHX_ char *start) 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 */ { @@ -7052,7 +7231,7 @@ Perl_scan_num(pTHX_ char *start) #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; @@ -7066,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); @@ -7096,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; @@ -7110,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); } } } @@ -7122,9 +7302,9 @@ vstring: /* make the op for the constant and return */ if (sv) - yylval.opval = newSVOP(OP_CONST, 0, sv); + lvalp->opval = newSVOP(OP_CONST, 0, sv); else - yylval.opval = Nullop; + lvalp->opval = Nullop; return s; } @@ -7132,7 +7312,6 @@ vstring: STATIC char * S_scan_formline(pTHX_ register char *s) { - dTHR; register char *eol; register char *t; SV *stuff = newSVpvn("",0); @@ -7180,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"); @@ -7223,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; @@ -7276,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; @@ -7289,7 +7470,6 @@ Perl_yywarn(pTHX_ char *s) int Perl_yyerror(pTHX_ char *s) { - dTHR; char *where = NULL; char *context = NULL; int contlen = -1; @@ -7366,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) @@ -7373,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"); @@ -7476,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); }