X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=717bfdcfc9ad2eb5181636aa5bd27853ebe75206;hb=a19d7498e238ac7c03cb96036dee4a734a2a0356;hp=46aa3aa0ac3357c6c2ecc131ba7adf07312a7d62;hpb=984200d0e3101dedd636f99bf5d5603033f7162d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 46aa3aa..717bfdc 100644 --- a/toke.c +++ b/toke.c @@ -1,7 +1,7 @@ /* toke.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -26,9 +26,12 @@ #define yychar (*PL_yycharp) #define yylval (*PL_yylvalp) -static char ident_too_long[] = "Identifier too long"; -static char c_without_g[] = "Use of /c modifier is meaningless without /g"; -static char c_in_subst[] = "Use of /c modifier is meaningless in s///"; +static const char ident_too_long[] = + "Identifier too long"; +static const char c_without_g[] = + "Use of /c modifier is meaningless without /g"; +static const char c_in_subst[] = + "Use of /c modifier is meaningless in s///"; static void restore_rsfp(pTHX_ void *f); #ifndef PERL_NO_UTF16_FILTER @@ -63,17 +66,38 @@ static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen); /* #define LEX_NOTPARSING 11 is done in perl.h. */ -#define LEX_NORMAL 10 -#define LEX_INTERPNORMAL 9 -#define LEX_INTERPCASEMOD 8 -#define LEX_INTERPPUSH 7 -#define LEX_INTERPSTART 6 -#define LEX_INTERPEND 5 -#define LEX_INTERPENDMAYBE 4 -#define LEX_INTERPCONCAT 3 -#define LEX_INTERPCONST 2 -#define LEX_FORMLINE 1 -#define LEX_KNOWNEXT 0 +#define LEX_NORMAL 10 /* normal code (ie not within "...") */ +#define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */ +#define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */ +#define LEX_INTERPPUSH 7 /* starting a new sublex parse level */ +#define LEX_INTERPSTART 6 /* expecting the start of a $var */ + + /* at end of code, eg "$x" followed by: */ +#define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */ +#define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */ + +#define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of + string or after \E, $foo, etc */ +#define LEX_INTERPCONST 2 /* NOT USED */ +#define LEX_FORMLINE 1 /* expecting a format line */ +#define LEX_KNOWNEXT 0 /* next token known; just return it */ + + +#ifdef DEBUGGING +static const char* const lex_state_names[] = { + "KNOWNEXT", + "FORMLINE", + "INTERPCONST", + "INTERPCONCAT", + "INTERPENDMAYBE", + "INTERPEND", + "INTERPSTART", + "INTERPPUSH", + "INTERPCASEMOD", + "INTERPNORMAL", + "NORMAL" +}; +#endif #ifdef ff_next #undef ff_next @@ -116,79 +140,213 @@ static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen); * Also see LOP and lop() below. */ -/* 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), +# define REPORT(retval) tokereport(s,(int)retval) #else -# define REPORT(x,retval) -# define REPORT2(x,retval) +# define REPORT(retval) (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 = XTERMORDORDOR,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) +#define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval)) +#define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval)) +#define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval))) +#define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval)) +#define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval)) +#define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval)) +#define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval)) +#define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX)) +#define FTST(f) return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP)) +#define FUN0(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0)) +#define FUN1(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1)) +#define BOop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP))) +#define BAop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP))) +#define SHop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP))) +#define PWop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP))) +#define PMop(f) return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP)) +#define Aop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP))) +#define Mop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP))) +#define Eop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP)) +#define Rop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP)) /* This bit of chicanery makes a unary function followed by * a parenthesis into a function with one argument, highest precedence. * The UNIDOR macro is for unary functions that can be followed by the // * operator (such as C). */ -#define UNI2(f,x) return(yylval.ival = f, \ - REPORT("uni",f) \ - PL_expect = x, \ - PL_bufptr = s, \ - PL_last_uni = PL_oldbufptr, \ - PL_last_lop_op = f, \ - (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) ) +#define UNI2(f,x) { \ + yylval.ival = f; \ + PL_expect = x; \ + PL_bufptr = s; \ + PL_last_uni = PL_oldbufptr; \ + PL_last_lop_op = f; \ + if (*s == '(') \ + return REPORT( (int)FUNC1 ); \ + s = skipspace(s); \ + return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \ + } #define UNI(f) UNI2(f,XTERM) #define UNIDOR(f) UNI2(f,XTERMORDORDOR) -#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) ) +#define UNIBRACK(f) { \ + yylval.ival = f; \ + PL_bufptr = s; \ + PL_last_uni = PL_oldbufptr; \ + if (*s == '(') \ + return REPORT( (int)FUNC1 ); \ + s = skipspace(s); \ + return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \ + } /* grandfather return to old style */ #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP) #ifdef DEBUGGING -STATIC void -S_tokereport(pTHX_ char *thing, char* s, I32 rv) +/* how to interpret the yylval associated with the token */ +enum token_type { + TOKENTYPE_NONE, + TOKENTYPE_IVAL, + TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */ + TOKENTYPE_PVAL, + TOKENTYPE_OPVAL, + TOKENTYPE_GVVAL +}; + +static struct debug_tokens { const int token, type; const char *name; } + const debug_tokens[] = { - DEBUG_T({ - SV* report = newSVpv(thing, 0); - Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop), - (IV)rv); + { ADDOP, TOKENTYPE_OPNUM, "ADDOP" }, + { ANDAND, TOKENTYPE_NONE, "ANDAND" }, + { ANDOP, TOKENTYPE_NONE, "ANDOP" }, + { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" }, + { ARROW, TOKENTYPE_NONE, "ARROW" }, + { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" }, + { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" }, + { BITOROP, TOKENTYPE_OPNUM, "BITOROP" }, + { COLONATTR, TOKENTYPE_NONE, "COLONATTR" }, + { CONTINUE, TOKENTYPE_NONE, "CONTINUE" }, + { DO, TOKENTYPE_NONE, "DO" }, + { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" }, + { DORDOR, TOKENTYPE_NONE, "DORDOR" }, + { DOROP, TOKENTYPE_OPNUM, "DOROP" }, + { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" }, + { ELSE, TOKENTYPE_NONE, "ELSE" }, + { ELSIF, TOKENTYPE_IVAL, "ELSIF" }, + { EQOP, TOKENTYPE_OPNUM, "EQOP" }, + { FOR, TOKENTYPE_IVAL, "FOR" }, + { FORMAT, TOKENTYPE_NONE, "FORMAT" }, + { FUNC, TOKENTYPE_OPNUM, "FUNC" }, + { FUNC0, TOKENTYPE_OPNUM, "FUNC0" }, + { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" }, + { FUNC1, TOKENTYPE_OPNUM, "FUNC1" }, + { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" }, + { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" }, + { IF, TOKENTYPE_IVAL, "IF" }, + { LABEL, TOKENTYPE_PVAL, "LABEL" }, + { LOCAL, TOKENTYPE_IVAL, "LOCAL" }, + { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" }, + { LSTOP, TOKENTYPE_OPNUM, "LSTOP" }, + { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" }, + { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" }, + { METHOD, TOKENTYPE_OPVAL, "METHOD" }, + { MULOP, TOKENTYPE_OPNUM, "MULOP" }, + { MY, TOKENTYPE_IVAL, "MY" }, + { MYSUB, TOKENTYPE_NONE, "MYSUB" }, + { NOAMP, TOKENTYPE_NONE, "NOAMP" }, + { NOTOP, TOKENTYPE_NONE, "NOTOP" }, + { OROP, TOKENTYPE_IVAL, "OROP" }, + { OROR, TOKENTYPE_NONE, "OROR" }, + { PACKAGE, TOKENTYPE_NONE, "PACKAGE" }, + { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" }, + { POSTDEC, TOKENTYPE_NONE, "POSTDEC" }, + { POSTINC, TOKENTYPE_NONE, "POSTINC" }, + { POWOP, TOKENTYPE_OPNUM, "POWOP" }, + { PREDEC, TOKENTYPE_NONE, "PREDEC" }, + { PREINC, TOKENTYPE_NONE, "PREINC" }, + { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" }, + { REFGEN, TOKENTYPE_NONE, "REFGEN" }, + { RELOP, TOKENTYPE_OPNUM, "RELOP" }, + { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" }, + { SUB, TOKENTYPE_NONE, "SUB" }, + { THING, TOKENTYPE_OPVAL, "THING" }, + { UMINUS, TOKENTYPE_NONE, "UMINUS" }, + { UNIOP, TOKENTYPE_OPNUM, "UNIOP" }, + { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" }, + { UNLESS, TOKENTYPE_IVAL, "UNLESS" }, + { UNTIL, TOKENTYPE_IVAL, "UNTIL" }, + { USE, TOKENTYPE_IVAL, "USE" }, + { WHILE, TOKENTYPE_IVAL, "WHILE" }, + { WORD, TOKENTYPE_OPVAL, "WORD" }, + { 0, TOKENTYPE_NONE, 0 } +}; + +/* dump the returned token in rv, plus any optional arg in yylval */ - 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)); - }); +STATIC int +S_tokereport(pTHX_ const char* s, I32 rv) +{ + if (DEBUG_T_TEST) { + const char *name = Nullch; + enum token_type type = TOKENTYPE_NONE; + const struct debug_tokens *p; + SV* const report = newSVpvn("<== ", 4); + + for (p = debug_tokens; p->token; p++) { + if (p->token == (int)rv) { + name = p->name; + type = p->type; + break; + } + } + if (name) + Perl_sv_catpv(aTHX_ report, name); + else if ((char)rv > ' ' && (char)rv < '~') + Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv); + else if (!rv) + Perl_sv_catpv(aTHX_ report, "EOF"); + else + Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv); + switch (type) { + case TOKENTYPE_NONE: + case TOKENTYPE_GVVAL: /* doesn't appear to be used */ + break; + case TOKENTYPE_IVAL: + Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival); + break; + case TOKENTYPE_OPNUM: + Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)", + PL_op_name[yylval.ival]); + break; + case TOKENTYPE_PVAL: + Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval); + break; + case TOKENTYPE_OPVAL: + if (yylval.opval) { + Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)", + PL_op_name[yylval.opval->op_type]); + if (yylval.opval->op_type == OP_CONST) { + Perl_sv_catpvf(aTHX_ report, " %s", + SvPEEK(cSVOPx_sv(yylval.opval))); + } + + } + else + Perl_sv_catpv(aTHX_ report, "(opval=null)"); + break; + } + PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report)); + }; + return (int)rv; +} + + +/* print the buffer with suitable escapes */ + +STATIC void +S_printbuf(pTHX_ const char* fmt, const char* s) +{ + SV* tmp = newSVpvn("", 0); + PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60)); + SvREFCNT_dec(tmp); } #endif @@ -230,10 +388,10 @@ S_ao(pTHX_ int toketype) */ STATIC void -S_no_op(pTHX_ char *what, char *s) +S_no_op(pTHX_ const char *what, char *s) { - char *oldbp = PL_bufptr; - bool is_first = (PL_oldbufptr == PL_linestart); + char * const oldbp = PL_bufptr; + const bool is_first = (PL_oldbufptr == PL_linestart); if (!s) s = oldbp; @@ -245,7 +403,7 @@ S_no_op(pTHX_ char *what, char *s) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\t(Missing semicolon on previous line?)\n"); else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) { - char *t; + const char *t; for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ; if (t < PL_bufptr && isSPACE(*t)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), @@ -276,7 +434,7 @@ S_missingterm(pTHX_ char *s) char tmpbuf[3]; char q; if (s) { - char *nl = strrchr(s,'\n'); + char * const nl = strrchr(s,'\n'); if (nl) *nl = '\0'; } @@ -289,7 +447,6 @@ S_missingterm(pTHX_ char *s) ) { *tmpbuf = '^'; tmpbuf[1] = toCTRL(PL_multi_close); - s = "\\n"; tmpbuf[2] = '\0'; s = tmpbuf; } @@ -307,14 +464,14 @@ S_missingterm(pTHX_ char *s) */ void -Perl_deprecate(pTHX_ char *s) +Perl_deprecate(pTHX_ const char *s) { if (ckWARN(WARN_DEPRECATED)) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s); } void -Perl_deprecate_old(pTHX_ char *s) +Perl_deprecate_old(pTHX_ const char *s) { /* This function should NOT be called for any new deprecated warnings */ /* Use Perl_deprecate instead */ @@ -325,7 +482,7 @@ Perl_deprecate_old(pTHX_ char *s) /* in its own right. */ if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of %s is deprecated", s); } @@ -349,8 +506,8 @@ S_depcom(pTHX) static void strip_return(SV *sv) { - register char *s = SvPVX(sv); - register char *e = s + SvCUR(sv); + register const char *s = SvPVX_const(sv); + register const char * const e = s + SvCUR(sv); /* outer loop optimized to do nothing if there are no CR-LFs */ while (s < e) { if (*s++ == '\r' && *s == '\n') { @@ -371,7 +528,7 @@ strip_return(SV *sv) STATIC I32 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) { - I32 count = FILTER_READ(idx+1, sv, maxlen); + const I32 count = FILTER_READ(idx+1, sv, maxlen); if (count > 0 && !maxlen) strip_return(sv); return count; @@ -387,7 +544,7 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) void Perl_lex_start(pTHX_ SV *line) { - char *s; + const char *s; STRLEN len; SAVEI32(PL_lex_dojoin); @@ -428,8 +585,8 @@ Perl_lex_start(pTHX_ SV *line) PL_lex_defer = 0; PL_expect = XSTATE; PL_lex_brackets = 0; - New(899, PL_lex_brackstack, 120, char); - New(899, PL_lex_casestack, 12, char); + Newx(PL_lex_brackstack, 120, char); + Newx(PL_lex_casestack, 12, char); PL_lex_casemods = 0; *PL_lex_casestack = '\0'; PL_lex_dojoin = 0; @@ -443,7 +600,7 @@ Perl_lex_start(pTHX_ SV *line) PL_linestr = line; if (SvREADONLY(PL_linestr)) PL_linestr = sv_2mortal(newSVsv(PL_linestr)); - s = SvPV(PL_linestr, len); + s = SvPV_const(PL_linestr, len); if (!len || s[len-1] != ';') { if (!(SvFLAGS(PL_linestr) & SVs_TEMP)) PL_linestr = sv_2mortal(newSVsv(PL_linestr)); @@ -522,6 +679,43 @@ S_incline(pTHX_ char *s) ch = *t; *t = '\0'; if (t - s > 0) { +#ifndef USE_ITHREADS + const char *cf = CopFILE(PL_curcop); + if (cf && strlen(cf) > 7 && strnEQ(cf, "(eval ", 6)) { + /* must copy *{"::_<(eval N)[oldfilename:L]"} + * to *{"::_op_private |= OPpCONST_BARE; - if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len)) - SvUTF8_on(((SVOP*)PL_nextval[PL_nexttoke].opval)->op_sv); force_next(token); } return s; @@ -792,10 +996,10 @@ S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow */ STATIC void -S_force_ident(pTHX_ register char *s, int kind) +S_force_ident(pTHX_ register const char *s, int kind) { if (s && *s) { - OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0)); + OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0)); PL_nextval[PL_nexttoke].opval = o; force_next(WORD); if (kind) { @@ -819,9 +1023,9 @@ Perl_str_to_version(pTHX_ SV *sv) NV retval = 0.0; NV nshift = 1.0; STRLEN len; - char *start = SvPVx(sv,len); - bool utf = SvUTF8(sv) ? TRUE : FALSE; - char *end = start + len; + const char *start = SvPV_const(sv,len); + const char * const end = start + len; + const bool utf = SvUTF8(sv) ? TRUE : FALSE; while (start < end) { STRLEN skip; UV n; @@ -866,8 +1070,8 @@ S_force_version(pTHX_ char *s, int guessing) version = yylval.opval; ver = cSVOPx(version)->op_sv; if (SvPOK(ver) && !SvNIOK(ver)) { - (void)SvUPGRADE(ver, SVt_PVNV); - SvNVX(ver) = str_to_version(ver); + SvUPGRADE(ver, SVt_PVNV); + SvNV_set(ver, str_to_version(ver)); SvNOK_on(ver); /* hint that it is a version */ } } @@ -912,7 +1116,7 @@ S_tokeq(pTHX_ SV *sv) goto finish; d = s; if ( PL_hints & HINT_NEW_STRING ) { - pv = sv_2mortal(newSVpvn(SvPVX(pv), len)); + pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len)); if (SvUTF8(sv)) SvUTF8_on(pv); } @@ -924,7 +1128,7 @@ S_tokeq(pTHX_ SV *sv) *d++ = *s++; } *d = '\0'; - SvCUR_set(sv, d - SvPVX(sv)); + SvCUR_set(sv, d - SvPVX_const(sv)); finish: if ( PL_hints & HINT_NEW_STRING ) return new_constant(NULL, 0, "q", sv, pv, "q"); @@ -966,7 +1170,7 @@ S_tokeq(pTHX_ SV *sv) STATIC I32 S_sublex_start(pTHX) { - register I32 op_type = yylval.ival; + const register I32 op_type = yylval.ival; if (op_type == OP_NULL) { yylval.opval = PL_lex_op; @@ -979,11 +1183,8 @@ S_sublex_start(pTHX) if (SvTYPE(sv) == SVt_PVIV) { /* Overloaded constants, nothing fancy: Convert to SVt_PV: */ STRLEN len; - char *p; - SV *nsv; - - p = SvPV(sv, len); - nsv = newSVpvn(p, len); + const char *p = SvPV_const(sv, len); + SV * const nsv = newSVpvn(p, len); if (SvUTF8(sv)) SvUTF8_on(nsv); SvREFCNT_dec(sv); @@ -1023,6 +1224,7 @@ S_sublex_start(pTHX) STATIC I32 S_sublex_push(pTHX) { + dVAR; ENTER; PL_lex_state = PL_sublex_info.super_state; @@ -1056,8 +1258,8 @@ S_sublex_push(pTHX) PL_lex_dojoin = FALSE; PL_lex_brackets = 0; - New(899, PL_lex_brackstack, 120, char); - New(899, PL_lex_casestack, 12, char); + Newx(PL_lex_brackstack, 120, char); + Newx(PL_lex_casestack, 12, char); PL_lex_casemods = 0; *PL_lex_casestack = '\0'; PL_lex_starts = 0; @@ -1081,8 +1283,9 @@ S_sublex_push(pTHX) STATIC I32 S_sublex_done(pTHX) { + dVAR; if (!PL_lex_starts++) { - SV *sv = newSVpvn("",0); + SV * const sv = newSVpvn("",0); if (SvUTF8(PL_linestr)) SvUTF8_on(sv); PL_expect = XOPERATOR; @@ -1217,10 +1420,13 @@ S_scan_const(pTHX_ char *start) I32 has_utf8 = FALSE; /* Output constant is UTF8 */ I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */ UV uv; +#ifdef EBCDIC + UV literal_endpoint = 0; +#endif const char *leaveit = /* set of acceptably-backslashed characters */ PL_lex_inpat - ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#" + ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#" : ""; if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { @@ -1240,7 +1446,7 @@ S_scan_const(pTHX_ char *start) I32 max; /* last character in range */ if (has_utf8) { - char *c = (char*)utf8_hop((U8*)d, -1); + char * const c = (char*)utf8_hop((U8*)d, -1); char *e = d++; while (e-- > c) *(e + 1) = *e; @@ -1251,7 +1457,7 @@ S_scan_const(pTHX_ char *start) continue; } - i = d - SvPVX(sv); /* remember current offset */ + i = d - SvPVX_const(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 */ d -= 2; /* eat the first char and the - */ @@ -1266,8 +1472,9 @@ S_scan_const(pTHX_ char *start) } #ifdef EBCDIC - if ((isLOWER(min) && isLOWER(max)) || - (isUPPER(min) && isUPPER(max))) { + if (literal_endpoint == 2 && + ((isLOWER(min) && isLOWER(max)) || + (isUPPER(min) && isUPPER(max)))) { if (isLOWER(min)) { for (i = min; i <= max; i++) if (isLOWER(i)) @@ -1286,6 +1493,9 @@ S_scan_const(pTHX_ char *start) /* mark the range as done, and continue */ dorange = FALSE; didrange = TRUE; +#ifdef EBCDIC + literal_endpoint = 0; +#endif continue; } @@ -1304,6 +1514,9 @@ S_scan_const(pTHX_ char *start) } else { didrange = FALSE; +#ifdef EBCDIC + literal_endpoint = 0; +#endif } } @@ -1404,9 +1617,9 @@ S_scan_const(pTHX_ char *start) /* FALL THROUGH */ default: { - if (ckWARN(WARN_MISC) && - isALNUM(*s) && - *s != '_') + if (isALNUM(*s) && + *s != '_' && + ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), "Unrecognized escape \\%c passed through", *s); @@ -1429,7 +1642,7 @@ S_scan_const(pTHX_ char *start) case 'x': ++s; if (*s == '{') { - char* e = strchr(s, '}'); + char* const e = strchr(s, '}'); I32 flags = PERL_SCAN_ALLOW_UNDERSCORES | PERL_SCAN_DISALLOW_PREFIX; STRLEN len; @@ -1478,15 +1691,15 @@ S_scan_const(pTHX_ char *start) } } if (hicount) { - STRLEN offset = d - SvPVX(sv); + const STRLEN offset = d - SvPVX_const(sv); U8 *src, *dst; d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset; src = (U8 *)d - 1; dst = src+hicount; d += hicount; - while (src >= (U8 *)SvPVX(sv)) { + while (src >= (const U8 *)SvPVX_const(sv)) { if (!NATIVE_IS_INVARIANT(*src)) { - U8 ch = NATIVE_TO_ASCII(*src); + const U8 ch = NATIVE_TO_ASCII(*src); *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch); *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch); } @@ -1524,7 +1737,7 @@ S_scan_const(pTHX_ char *start) char* e = strchr(s, '}'); SV *res; STRLEN len; - char *str; + const char *str; if (!e) { yyerror("Missing right brace on \\N{}"); @@ -1546,7 +1759,7 @@ S_scan_const(pTHX_ char *start) res, Nullsv, "\\N{...}" ); if (has_utf8) sv_utf8_upgrade(res); - str = SvPV(res,len); + str = SvPV_const(res,len); #ifdef EBCDIC_NEVER_MIND /* charnames uses pack U and that has been * recently changed to do the below uni->native @@ -1556,19 +1769,19 @@ S_scan_const(pTHX_ char *start) * gets revoked, but the semantics is still * desireable for charnames. --jhi */ { - UV uv = utf8_to_uvchr((U8*)str, 0); + UV uv = utf8_to_uvchr((const U8*)str, 0); if (uv < 0x100) { - U8 tmpbuf[UTF8_MAXLEN+1], *d; + U8 tmpbuf[UTF8_MAXBYTES+1], *d; d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv)); sv_setpvn(res, (char *)tmpbuf, d - tmpbuf); - str = SvPV(res, len); + str = SvPV_const(res, len); } } #endif if (!has_utf8 && SvUTF8(res)) { - char *ostart = SvPVX(sv); + const char * const ostart = SvPVX_const(sv); SvCUR_set(sv, d - ostart); SvPOK_on(sv); *d = '\0'; @@ -1579,7 +1792,7 @@ S_scan_const(pTHX_ char *start) has_utf8 = TRUE; } if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */ - char *odest = SvPVX(sv); + const char * const odest = SvPVX_const(sv); SvGROW(sv, (SvLEN(sv) + len - (e - s + 4))); d = SvPVX(sv) + (d - odest); @@ -1637,18 +1850,22 @@ S_scan_const(pTHX_ char *start) s++; continue; } /* end if (backslash) */ +#ifdef EBCDIC + else + literal_endpoint++; +#endif default_action: /* If we started with encoded form, or already know we want it and then encode the next character */ if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) { STRLEN len = 1; - UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s); - STRLEN need = UNISKIP(NATIVE_TO_UNI(uv)); + const UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s); + const STRLEN need = UNISKIP(NATIVE_TO_UNI(uv)); s += len; if (need > len) { /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */ - STRLEN off = d - SvPVX(sv); + const STRLEN off = d - SvPVX_const(sv); d = SvGROW(sv, SvLEN(sv) + (need-len)) + off; } d = (char*)uvchr_to_utf8((U8*)d, uv); @@ -1661,7 +1878,7 @@ S_scan_const(pTHX_ char *start) /* terminate the string and set up the sv */ *d = '\0'; - SvCUR_set(sv, d - SvPVX(sv)); + SvCUR_set(sv, d - SvPVX_const(sv)); if (SvCUR(sv) >= SvLEN(sv)) Perl_croak(aTHX_ "panic: constant overflowed allocated space"); @@ -1681,8 +1898,7 @@ S_scan_const(pTHX_ char *start) /* shrink the sv if we allocated more than we used */ if (SvCUR(sv) + 5 < SvLEN(sv)) { - SvLEN_set(sv, SvCUR(sv) + 1); - Renew(SvPVX(sv), SvLEN(sv), char); + SvPV_shrink_to_cur(sv); } /* return the substring (via yylval) only if we parsed anything */ @@ -1761,7 +1977,7 @@ S_intuit_more(pTHX_ register char *s) int weight = 2; /* let's weigh the evidence */ char seen[256]; unsigned char un_char = 255, last_un_char; - char *send = strchr(s,']'); + const char * const send = strchr(s,']'); char tmpbuf[sizeof PL_tokenbuf * 4]; if (!send) /* has to be an expression */ @@ -1830,8 +2046,10 @@ S_intuit_more(pTHX_ register char *s) weight -= 5; /* cope with negative subscript */ break; default: - if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) && - isALPHA(*s) && s[1] && isALPHA(s[1])) { + if (!isALNUM(last_un_char) + && !(last_un_char == '$' || last_un_char == '@' + || last_un_char == '&') + && isALPHA(*s) && s[1] && isALPHA(s[1])) { char *d = tmpbuf; while (isALPHA(*s)) *d++ = *s++; @@ -1887,7 +2105,7 @@ S_intuit_method(pTHX_ char *start, GV *gv) if (GvIO(gv)) return 0; if ((cv = GvCVu(gv))) { - char *proto = SvPVX(cv); + const char *proto = SvPVX_const(cv); if (proto) { if (*proto == ';') proto++; @@ -1945,11 +2163,11 @@ S_intuit_method(pTHX_ char *start, GV *gv) * compile-time require of perl5db.pl. */ -STATIC char* +STATIC const char* S_incl_perldb(pTHX) { if (PL_perldb) { - char *pdb = PerlEnv_getenv("PERL5DB"); + const char * const pdb = PerlEnv_getenv("PERL5DB"); if (pdb) return pdb; @@ -1987,12 +2205,11 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) PL_rsfp_filters = newAV(); if (!datasv) datasv = NEWSV(255,0); - if (!SvUPGRADE(datasv, SVt_PVIO)) - Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO"); - IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */ + SvUPGRADE(datasv, SVt_PVIO); + IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */ IoFLAGS(datasv) |= IOf_FAKE_DIRP; DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n", - (void*)funcp, SvPV_nolen(datasv))); + IoANY(datasv), SvPV_nolen(datasv))); av_unshift(PL_rsfp_filters, 1); av_store(PL_rsfp_filters, 0, datasv) ; return(datasv); @@ -2004,12 +2221,15 @@ void Perl_filter_del(pTHX_ filter_t funcp) { SV *datasv; - DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp)); + +#ifdef DEBUGGING + DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp))); +#endif if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0) return; /* if filter is on top of stack (usual case) just pop it off */ datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters)); - if (IoANY(datasv) == (void *)funcp) { + if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) { IoFLAGS(datasv) &= ~IOf_FAKE_DIRP; IoANY(datasv) = (void *)NULL; sv_free(av_pop(PL_rsfp_filters)); @@ -2021,19 +2241,17 @@ Perl_filter_del(pTHX_ filter_t funcp) } -/* Invoke the n'th filter function for the current rsfp. */ +/* Invoke the idxth filter function for the current rsfp. */ +/* maxlen 0 = read one text line */ I32 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) - - - /* 0 = read one text line */ { filter_t funcp; SV *datasv = NULL; if (!PL_rsfp_filters) return -1; - if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */ + if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */ /* Provide a default input filter to make life easy. */ /* Note that we append to the line. This is handy. */ DEBUG_P(PerlIO_printf(Perl_debug_log, @@ -2041,7 +2259,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) if (maxlen) { /* Want a block */ int len ; - int old_len = SvCUR(buf_sv) ; + const int old_len = SvCUR(buf_sv); /* ensure buf_sv is large enough */ SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ; @@ -2064,17 +2282,17 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) return SvCUR(buf_sv); } /* Skip this filter slot if filter has been deleted */ - if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){ + if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) { DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: skipped (filter deleted)\n", idx)); return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */ } /* Get function pointer hidden within datasv */ - funcp = (filter_t)IoANY(datasv); + funcp = DPTR2FPTR(filter_t, IoANY(datasv)); DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: via function %p (%s)\n", - idx, (void*)funcp, SvPV_nolen(datasv))); + idx, datasv, SvPV_nolen_const(datasv))); /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ /* Return: <0:error, =0:eof, >0:not eof */ @@ -2090,7 +2308,6 @@ S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) } #endif if (PL_rsfp_filters) { - if (!append) SvCUR_set(sv, 0); /* start with empty line */ if (FILTER_READ(0, sv, 0) > 0) @@ -2103,7 +2320,7 @@ S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) } STATIC HV * -S_find_in_my_stash(pTHX_ char *pkgname, I32 len) +S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) { GV *gv; @@ -2121,15 +2338,39 @@ S_find_in_my_stash(pTHX_ char *pkgname, I32 len) if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) { SV *sv; if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) { - pkgname = SvPV_nolen(sv); + pkgname = SvPV_nolen_const(sv); } } return gv_stashpv(pkgname, FALSE); } +STATIC char * +S_tokenize_use(pTHX_ int is_use, char *s) { + if (PL_expect != XSTATE) + yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression", + is_use ? "use" : "no")); + s = skipspace(s); + if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { + s = force_version(s, TRUE); + if (*s == ';' || (s = skipspace(s), *s == ';')) { + PL_nextval[PL_nexttoke].opval = Nullop; + force_next(WORD); + } + else if (*s == 'v') { + s = force_word(s,WORD,FALSE,TRUE,FALSE); + s = force_version(s, FALSE); + } + } + else { + s = force_word(s,WORD,FALSE,TRUE,FALSE); + s = force_version(s, FALSE); + } + yylval.ival = is_use; + return s; +} #ifdef DEBUGGING - static char* exp_name[] = + static const char* const exp_name[] = { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK", "ATTRTERM", "TERMBLOCK", "TERMORDORDOR" }; @@ -2167,7 +2408,7 @@ S_find_in_my_stash(pTHX_ char *pkgname, I32 len) int Perl_yylex(pTHX) { - register char *s; + register char *s = PL_bufptr; register char *d; register I32 tmp; STRLEN len; @@ -2176,9 +2417,18 @@ Perl_yylex(pTHX) bool bof = FALSE; I32 orig_keyword = 0; + DEBUG_T( { + SV* tmp = newSVpvn("", 0); + PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n", + (IV)CopLINE(PL_curcop), + lex_state_names[PL_lex_state], + exp_name[PL_expect], + pv_display(tmp, s, strlen(s), 0, 60)); + SvREFCNT_dec(tmp); + } ); /* check if there's an identifier for us to look at */ if (PL_pending_ident) - return S_pending_ident(aTHX); + return REPORT(S_pending_ident(aTHX)); /* no identifier pending identification */ @@ -2198,11 +2448,7 @@ 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]); + return REPORT(PL_nexttype[PL_nexttoke]); /* interpolated case modifiers like \L \U, including \Q and \E. when we get here, PL_bufptr is at the \ @@ -2214,18 +2460,17 @@ Perl_yylex(pTHX) #endif /* handle \E or end of string */ if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') { - char oldmod; - /* if at a \E */ if (PL_lex_casemods) { - oldmod = PL_lex_casestack[--PL_lex_casemods]; + const char oldmod = PL_lex_casestack[--PL_lex_casemods]; PL_lex_casestack[PL_lex_casemods] = '\0'; - if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) { + if (PL_bufptr != PL_bufend + && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) { PL_bufptr += 2; PL_lex_state = LEX_INTERPCONCAT; } - return ')'; + return REPORT(')'); } if (PL_bufptr != PL_bufend) PL_bufptr += 2; @@ -2234,7 +2479,7 @@ Perl_yylex(pTHX) } else { DEBUG_T({ PerlIO_printf(Perl_debug_log, - "### Saw case modifier at '%s'\n", PL_bufptr); }); + "### Saw case modifier\n"); }); s = PL_bufptr + 1; if (s[1] == '\\' && s[2] == 'E') { PL_bufptr = s + 3; @@ -2244,10 +2489,10 @@ Perl_yylex(pTHX) else { if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */ - if (strchr("LU", *s) && + if ((*s == 'L' || *s == 'U') && (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) { PL_lex_casestack[--PL_lex_casemods] = '\0'; - return ')'; + return REPORT(')'); } if (PL_lex_casemods > 10) Renew(PL_lex_casestack, PL_lex_casemods + 2, char); @@ -2274,20 +2519,24 @@ Perl_yylex(pTHX) if (PL_lex_starts) { s = PL_bufptr; PL_lex_starts = 0; - Aop(OP_CONCAT); + /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ + if (PL_lex_casemods == 1 && PL_lex_inpat) + OPERATOR(','); + else + Aop(OP_CONCAT); } else return yylex(); } case LEX_INTERPPUSH: - return sublex_push(); + return REPORT(sublex_push()); case LEX_INTERPSTART: if (PL_bufptr == PL_bufend) - return sublex_done(); + return REPORT(sublex_done()); DEBUG_T({ PerlIO_printf(Perl_debug_log, - "### Interpolated variable at '%s'\n", PL_bufptr); }); + "### Interpolated variable\n"); }); PL_expect = XTERM; PL_lex_dojoin = (*PL_bufptr == '@'); PL_lex_state = LEX_INTERPNORMAL; @@ -2304,7 +2553,11 @@ Perl_yylex(pTHX) } if (PL_lex_starts++) { s = PL_bufptr; - Aop(OP_CONCAT); + /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ + if (!PL_lex_casemods && PL_lex_inpat) + OPERATOR(','); + else + Aop(OP_CONCAT); } return yylex(); @@ -2319,7 +2572,7 @@ Perl_yylex(pTHX) if (PL_lex_dojoin) { PL_lex_dojoin = FALSE; PL_lex_state = LEX_INTERPCONCAT; - return ')'; + return REPORT(')'); } if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl && SvEVALED(PL_lex_repl)) @@ -2335,7 +2588,7 @@ Perl_yylex(pTHX) Perl_croak(aTHX_ "panic: INTERPCONCAT"); #endif if (PL_bufptr == PL_bufend) - return sublex_done(); + return REPORT(sublex_done()); if (SvIVX(PL_linestr) == '\'') { SV *sv = newSVsv(PL_linestr); @@ -2358,8 +2611,13 @@ Perl_yylex(pTHX) PL_nextval[PL_nexttoke] = yylval; PL_expect = XTERM; force_next(THING); - if (PL_lex_starts++) - Aop(OP_CONCAT); + if (PL_lex_starts++) { + /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ + if (!PL_lex_casemods && PL_lex_inpat) + OPERATOR(','); + else + Aop(OP_CONCAT); + } else { PL_bufptr = s; return yylex(); @@ -2378,10 +2636,6 @@ Perl_yylex(pTHX) s = PL_bufptr; PL_oldoldbufptr = PL_oldbufptr; PL_oldbufptr = s; - DEBUG_T( { - PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n", - exp_name[PL_expect], s); - } ); retry: switch (*s) { @@ -2415,12 +2669,12 @@ Perl_yylex(pTHX) PL_preambled = TRUE; sv_setpv(PL_linestr,incl_perldb()); if (SvCUR(PL_linestr)) - sv_catpv(PL_linestr,";"); + sv_catpvn(PL_linestr,";", 1); if (PL_preambleav){ while(AvFILLp(PL_preambleav) >= 0) { SV *tmpsv = av_shift(PL_preambleav); sv_catsv(PL_linestr, tmpsv); - sv_catpv(PL_linestr, ";"); + sv_catpvn(PL_linestr, ";", 1); sv_free(tmpsv); } sv_free((SV*)PL_preambleav); @@ -2432,39 +2686,45 @@ Perl_yylex(pTHX) sv_catpv(PL_linestr,"chomp;"); if (PL_minus_a) { if (PL_minus_F) { - if (strchr("/'\"", *PL_splitstr) + if ((*PL_splitstr == '/' || *PL_splitstr == '\'' + || *PL_splitstr == '"') && strchr(PL_splitstr + 1, *PL_splitstr)) Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr); else { - char delim; - s = "'~#\200\1'"; /* surely one char is unused...*/ - while (s[1] && strchr(PL_splitstr, *s)) s++; - delim = *s; - Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c", - "q" + (delim == '\''), delim); - for (s = PL_splitstr; *s; s++) { - if (*s == '\\') - sv_catpvn(PL_linestr, "\\", 1); - sv_catpvn(PL_linestr, s, 1); - } - Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim); + /* "q\0${splitstr}\0" is legal perl. Yes, even NUL + bytes can be used as quoting characters. :-) */ + /* The count here deliberately includes the NUL + that terminates the C string constant. This + embeds the opening NUL into the string. */ + const char *splits = PL_splitstr; + sv_catpvn(PL_linestr, "our @F=split(q", 15); + do { + /* Need to \ \s */ + if (*splits == '\\') + sv_catpvn(PL_linestr, splits, 1); + sv_catpvn(PL_linestr, splits, 1); + } while (*splits++); + /* This loop will embed the trailing NUL of + PL_linestr as the last thing it does before + terminating. */ + sv_catpvn(PL_linestr, ");", 2); } } else sv_catpv(PL_linestr,"our @F=split(' ');"); } } - sv_catpv(PL_linestr, "\n"); + sv_catpvn(PL_linestr, "\n", 1); 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); + SV * const sv = NEWSV(85,0); sv_upgrade(sv, SVt_PVMG); sv_setsv(sv,PL_linestr); (void)SvIOK_on(sv); - SvIVX(sv) = 0; + SvIV_set(sv, 0); av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); } goto retry; @@ -2484,8 +2744,8 @@ Perl_yylex(pTHX) 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,";}"); + sv_setpv(PL_linestr,PL_minus_p + ? ";}continue{print;}" : ";}"); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = Nullch; @@ -2494,11 +2754,16 @@ Perl_yylex(pTHX) } PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_last_lop = PL_last_uni = Nullch; - sv_setpv(PL_linestr,""); + sv_setpvn(PL_linestr,"",0); 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)) { + /* If it looks like the start of a BOM or raw UTF-16, + * check if it in fact is. */ + else if (bof && + (*s == 0 || + *(U8*)s == 0xEF || + *(U8*)s >= 0xFE || + s[1] == 0)) { #ifdef PERLIO_IS_STDIO # ifdef __GNU_LIBRARY__ # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */ @@ -2530,7 +2795,7 @@ Perl_yylex(pTHX) if (PL_doextract) { /* Incest with pod. */ if (*s == '=' && strnEQ(s, "=cut", 4)) { - sv_setpv(PL_linestr, ""); + sv_setpvn(PL_linestr, "", 0); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = Nullch; @@ -2541,12 +2806,12 @@ Perl_yylex(pTHX) } while (PL_doextract); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV *sv = NEWSV(85,0); + SV * const sv = NEWSV(85,0); sv_upgrade(sv, SVt_PVMG); sv_setsv(sv,PL_linestr); (void)SvIOK_on(sv); - SvIVX(sv) = 0; + SvIV_set(sv, 0); av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); } PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); @@ -2562,7 +2827,7 @@ Perl_yylex(pTHX) d = s + 2; #ifdef ALTERNATE_SHEBANG else { - static char as[] = ALTERNATE_SHEBANG; + static char const as[] = ALTERNATE_SHEBANG; if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1)) d = s + (sizeof(as) - 1); } @@ -2596,8 +2861,8 @@ Perl_yylex(pTHX) else { STRLEN blen; STRLEN llen; - char *bstart = SvPV(CopFILESV(PL_curcop),blen); - char *lstart = SvPV(x,llen); + const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen); + const char * const lstart = SvPV_const(x,llen); if (llen < blen) { bstart += blen - llen; if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') { @@ -2643,7 +2908,7 @@ Perl_yylex(pTHX) * contains the start of the Perl program. */ if (d && *s != '#') { - char *c = ipath; + const char *c = ipath; while (*c && !strchr("; \t\r\n\f\v#", *c)) c++; if (c < d) @@ -2660,6 +2925,7 @@ Perl_yylex(pTHX) !instr(s,"indir") && instr(PL_origargv[0],"perl")) { + dVAR; char **newargv; *ipathend = '\0'; @@ -2667,7 +2933,7 @@ Perl_yylex(pTHX) while (s < PL_bufend && isSPACE(*s)) s++; if (s < PL_bufend) { - Newz(899,newargv,PL_origargc+3,char*); + Newxz(newargv,PL_origargc+3,char*); newargv[1] = s; while (s < PL_bufend && !isSPACE(*s)) s++; @@ -2684,18 +2950,18 @@ Perl_yylex(pTHX) } #endif if (d) { - U32 oldpdb = PL_perldb; - bool oldn = PL_minus_n; - bool oldp = PL_minus_p; + const U32 oldpdb = PL_perldb; + const bool oldn = PL_minus_n; + const bool oldp = PL_minus_p; while (*d && !isSPACE(*d)) d++; while (SPACE_OR_TAB(*d)) d++; if (*d++ == '-') { - bool switches_done = PL_doswitches; + const bool switches_done = PL_doswitches; do { - if (*d == 'M' || *d == 'm') { - char *m = d; + if (*d == 'M' || *d == 'm' || *d == 'C') { + const char * const m = d; while (*d && !isSPACE(*d)) d++; Perl_croak(aTHX_ "Too late for \"-%.*s\" option", (int)(d - m), m); @@ -2715,7 +2981,7 @@ Perl_yylex(pTHX) /* if we have already added "LINE: while (<>) {", we must not do it again */ { - sv_setpv(PL_linestr, ""); + sv_setpvn(PL_linestr, "", 0); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = Nullch; @@ -2794,8 +3060,8 @@ 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); + DEBUG_T( { S_printbuf(aTHX_ + "### Saw unary minus before =>, forcing word %s\n", s); } ); OPERATOR('-'); /* unary minus */ } @@ -2849,7 +3115,7 @@ Perl_yylex(pTHX) * subroutine call (or a -bareword), then. */ DEBUG_T( { PerlIO_printf(Perl_debug_log, "### '-%c' looked like a file test but was not\n", - tmp); + (int) tmp); } ); s = --PL_bufptr; } @@ -2987,7 +3253,7 @@ Perl_yylex(pTHX) yyerror("Unterminated attribute parameter in attribute list"); if (attrs) op_free(attrs); - return 0; /* EOF indicator */ + return REPORT(0); /* EOF indicator */ } } if (PL_lex_stuff) { @@ -3006,7 +3272,7 @@ Perl_yylex(pTHX) #else ; /* skip to avoid loading attributes.pm */ #endif - else + else Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables"); } @@ -3043,7 +3309,7 @@ Perl_yylex(pTHX) } tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */ if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) { - char q = ((*s == '\'') ? '"' : '\''); + const char q = ((*s == '\'') ? '"' : '\''); /* If here for an expression, and parsed no attrs, back off. */ if (tmp == '=' && !attrs) { s = PL_bufptr; @@ -3135,7 +3401,7 @@ Perl_yylex(pTHX) while (d < PL_bufend && SPACE_OR_TAB(*d)) d++; if (*d == '}') { - char minus = (PL_tokenbuf[0] == '-'); + const char minus = (PL_tokenbuf[0] == '-'); s = force_word(s + minus, WORD, FALSE, TRUE, FALSE); if (minus) force_next('-'); @@ -3153,7 +3419,7 @@ Perl_yylex(pTHX) PL_expect = XSTATE; break; default: { - char *t; + const char *t; if (PL_oldoldbufptr == PL_last_lop) PL_lex_brackstack[PL_lex_brackets++] = XTERM; else @@ -3176,7 +3442,7 @@ Perl_yylex(pTHX) * eval"") we have to resolve the ambiguity. This code * covers the case where the first term in the curlies is a * quoted string. Most other cases need to be explicitly - * disambiguated by prepending a `+' before the opening + * disambiguated by prepending a "+" before the opening * curly in order to force resolution as an anon hash. * * XXX should probably propagate the outer expectation @@ -3199,7 +3465,7 @@ Perl_yylex(pTHX) && !isALNUM(*t)))) { /* skip q//-like construct */ - char *tmps; + const char *tmps; char open, close, term; I32 brackets = 1; @@ -3300,8 +3566,8 @@ Perl_yylex(pTHX) AOPERATOR(ANDAND); s--; if (PL_expect == XOPERATOR) { - if (ckWARN(WARN_SEMICOLON) - && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart) + if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON) + && isIDFIRST_lazy_if(s,UTF)) { CopLINE_dec(PL_curcop); Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi); @@ -3336,7 +3602,7 @@ Perl_yylex(pTHX) OPERATOR(','); if (tmp == '~') PMop(OP_MATCH); - if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp)) + if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) && strchr("+-*/%.^&|<",tmp)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp); s--; if (PL_expect == XSTATE && isALPHA(tmp) && @@ -3365,7 +3631,7 @@ Perl_yylex(pTHX) goto retry; } if (PL_lex_brackets < PL_lex_formbrack) { - char *t; + const char *t; #ifdef PERL_STRICT_CR for (t = s; SPACE_OR_TAB(*t); t++) ; #else @@ -3383,14 +3649,18 @@ Perl_yylex(pTHX) s++; tmp = *s++; if (tmp == '=') { - /* was this !=~ where !~ was meant? */ + /* was this !=~ where !~ was meant? + * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */ + if (*s == '~' && ckWARN(WARN_SYNTAX)) { - char *t = s+1; + const char *t = s+1; while (t < PL_bufend && isSPACE(*t)) ++t; - if (*t == '/' || (*t == 'm' && !isALNUM(t[1])) || *t == '?') + if (*t == '/' || *t == '?' || + ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) || + (*t == 't' && t[1] == 'r' && !isALNUM(t[2]))) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "!=~ should be !~"); } @@ -3440,7 +3710,7 @@ Perl_yylex(pTHX) if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; depcom(); - return ','; /* grandfather non-comma-format format */ + return REPORT(','); /* grandfather non-comma-format format */ } } @@ -3482,10 +3752,10 @@ Perl_yylex(pTHX) s = skipspace(s); if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { - char *t; if (*s == '[') { PL_tokenbuf[0] = '@'; if (ckWARN(WARN_SYNTAX)) { + char *t; for(t = s + 1; isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$'; t++) ; @@ -3500,14 +3770,15 @@ Perl_yylex(pTHX) } } else if (*s == '{') { + char *t; PL_tokenbuf[0] = '%'; - if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") && - (t = strchr(s, '}')) && (t = strchr(t, '='))) + if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX) + && (t = strchr(s, '}')) && (t = strchr(t, '='))) { char tmpbuf[sizeof PL_tokenbuf]; - STRLEN len; for (t++; isSPACE(*t); t++) ; if (isIDFIRST_lazy_if(t,UTF)) { + STRLEN len; t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len); for (; isSPACE(*t); t++) ; if (*t == ';' && get_cv(tmpbuf, FALSE)) @@ -3520,7 +3791,7 @@ Perl_yylex(pTHX) PL_expect = XOPERATOR; if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) { - bool islop = (PL_last_lop == PL_oldoldbufptr); + const bool islop = (PL_last_lop == PL_oldoldbufptr); if (!islop || PL_last_lop_op == OP_GREPSTART) PL_expect = XOPERATOR; else if (strchr("$@\"'`q", *s)) @@ -3555,7 +3826,8 @@ Perl_yylex(pTHX) PL_expect = XTERM; /* e.g. print $fh 3 */ else if (*s == '.' && isDIGIT(s[1])) PL_expect = XTERM; /* e.g. print $fh .3 */ - else if (strchr("?-+", *s) && !isSPACE(s[1]) && s[1] != '=') + else if ((*s == '?' || *s == '-' || *s == '+') + && !isSPACE(s[1]) && s[1] != '=') PL_expect = XTERM; /* e.g. print $fh -1 */ else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/') PL_expect = XTERM; /* e.g. print $fh /.../ @@ -3581,9 +3853,9 @@ Perl_yylex(pTHX) PL_tokenbuf[0] = '%'; /* Warn about @ where they meant $. */ - if (ckWARN(WARN_SYNTAX)) { - if (*s == '[' || *s == '{') { - char *t = s + 1; + if (*s == '[' || *s == '{') { + if (ckWARN(WARN_SYNTAX)) { + const char *t = s + 1; while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t))) t++; if (*t == '}' || *t == ']') { @@ -3667,23 +3939,19 @@ 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, - "### Saw number in '%s'\n", s); - } ); + DEBUG_T( { S_printbuf(aTHX_ "### 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); - } ); + DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } ); if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; depcom(); - return ','; /* grandfather non-comma-format format */ + return REPORT(','); /* grandfather non-comma-format format */ } else no_op("String",s); @@ -3695,14 +3963,12 @@ Perl_yylex(pTHX) case '"': s = scan_str(s,FALSE,FALSE); - DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### Saw string before '%s'\n", s); - } ); + DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } ); if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; depcom(); - return ','; /* grandfather non-comma-format format */ + return REPORT(','); /* grandfather non-comma-format format */ } else no_op("String",s); @@ -3710,6 +3976,8 @@ Perl_yylex(pTHX) if (!s) missingterm((char*)0); yylval.ival = OP_CONST; + /* FIXME. I think that this can be const if char *d is replaced by + more localised variables. */ for (d = SvPV(PL_lex_stuff, len); len; len--, d++) { if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) { yylval.ival = OP_STRINGIFY; @@ -3720,9 +3988,7 @@ Perl_yylex(pTHX) case '`': s = scan_str(s,FALSE,FALSE); - DEBUG_T( { PerlIO_printf(Perl_debug_log, - "### Saw backtick string before '%s'\n", s); - } ); + DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } ); if (PL_expect == XOPERATOR) no_op("Backticks",s); if (!s) @@ -3733,7 +3999,7 @@ Perl_yylex(pTHX) case '\\': s++; - if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s)) + if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression", *s, *s); if (PL_expect == XOPERATOR) @@ -3742,9 +4008,7 @@ Perl_yylex(pTHX) case 'v': if (isDIGIT(s[1]) && PL_expect != XOPERATOR) { - char *start = s; - start++; - start++; + char *start = s + 2; while (isDIGIT(*start) || *start == '_') start++; if (*start == '.' && isDIGIT(start[1])) { @@ -3755,7 +4019,7 @@ Perl_yylex(pTHX) else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE || PL_expect == XTERMORDORDOR)) { - char c = *start; + const char c = *start; GV *gv; *start = '\0'; gv = gv_fetchpv(s, FALSE, SVt_PVCV); @@ -3839,10 +4103,10 @@ Perl_yylex(pTHX) /* Is this a word before a => operator? */ if (*d == '=' && d[1] == '>') { CLINE; - yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0)); + yylval.opval + = (OP*)newSVOP(OP_CONST, 0, + S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len)); yylval.opval->op_private = OPpCONST_BARE; - if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len)) - SvUTF8_on(((SVOP*)yylval.opval)->op_sv); TERM(WORD); } @@ -3878,6 +4142,16 @@ Perl_yylex(pTHX) { tmp = 0; /* any sub overrides "weak" keyword */ } + else if (gv && !gvp + && tmp == -KEY_err + && GvCVu(gv) + && PL_expect != XOPERATOR + && PL_expect != XTERMORDORDOR) + { + /* any sub overrides the "err" keyword, except when really an + * operator is expected */ + tmp = 0; + } else { /* no override */ tmp = -tmp; if (tmp == KEY_dump && ckWARN(WARN_MISC)) { @@ -3886,8 +4160,8 @@ Perl_yylex(pTHX) } gv = Nullgv; gvp = 0; - if (ckWARN(WARN_AMBIGUOUS) && hgv - && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */ + if (hgv && tmp != KEY_x && tmp != KEY_CORE + && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */ Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous call resolved as CORE::%s(), %s", GvENAME(hgv), "qualify as such or use &"); @@ -3901,7 +4175,7 @@ Perl_yylex(pTHX) just_a_word: { SV *sv; int pkgname = 0; - char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); + const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); /* Get the rest if it looks like a package qualifier */ @@ -3954,8 +4228,12 @@ Perl_yylex(pTHX) sv = newSVpvn("CORE::GLOBAL::",14); sv_catpv(sv,PL_tokenbuf); } - else - sv = newSVpv(PL_tokenbuf,0); + else { + /* If len is 0, newSVpv does strlen(), which is correct. + If len is non-zero, then it will be the true length, + and so the scalar will be created correctly. */ + sv = newSVpv(PL_tokenbuf,len); + } /* Presume this is going to be a bareword of some sort. */ @@ -3964,7 +4242,7 @@ Perl_yylex(pTHX) yylval.opval->op_private = OPpCONST_BARE; /* UTF-8 package name? */ if (UTF && !IN_BYTES && - is_utf8_string((U8*)SvPVX(sv), SvCUR(sv))) + is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv))) SvUTF8_on(sv); /* And if "Foo::", then that's what it certainly is. */ @@ -3990,7 +4268,7 @@ Perl_yylex(pTHX) /* Two barewords in a row may indicate method call. */ if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv))) - return tmp; + return REPORT(tmp); /* If not a declared subroutine, it's an indirect object. */ /* (But it's an indir obj regardless for sort.) */ @@ -4047,7 +4325,7 @@ Perl_yylex(pTHX) if (!orig_keyword && (isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv))) - return tmp; + return REPORT(tmp); /* Not a method, so call it a subroutine (if defined) */ @@ -4076,15 +4354,15 @@ Perl_yylex(pTHX) /* Is there a prototype? */ if (SvPOK(cv)) { STRLEN len; - char *proto = SvPV((SV*)cv, len); + const char *proto = SvPV_const((SV*)cv, len); if (!len) TERM(FUNC0SUB); - if (strEQ(proto, "$")) + if (*proto == '$' && proto[1] == '\0') OPERATOR(UNIOPSUB); while (*proto == ';') proto++; if (*proto == '&' && *s == '{') { - sv_setpv(PL_subname, PL_curstash ? + sv_setpv(PL_subname, PL_curstash ? "__ANON__" : "__ANON__::__ANON__"); PREBLOCK(LSTOPSUB); } @@ -4101,8 +4379,8 @@ Perl_yylex(pTHX) yylval.opval->op_private |= OPpCONST_STRICT; else { bareword: - if (ckWARN(WARN_RESERVED)) { - if (lastchar != '-') { + if (lastchar != '-') { + if (ckWARN(WARN_RESERVED)) { for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ; if (!*d && !gv_stashpv(PL_tokenbuf,FALSE)) Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved, @@ -4112,7 +4390,8 @@ Perl_yylex(pTHX) } safe_bareword: - if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) { + if ((lastchar == '*' || lastchar == '%' || lastchar == '&') + && ckWARN_d(WARN_AMBIGUOUS)) { Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Operator or semicolon missing before %c%s", lastchar, PL_tokenbuf); @@ -4136,19 +4415,17 @@ Perl_yylex(pTHX) case KEY___PACKAGE__: yylval.opval = (OP*)newSVOP(OP_CONST, 0, (PL_curstash - ? newSVsv(PL_curstname) + ? newSVhek(HvNAME_HEK(PL_curstash)) : &PL_sv_undef)); TERM(THING); case KEY___DATA__: case KEY___END__: { GV *gv; - - /*SUPPRESS 560*/ if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) { - char *pname = "main"; + const char *pname = "main"; if (PL_tokenbuf[2] == 'D') - pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash); + pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash); gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO); GvMULTI_on(gv); if (!GvIO(gv)) @@ -4156,7 +4433,7 @@ Perl_yylex(pTHX) IoIFP(GvIOp(gv)) = PL_rsfp; #if defined(HAS_FCNTL) && defined(F_SETFD) { - int fd = PerlIO_fileno(PL_rsfp); + const int fd = PerlIO_fileno(PL_rsfp); fcntl(fd,F_SETFD,fd >= 3); } #endif @@ -4213,7 +4490,7 @@ Perl_yylex(pTHX) SPAGAIN; name = POPs; PUTBACK; - PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, + PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, Perl_form(aTHX_ ":encoding(%"SVf")", name)); FREETMPS; @@ -4247,6 +4524,9 @@ Perl_yylex(pTHX) Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf); if (tmp < 0) tmp = -tmp; + else if (tmp == KEY_require || tmp == KEY_do) + /* that's a way to remember we saw "CORE::" */ + orig_keyword = tmp; goto reserved_word; } goto just_a_word; @@ -4330,6 +4610,12 @@ Perl_yylex(pTHX) PRETERMBLOCK(DO); if (*s != '\'') s = force_word(s,WORD,TRUE,TRUE,FALSE); + if (orig_keyword == KEY_do) { + orig_keyword = 0; + yylval.ival = 1; + } + else + yylval.ival = 0; OPERATOR(DO); case KEY_die: @@ -4659,11 +4945,7 @@ Perl_yylex(pTHX) Eop(OP_SNE); case KEY_no: - if (PL_expect != XSTATE) - yyerror("\"no\" not allowed in expression"); - s = force_word(s,WORD,FALSE,TRUE,FALSE); - s = force_version(s, FALSE); - yylval.ival = 0; + s = tokenize_use(0, s); OPERATOR(USE); case KEY_not: @@ -4675,10 +4957,10 @@ Perl_yylex(pTHX) case KEY_open: s = skipspace(s); if (isIDFIRST_lazy_if(s,UTF)) { - char *t; + const char *t; for (d = s; isALNUM_lazy_if(d,UTF); d++) ; - t = skipspace(d); - if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE) + for (t=d; *t && isSPACE(*t); t++) ; + if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE) /* [perl #16184] */ && !(t[0] == '=' && t[1] == '>') ) { @@ -4746,6 +5028,7 @@ Perl_yylex(pTHX) s = scan_str(s,FALSE,FALSE); if (!s) missingterm((char*)0); + PL_expect = XOPERATOR; force_next(')'); if (SvCUR(PL_lex_stuff)) { OP *words = Nullop; @@ -4755,7 +5038,7 @@ Perl_yylex(pTHX) SV *sv; for (; isSPACE(*d) && len; --len, ++d) ; if (len) { - char *b = d; + const char *b = d; if (!warned && ckWARN(WARN_QW)) { for (; !isSPACE(*d) && len; --len, ++d) { if (*d == ',') { @@ -4798,7 +5081,7 @@ Perl_yylex(pTHX) missingterm((char*)0); yylval.ival = OP_STRINGIFY; if (SvIVX(PL_lex_stuff) == '\'') - SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */ + SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */ TERM(sublex_start()); case KEY_qr: @@ -4831,7 +5114,18 @@ Perl_yylex(pTHX) else if (*s == '<') yyerror("<> should be quotes"); } - UNI(OP_REQUIRE); + if (orig_keyword == KEY_require) { + orig_keyword = 0; + yylval.ival = 1; + } + else + yylval.ival = 0; + PL_expect = XTERM; + PL_bufptr = s; + PL_last_uni = PL_oldbufptr; + PL_last_lop_op = OP_REQUIRE; + s = skipspace(s); + return REPORT( (int)REQUIRE ); case KEY_reset: UNI(OP_RESET); @@ -5013,7 +5307,7 @@ Perl_yylex(pTHX) SSize_t tboffset = 0; expectation attrful; bool have_name, have_proto, bad_proto; - int key = tmp; + const int key = tmp; s = skipspace(s); @@ -5040,7 +5334,7 @@ Perl_yylex(pTHX) Perl_croak(aTHX_ "Missing name in \"my sub\""); PL_expect = XTERMBLOCK; attrful = XATTRTERM; - sv_setpv(PL_subname,"?"); + sv_setpvn(PL_subname,"?",1); have_name = FALSE; } @@ -5076,7 +5370,7 @@ Perl_yylex(pTHX) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Illegal character in prototype for %"SVf" : %s", PL_subname, d); - SvCUR(PL_lex_stuff) = tmp; + SvCUR_set(PL_lex_stuff, tmp); have_proto = TRUE; s = skipspace(s); @@ -5086,8 +5380,12 @@ Perl_yylex(pTHX) if (*s == ':' && s[1] != ':') PL_expect = attrful; - else if (!have_name && *s != '{' && key == KEY_sub) - Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine"); + else if (*s != '{' && key == KEY_sub) { + if (!have_name) + Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine"); + else if (*s != ';') + Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname); + } if (have_proto) { PL_nextval[PL_nexttoke].opval = @@ -5190,25 +5488,7 @@ Perl_yylex(pTHX) LOP(OP_UNSHIFT,XTERM); case KEY_use: - if (PL_expect != XSTATE) - yyerror("\"use\" not allowed in expression"); - s = skipspace(s); - if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { - s = force_version(s, TRUE); - if (*s == ';' || (s = skipspace(s), *s == ';')) { - PL_nextval[PL_nexttoke].opval = Nullop; - force_next(WORD); - } - else if (*s == 'v') { - s = force_word(s,WORD,FALSE,TRUE,FALSE); - s = force_version(s, FALSE); - } - } - else { - s = force_word(s,WORD,FALSE,TRUE,FALSE); - s = force_version(s, FALSE); - } - yylval.ival = 1; + s = tokenize_use(1, s); OPERATOR(USE); case KEY_values: @@ -5277,7 +5557,7 @@ S_pending_ident(pTHX) PL_pending_ident = 0; DEBUG_T({ PerlIO_printf(Perl_debug_log, - "### Tokener saw identifier '%s'\n", PL_tokenbuf); }); + "### Pending 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 @@ -5322,12 +5602,14 @@ S_pending_ident(pTHX) /* might be an "our" variable" */ if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) { /* build ops for a bareword */ - SV *sym = newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)), 0); + HV * const stash = PAD_COMPNAME_OURSTASH(tmp); + HEK * const stashname = HvNAME_HEK(stash); + SV * const sym = newSVhek(stashname); sv_catpvn(sym, "::", 2); sv_catpv(sym, PL_tokenbuf+1); yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym); yylval.opval->op_private = OPpCONST_ENTERED; - gv_fetchpv(SvPVX(sym), + gv_fetchsv(sym, (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADDMULTI @@ -5388,616 +5670,3312 @@ S_pending_ident(pTHX) return WORD; } +/* + * The following code was generated by perl_keyword.pl. + */ + I32 -Perl_keyword(pTHX_ register char *d, I32 len) +Perl_keyword (pTHX_ const char *name, I32 len) { - switch (*d) { - case '_': - if (d[1] == '_') { - if (strEQ(d,"__FILE__")) return -KEY___FILE__; - if (strEQ(d,"__LINE__")) return -KEY___LINE__; - if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__; - if (strEQ(d,"__DATA__")) return KEY___DATA__; - if (strEQ(d,"__END__")) return KEY___END__; - } - break; - case 'A': - if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD; - break; - case 'a': - switch (len) { - case 3: - if (strEQ(d,"and")) return -KEY_and; - if (strEQ(d,"abs")) return -KEY_abs; - break; - case 5: - if (strEQ(d,"alarm")) return -KEY_alarm; - if (strEQ(d,"atan2")) return -KEY_atan2; - break; - case 6: - if (strEQ(d,"accept")) return -KEY_accept; - break; - } - break; - case 'B': - if (strEQ(d,"BEGIN")) return KEY_BEGIN; - break; - case 'b': - if (strEQ(d,"bless")) return -KEY_bless; - if (strEQ(d,"bind")) return -KEY_bind; - if (strEQ(d,"binmode")) return -KEY_binmode; - break; - case 'C': - if (strEQ(d,"CORE")) return -KEY_CORE; - if (strEQ(d,"CHECK")) return KEY_CHECK; - break; - case 'c': - switch (len) { - case 3: - if (strEQ(d,"cmp")) return -KEY_cmp; - if (strEQ(d,"chr")) return -KEY_chr; - if (strEQ(d,"cos")) return -KEY_cos; - break; - case 4: - if (strEQ(d,"chop")) return -KEY_chop; - break; - case 5: - if (strEQ(d,"close")) return -KEY_close; - if (strEQ(d,"chdir")) return -KEY_chdir; - if (strEQ(d,"chomp")) return -KEY_chomp; - if (strEQ(d,"chmod")) return -KEY_chmod; - if (strEQ(d,"chown")) return -KEY_chown; - if (strEQ(d,"crypt")) return -KEY_crypt; - break; - case 6: - if (strEQ(d,"chroot")) return -KEY_chroot; - if (strEQ(d,"caller")) return -KEY_caller; - break; - case 7: - if (strEQ(d,"connect")) return -KEY_connect; - break; - case 8: - if (strEQ(d,"closedir")) return -KEY_closedir; - if (strEQ(d,"continue")) return -KEY_continue; - break; - } - break; - case 'D': - if (strEQ(d,"DESTROY")) return KEY_DESTROY; - break; - case 'd': - switch (len) { - case 2: - if (strEQ(d,"do")) return KEY_do; - break; - case 3: - if (strEQ(d,"die")) return -KEY_die; - break; - case 4: - if (strEQ(d,"dump")) return -KEY_dump; - break; - case 6: - if (strEQ(d,"delete")) return KEY_delete; - break; - case 7: - if (strEQ(d,"defined")) return KEY_defined; - if (strEQ(d,"dbmopen")) return -KEY_dbmopen; - break; - case 8: - if (strEQ(d,"dbmclose")) return -KEY_dbmclose; - break; - } - break; - case 'E': - if (strEQ(d,"END")) return KEY_END; - break; - case 'e': - switch (len) { - case 2: - if (strEQ(d,"eq")) return -KEY_eq; - break; - case 3: - if (strEQ(d,"eof")) return -KEY_eof; - if (strEQ(d,"err")) return -KEY_err; - if (strEQ(d,"exp")) return -KEY_exp; - break; - case 4: - if (strEQ(d,"else")) return KEY_else; - 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; - break; - case 5: - if (strEQ(d,"elsif")) return KEY_elsif; - break; - case 6: - if (strEQ(d,"exists")) return KEY_exists; - if (strEQ(d,"elseif") && ckWARN_d(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "elseif should be elsif"); - break; - case 8: - if (strEQ(d,"endgrent")) return -KEY_endgrent; - if (strEQ(d,"endpwent")) return -KEY_endpwent; - break; - case 9: - if (strEQ(d,"endnetent")) return -KEY_endnetent; - break; - case 10: - if (strEQ(d,"endhostent")) return -KEY_endhostent; - if (strEQ(d,"endservent")) return -KEY_endservent; - break; - case 11: - if (strEQ(d,"endprotoent")) return -KEY_endprotoent; - break; - } - break; - case 'f': - switch (len) { - case 3: - if (strEQ(d,"for")) return KEY_for; - break; - case 4: - if (strEQ(d,"fork")) return -KEY_fork; - break; - case 5: - if (strEQ(d,"fcntl")) return -KEY_fcntl; - if (strEQ(d,"flock")) return -KEY_flock; - break; - case 6: - if (strEQ(d,"format")) return KEY_format; - if (strEQ(d,"fileno")) return -KEY_fileno; - break; - case 7: - if (strEQ(d,"foreach")) return KEY_foreach; - break; - case 8: - if (strEQ(d,"formline")) return -KEY_formline; - break; - } - break; - case 'g': - if (strnEQ(d,"get",3)) { - d += 3; - if (*d == 'p') { - switch (len) { - case 7: - if (strEQ(d,"ppid")) return -KEY_getppid; - if (strEQ(d,"pgrp")) return -KEY_getpgrp; - break; - case 8: - if (strEQ(d,"pwent")) return -KEY_getpwent; - if (strEQ(d,"pwnam")) return -KEY_getpwnam; - if (strEQ(d,"pwuid")) return -KEY_getpwuid; - break; - case 11: - if (strEQ(d,"peername")) return -KEY_getpeername; - if (strEQ(d,"protoent")) return -KEY_getprotoent; - if (strEQ(d,"priority")) return -KEY_getpriority; - break; - case 14: - if (strEQ(d,"protobyname")) return -KEY_getprotobyname; - break; - case 16: - if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber; - break; - } - } - else if (*d == 'h') { - if (strEQ(d,"hostbyname")) return -KEY_gethostbyname; - if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr; - if (strEQ(d,"hostent")) return -KEY_gethostent; - } - else if (*d == 'n') { - if (strEQ(d,"netbyname")) return -KEY_getnetbyname; - if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr; - if (strEQ(d,"netent")) return -KEY_getnetent; - } - else if (*d == 's') { - if (strEQ(d,"servbyname")) return -KEY_getservbyname; - if (strEQ(d,"servbyport")) return -KEY_getservbyport; - if (strEQ(d,"servent")) return -KEY_getservent; - if (strEQ(d,"sockname")) return -KEY_getsockname; - if (strEQ(d,"sockopt")) return -KEY_getsockopt; - } - else if (*d == 'g') { - if (strEQ(d,"grent")) return -KEY_getgrent; - if (strEQ(d,"grnam")) return -KEY_getgrnam; - if (strEQ(d,"grgid")) return -KEY_getgrgid; - } - else if (*d == 'l') { - if (strEQ(d,"login")) return -KEY_getlogin; - } - else if (strEQ(d,"c")) return -KEY_getc; - break; - } - switch (len) { - case 2: - if (strEQ(d,"gt")) return -KEY_gt; - if (strEQ(d,"ge")) return -KEY_ge; - break; - case 4: - if (strEQ(d,"grep")) return KEY_grep; - if (strEQ(d,"goto")) return KEY_goto; - if (strEQ(d,"glob")) return KEY_glob; - break; - case 6: - if (strEQ(d,"gmtime")) return -KEY_gmtime; - break; - } - break; - case 'h': - if (strEQ(d,"hex")) return -KEY_hex; - break; - case 'I': - if (strEQ(d,"INIT")) return KEY_INIT; - break; - case 'i': - switch (len) { - case 2: - if (strEQ(d,"if")) return KEY_if; - break; - case 3: - if (strEQ(d,"int")) return -KEY_int; - break; - case 5: - if (strEQ(d,"index")) return -KEY_index; - if (strEQ(d,"ioctl")) return -KEY_ioctl; - break; - } - break; - case 'j': - if (strEQ(d,"join")) return -KEY_join; - break; - case 'k': - if (len == 4) { - if (strEQ(d,"keys")) return -KEY_keys; - if (strEQ(d,"kill")) return -KEY_kill; - } - break; - case 'l': - switch (len) { - case 2: - if (strEQ(d,"lt")) return -KEY_lt; - if (strEQ(d,"le")) return -KEY_le; - if (strEQ(d,"lc")) return -KEY_lc; - break; - case 3: - if (strEQ(d,"log")) return -KEY_log; - break; - case 4: - if (strEQ(d,"last")) return KEY_last; - if (strEQ(d,"link")) return -KEY_link; - if (strEQ(d,"lock")) return -KEY_lock; - break; - case 5: - if (strEQ(d,"local")) return KEY_local; - if (strEQ(d,"lstat")) return -KEY_lstat; - break; - case 6: - if (strEQ(d,"length")) return -KEY_length; - if (strEQ(d,"listen")) return -KEY_listen; - break; - case 7: - if (strEQ(d,"lcfirst")) return -KEY_lcfirst; - break; - case 9: - if (strEQ(d,"localtime")) return -KEY_localtime; - break; - } - break; - case 'm': - switch (len) { - case 1: return KEY_m; - case 2: - if (strEQ(d,"my")) return KEY_my; - break; - case 3: - if (strEQ(d,"map")) return KEY_map; - break; - case 5: - if (strEQ(d,"mkdir")) return -KEY_mkdir; - break; - case 6: - if (strEQ(d,"msgctl")) return -KEY_msgctl; - if (strEQ(d,"msgget")) return -KEY_msgget; - if (strEQ(d,"msgrcv")) return -KEY_msgrcv; - if (strEQ(d,"msgsnd")) return -KEY_msgsnd; - break; - } - break; - case 'n': - if (strEQ(d,"next")) return KEY_next; - if (strEQ(d,"ne")) return -KEY_ne; - if (strEQ(d,"not")) return -KEY_not; - if (strEQ(d,"no")) return KEY_no; - break; - case 'o': - switch (len) { - case 2: - if (strEQ(d,"or")) return -KEY_or; - break; - case 3: - if (strEQ(d,"ord")) return -KEY_ord; - if (strEQ(d,"oct")) return -KEY_oct; - if (strEQ(d,"our")) return KEY_our; - break; - case 4: - if (strEQ(d,"open")) return -KEY_open; - break; - case 7: - if (strEQ(d,"opendir")) return -KEY_opendir; - break; - } - break; - case 'p': - switch (len) { - case 3: - 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,"pack")) return -KEY_pack; - if (strEQ(d,"pipe")) return -KEY_pipe; - break; - case 5: - if (strEQ(d,"print")) return KEY_print; - break; - case 6: - if (strEQ(d,"printf")) return KEY_printf; - break; - case 7: - if (strEQ(d,"package")) return KEY_package; - break; - case 9: - if (strEQ(d,"prototype")) return KEY_prototype; - } - break; - case 'q': - if (len <= 2) { - if (strEQ(d,"q")) return KEY_q; - if (strEQ(d,"qr")) return KEY_qr; - if (strEQ(d,"qq")) return KEY_qq; - if (strEQ(d,"qw")) return KEY_qw; - if (strEQ(d,"qx")) return KEY_qx; - } - else if (strEQ(d,"quotemeta")) return -KEY_quotemeta; - break; - case 'r': - switch (len) { - case 3: - if (strEQ(d,"ref")) return -KEY_ref; - break; - case 4: - if (strEQ(d,"read")) return -KEY_read; - if (strEQ(d,"rand")) return -KEY_rand; - if (strEQ(d,"recv")) return -KEY_recv; - if (strEQ(d,"redo")) return KEY_redo; - break; - case 5: - if (strEQ(d,"rmdir")) return -KEY_rmdir; - if (strEQ(d,"reset")) return -KEY_reset; - break; - case 6: - if (strEQ(d,"return")) return KEY_return; - if (strEQ(d,"rename")) return -KEY_rename; - if (strEQ(d,"rindex")) return -KEY_rindex; - break; - case 7: - if (strEQ(d,"require")) return KEY_require; - if (strEQ(d,"reverse")) return -KEY_reverse; - if (strEQ(d,"readdir")) return -KEY_readdir; - break; - case 8: - if (strEQ(d,"readlink")) return -KEY_readlink; - if (strEQ(d,"readline")) return -KEY_readline; - if (strEQ(d,"readpipe")) return -KEY_readpipe; - break; - case 9: - if (strEQ(d,"rewinddir")) return -KEY_rewinddir; - break; - } - break; - case 's': - switch (d[1]) { - case 0: return KEY_s; - case 'c': - if (strEQ(d,"scalar")) return KEY_scalar; - break; - case 'e': - switch (len) { - case 4: - if (strEQ(d,"seek")) return -KEY_seek; - if (strEQ(d,"send")) return -KEY_send; - break; - case 5: - if (strEQ(d,"semop")) return -KEY_semop; - break; - case 6: - if (strEQ(d,"select")) return -KEY_select; - if (strEQ(d,"semctl")) return -KEY_semctl; - if (strEQ(d,"semget")) return -KEY_semget; - break; - case 7: - if (strEQ(d,"setpgrp")) return -KEY_setpgrp; - if (strEQ(d,"seekdir")) return -KEY_seekdir; - break; - case 8: - if (strEQ(d,"setpwent")) return -KEY_setpwent; - if (strEQ(d,"setgrent")) return -KEY_setgrent; - break; - case 9: - if (strEQ(d,"setnetent")) return -KEY_setnetent; - break; - case 10: - if (strEQ(d,"setsockopt")) return -KEY_setsockopt; - if (strEQ(d,"sethostent")) return -KEY_sethostent; - if (strEQ(d,"setservent")) return -KEY_setservent; - break; - case 11: - if (strEQ(d,"setpriority")) return -KEY_setpriority; - if (strEQ(d,"setprotoent")) return -KEY_setprotoent; - break; - } - break; - case 'h': - switch (len) { - case 5: - if (strEQ(d,"shift")) return -KEY_shift; - break; - case 6: - if (strEQ(d,"shmctl")) return -KEY_shmctl; - if (strEQ(d,"shmget")) return -KEY_shmget; - break; - case 7: - if (strEQ(d,"shmread")) return -KEY_shmread; - break; - case 8: - if (strEQ(d,"shmwrite")) return -KEY_shmwrite; - if (strEQ(d,"shutdown")) return -KEY_shutdown; - break; - } - break; - case 'i': - if (strEQ(d,"sin")) return -KEY_sin; - break; - case 'l': - if (strEQ(d,"sleep")) return -KEY_sleep; - break; - case 'o': - if (strEQ(d,"sort")) return KEY_sort; - if (strEQ(d,"socket")) return -KEY_socket; - if (strEQ(d,"socketpair")) return -KEY_socketpair; - break; - case 'p': - if (strEQ(d,"split")) return KEY_split; - if (strEQ(d,"sprintf")) return -KEY_sprintf; - if (strEQ(d,"splice")) return -KEY_splice; - break; - case 'q': - if (strEQ(d,"sqrt")) return -KEY_sqrt; - break; - case 'r': - if (strEQ(d,"srand")) return -KEY_srand; - break; - case 't': - if (strEQ(d,"stat")) return -KEY_stat; - if (strEQ(d,"study")) return KEY_study; - break; - case 'u': - if (strEQ(d,"substr")) return -KEY_substr; - if (strEQ(d,"sub")) return KEY_sub; - break; - case 'y': - switch (len) { - case 6: - if (strEQ(d,"system")) return -KEY_system; - break; - case 7: - if (strEQ(d,"symlink")) return -KEY_symlink; - if (strEQ(d,"syscall")) return -KEY_syscall; - if (strEQ(d,"sysopen")) return -KEY_sysopen; - if (strEQ(d,"sysread")) return -KEY_sysread; - if (strEQ(d,"sysseek")) return -KEY_sysseek; - break; - case 8: - if (strEQ(d,"syswrite")) return -KEY_syswrite; - break; - } - break; - } - break; - case 't': - switch (len) { - case 2: - if (strEQ(d,"tr")) return KEY_tr; - break; - case 3: - if (strEQ(d,"tie")) return KEY_tie; - break; - case 4: - if (strEQ(d,"tell")) return -KEY_tell; - if (strEQ(d,"tied")) return KEY_tied; - if (strEQ(d,"time")) return -KEY_time; - break; - case 5: - if (strEQ(d,"times")) return -KEY_times; - break; - case 7: - if (strEQ(d,"telldir")) return -KEY_telldir; - break; - case 8: - if (strEQ(d,"truncate")) return -KEY_truncate; - break; - } - break; - case 'u': - switch (len) { - case 2: - if (strEQ(d,"uc")) return -KEY_uc; - break; - case 3: - if (strEQ(d,"use")) return KEY_use; - break; - case 5: - if (strEQ(d,"undef")) return KEY_undef; - if (strEQ(d,"until")) return KEY_until; - if (strEQ(d,"untie")) return KEY_untie; - if (strEQ(d,"utime")) return -KEY_utime; - if (strEQ(d,"umask")) return -KEY_umask; - break; - case 6: - if (strEQ(d,"unless")) return KEY_unless; - if (strEQ(d,"unpack")) return -KEY_unpack; - if (strEQ(d,"unlink")) return -KEY_unlink; - break; - case 7: - if (strEQ(d,"unshift")) return -KEY_unshift; - if (strEQ(d,"ucfirst")) return -KEY_ucfirst; - break; - } - break; - case 'v': - if (strEQ(d,"values")) return -KEY_values; - if (strEQ(d,"vec")) return -KEY_vec; - break; - case 'w': - switch (len) { - case 4: - if (strEQ(d,"warn")) return -KEY_warn; - if (strEQ(d,"wait")) return -KEY_wait; - break; - case 5: - if (strEQ(d,"while")) return KEY_while; - if (strEQ(d,"write")) return -KEY_write; - break; - case 7: - if (strEQ(d,"waitpid")) return -KEY_waitpid; - break; - case 9: - if (strEQ(d,"wantarray")) return -KEY_wantarray; - break; - } - break; - case 'x': - if (len == 1) return -KEY_x; - if (strEQ(d,"xor")) return -KEY_xor; - break; - case 'y': - if (len == 1) return KEY_y; - break; - case 'z': - break; - } - return 0; + switch (len) + { + case 1: /* 5 tokens of length 1 */ + switch (name[0]) + { + case 'm': + { /* m */ + return KEY_m; + } + + case 'q': + { /* q */ + return KEY_q; + } + + case 's': + { /* s */ + return KEY_s; + } + + case 'x': + { /* x */ + return -KEY_x; + } + + case 'y': + { /* y */ + return KEY_y; + } + + default: + goto unknown; + } + + case 2: /* 18 tokens of length 2 */ + switch (name[0]) + { + case 'd': + if (name[1] == 'o') + { /* do */ + return KEY_do; + } + + goto unknown; + + case 'e': + if (name[1] == 'q') + { /* eq */ + return -KEY_eq; + } + + goto unknown; + + case 'g': + switch (name[1]) + { + case 'e': + { /* ge */ + return -KEY_ge; + } + + case 't': + { /* gt */ + return -KEY_gt; + } + + default: + goto unknown; + } + + case 'i': + if (name[1] == 'f') + { /* if */ + return KEY_if; + } + + goto unknown; + + case 'l': + switch (name[1]) + { + case 'c': + { /* lc */ + return -KEY_lc; + } + + case 'e': + { /* le */ + return -KEY_le; + } + + case 't': + { /* lt */ + return -KEY_lt; + } + + default: + goto unknown; + } + + case 'm': + if (name[1] == 'y') + { /* my */ + return KEY_my; + } + + goto unknown; + + case 'n': + switch (name[1]) + { + case 'e': + { /* ne */ + return -KEY_ne; + } + + case 'o': + { /* no */ + return KEY_no; + } + + default: + goto unknown; + } + + case 'o': + if (name[1] == 'r') + { /* or */ + return -KEY_or; + } + + goto unknown; + + case 'q': + switch (name[1]) + { + case 'q': + { /* qq */ + return KEY_qq; + } + + case 'r': + { /* qr */ + return KEY_qr; + } + + case 'w': + { /* qw */ + return KEY_qw; + } + + case 'x': + { /* qx */ + return KEY_qx; + } + + default: + goto unknown; + } + + case 't': + if (name[1] == 'r') + { /* tr */ + return KEY_tr; + } + + goto unknown; + + case 'u': + if (name[1] == 'c') + { /* uc */ + return -KEY_uc; + } + + goto unknown; + + default: + goto unknown; + } + + case 3: /* 28 tokens of length 3 */ + switch (name[0]) + { + case 'E': + if (name[1] == 'N' && + name[2] == 'D') + { /* END */ + return KEY_END; + } + + goto unknown; + + case 'a': + switch (name[1]) + { + case 'b': + if (name[2] == 's') + { /* abs */ + return -KEY_abs; + } + + goto unknown; + + case 'n': + if (name[2] == 'd') + { /* and */ + return -KEY_and; + } + + goto unknown; + + default: + goto unknown; + } + + case 'c': + switch (name[1]) + { + case 'h': + if (name[2] == 'r') + { /* chr */ + return -KEY_chr; + } + + goto unknown; + + case 'm': + if (name[2] == 'p') + { /* cmp */ + return -KEY_cmp; + } + + goto unknown; + + case 'o': + if (name[2] == 's') + { /* cos */ + return -KEY_cos; + } + + goto unknown; + + default: + goto unknown; + } + + case 'd': + if (name[1] == 'i' && + name[2] == 'e') + { /* die */ + return -KEY_die; + } + + goto unknown; + + case 'e': + switch (name[1]) + { + case 'o': + if (name[2] == 'f') + { /* eof */ + return -KEY_eof; + } + + goto unknown; + + case 'r': + if (name[2] == 'r') + { /* err */ + return -KEY_err; + } + + goto unknown; + + case 'x': + if (name[2] == 'p') + { /* exp */ + return -KEY_exp; + } + + goto unknown; + + default: + goto unknown; + } + + case 'f': + if (name[1] == 'o' && + name[2] == 'r') + { /* for */ + return KEY_for; + } + + goto unknown; + + case 'h': + if (name[1] == 'e' && + name[2] == 'x') + { /* hex */ + return -KEY_hex; + } + + goto unknown; + + case 'i': + if (name[1] == 'n' && + name[2] == 't') + { /* int */ + return -KEY_int; + } + + goto unknown; + + case 'l': + if (name[1] == 'o' && + name[2] == 'g') + { /* log */ + return -KEY_log; + } + + goto unknown; + + case 'm': + if (name[1] == 'a' && + name[2] == 'p') + { /* map */ + return KEY_map; + } + + goto unknown; + + case 'n': + if (name[1] == 'o' && + name[2] == 't') + { /* not */ + return -KEY_not; + } + + goto unknown; + + case 'o': + switch (name[1]) + { + case 'c': + if (name[2] == 't') + { /* oct */ + return -KEY_oct; + } + + goto unknown; + + case 'r': + if (name[2] == 'd') + { /* ord */ + return -KEY_ord; + } + + goto unknown; + + case 'u': + if (name[2] == 'r') + { /* our */ + return KEY_our; + } + + goto unknown; + + default: + goto unknown; + } + + case 'p': + if (name[1] == 'o') + { + switch (name[2]) + { + case 'p': + { /* pop */ + return -KEY_pop; + } + + case 's': + { /* pos */ + return KEY_pos; + } + + default: + goto unknown; + } + } + + goto unknown; + + case 'r': + if (name[1] == 'e' && + name[2] == 'f') + { /* ref */ + return -KEY_ref; + } + + goto unknown; + + case 's': + switch (name[1]) + { + case 'i': + if (name[2] == 'n') + { /* sin */ + return -KEY_sin; + } + + goto unknown; + + case 'u': + if (name[2] == 'b') + { /* sub */ + return KEY_sub; + } + + goto unknown; + + default: + goto unknown; + } + + case 't': + if (name[1] == 'i' && + name[2] == 'e') + { /* tie */ + return KEY_tie; + } + + goto unknown; + + case 'u': + if (name[1] == 's' && + name[2] == 'e') + { /* use */ + return KEY_use; + } + + goto unknown; + + case 'v': + if (name[1] == 'e' && + name[2] == 'c') + { /* vec */ + return -KEY_vec; + } + + goto unknown; + + case 'x': + if (name[1] == 'o' && + name[2] == 'r') + { /* xor */ + return -KEY_xor; + } + + goto unknown; + + default: + goto unknown; + } + + case 4: /* 40 tokens of length 4 */ + switch (name[0]) + { + case 'C': + if (name[1] == 'O' && + name[2] == 'R' && + name[3] == 'E') + { /* CORE */ + return -KEY_CORE; + } + + goto unknown; + + case 'I': + if (name[1] == 'N' && + name[2] == 'I' && + name[3] == 'T') + { /* INIT */ + return KEY_INIT; + } + + goto unknown; + + case 'b': + if (name[1] == 'i' && + name[2] == 'n' && + name[3] == 'd') + { /* bind */ + return -KEY_bind; + } + + goto unknown; + + case 'c': + if (name[1] == 'h' && + name[2] == 'o' && + name[3] == 'p') + { /* chop */ + return -KEY_chop; + } + + goto unknown; + + case 'd': + if (name[1] == 'u' && + name[2] == 'm' && + name[3] == 'p') + { /* dump */ + return -KEY_dump; + } + + goto unknown; + + case 'e': + switch (name[1]) + { + case 'a': + if (name[2] == 'c' && + name[3] == 'h') + { /* each */ + return -KEY_each; + } + + goto unknown; + + case 'l': + if (name[2] == 's' && + name[3] == 'e') + { /* else */ + return KEY_else; + } + + goto unknown; + + case 'v': + if (name[2] == 'a' && + name[3] == 'l') + { /* eval */ + return KEY_eval; + } + + goto unknown; + + case 'x': + switch (name[2]) + { + case 'e': + if (name[3] == 'c') + { /* exec */ + return -KEY_exec; + } + + goto unknown; + + case 'i': + if (name[3] == 't') + { /* exit */ + return -KEY_exit; + } + + goto unknown; + + default: + goto unknown; + } + + default: + goto unknown; + } + + case 'f': + if (name[1] == 'o' && + name[2] == 'r' && + name[3] == 'k') + { /* fork */ + return -KEY_fork; + } + + goto unknown; + + case 'g': + switch (name[1]) + { + case 'e': + if (name[2] == 't' && + name[3] == 'c') + { /* getc */ + return -KEY_getc; + } + + goto unknown; + + case 'l': + if (name[2] == 'o' && + name[3] == 'b') + { /* glob */ + return KEY_glob; + } + + goto unknown; + + case 'o': + if (name[2] == 't' && + name[3] == 'o') + { /* goto */ + return KEY_goto; + } + + goto unknown; + + case 'r': + if (name[2] == 'e' && + name[3] == 'p') + { /* grep */ + return KEY_grep; + } + + goto unknown; + + default: + goto unknown; + } + + case 'j': + if (name[1] == 'o' && + name[2] == 'i' && + name[3] == 'n') + { /* join */ + return -KEY_join; + } + + goto unknown; + + case 'k': + switch (name[1]) + { + case 'e': + if (name[2] == 'y' && + name[3] == 's') + { /* keys */ + return -KEY_keys; + } + + goto unknown; + + case 'i': + if (name[2] == 'l' && + name[3] == 'l') + { /* kill */ + return -KEY_kill; + } + + goto unknown; + + default: + goto unknown; + } + + case 'l': + switch (name[1]) + { + case 'a': + if (name[2] == 's' && + name[3] == 't') + { /* last */ + return KEY_last; + } + + goto unknown; + + case 'i': + if (name[2] == 'n' && + name[3] == 'k') + { /* link */ + return -KEY_link; + } + + goto unknown; + + case 'o': + if (name[2] == 'c' && + name[3] == 'k') + { /* lock */ + return -KEY_lock; + } + + goto unknown; + + default: + goto unknown; + } + + case 'n': + if (name[1] == 'e' && + name[2] == 'x' && + name[3] == 't') + { /* next */ + return KEY_next; + } + + goto unknown; + + case 'o': + if (name[1] == 'p' && + name[2] == 'e' && + name[3] == 'n') + { /* open */ + return -KEY_open; + } + + goto unknown; + + case 'p': + switch (name[1]) + { + case 'a': + if (name[2] == 'c' && + name[3] == 'k') + { /* pack */ + return -KEY_pack; + } + + goto unknown; + + case 'i': + if (name[2] == 'p' && + name[3] == 'e') + { /* pipe */ + return -KEY_pipe; + } + + goto unknown; + + case 'u': + if (name[2] == 's' && + name[3] == 'h') + { /* push */ + return -KEY_push; + } + + goto unknown; + + default: + goto unknown; + } + + case 'r': + switch (name[1]) + { + case 'a': + if (name[2] == 'n' && + name[3] == 'd') + { /* rand */ + return -KEY_rand; + } + + goto unknown; + + case 'e': + switch (name[2]) + { + case 'a': + if (name[3] == 'd') + { /* read */ + return -KEY_read; + } + + goto unknown; + + case 'c': + if (name[3] == 'v') + { /* recv */ + return -KEY_recv; + } + + goto unknown; + + case 'd': + if (name[3] == 'o') + { /* redo */ + return KEY_redo; + } + + goto unknown; + + default: + goto unknown; + } + + default: + goto unknown; + } + + case 's': + switch (name[1]) + { + case 'e': + switch (name[2]) + { + case 'e': + if (name[3] == 'k') + { /* seek */ + return -KEY_seek; + } + + goto unknown; + + case 'n': + if (name[3] == 'd') + { /* send */ + return -KEY_send; + } + + goto unknown; + + default: + goto unknown; + } + + case 'o': + if (name[2] == 'r' && + name[3] == 't') + { /* sort */ + return KEY_sort; + } + + goto unknown; + + case 'q': + if (name[2] == 'r' && + name[3] == 't') + { /* sqrt */ + return -KEY_sqrt; + } + + goto unknown; + + case 't': + if (name[2] == 'a' && + name[3] == 't') + { /* stat */ + return -KEY_stat; + } + + goto unknown; + + default: + goto unknown; + } + + case 't': + switch (name[1]) + { + case 'e': + if (name[2] == 'l' && + name[3] == 'l') + { /* tell */ + return -KEY_tell; + } + + goto unknown; + + case 'i': + switch (name[2]) + { + case 'e': + if (name[3] == 'd') + { /* tied */ + return KEY_tied; + } + + goto unknown; + + case 'm': + if (name[3] == 'e') + { /* time */ + return -KEY_time; + } + + goto unknown; + + default: + goto unknown; + } + + default: + goto unknown; + } + + case 'w': + if (name[1] == 'a') + { + switch (name[2]) + { + case 'i': + if (name[3] == 't') + { /* wait */ + return -KEY_wait; + } + + goto unknown; + + case 'r': + if (name[3] == 'n') + { /* warn */ + return -KEY_warn; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + default: + goto unknown; + } + + case 5: /* 36 tokens of length 5 */ + switch (name[0]) + { + case 'B': + if (name[1] == 'E' && + name[2] == 'G' && + name[3] == 'I' && + name[4] == 'N') + { /* BEGIN */ + return KEY_BEGIN; + } + + goto unknown; + + case 'C': + if (name[1] == 'H' && + name[2] == 'E' && + name[3] == 'C' && + name[4] == 'K') + { /* CHECK */ + return KEY_CHECK; + } + + goto unknown; + + case 'a': + switch (name[1]) + { + case 'l': + if (name[2] == 'a' && + name[3] == 'r' && + name[4] == 'm') + { /* alarm */ + return -KEY_alarm; + } + + goto unknown; + + case 't': + if (name[2] == 'a' && + name[3] == 'n' && + name[4] == '2') + { /* atan2 */ + return -KEY_atan2; + } + + goto unknown; + + default: + goto unknown; + } + + case 'b': + if (name[1] == 'l' && + name[2] == 'e' && + name[3] == 's' && + name[4] == 's') + { /* bless */ + return -KEY_bless; + } + + goto unknown; + + case 'c': + switch (name[1]) + { + case 'h': + switch (name[2]) + { + case 'd': + if (name[3] == 'i' && + name[4] == 'r') + { /* chdir */ + return -KEY_chdir; + } + + goto unknown; + + case 'm': + if (name[3] == 'o' && + name[4] == 'd') + { /* chmod */ + return -KEY_chmod; + } + + goto unknown; + + case 'o': + switch (name[3]) + { + case 'm': + if (name[4] == 'p') + { /* chomp */ + return -KEY_chomp; + } + + goto unknown; + + case 'w': + if (name[4] == 'n') + { /* chown */ + return -KEY_chown; + } + + goto unknown; + + default: + goto unknown; + } + + default: + goto unknown; + } + + case 'l': + if (name[2] == 'o' && + name[3] == 's' && + name[4] == 'e') + { /* close */ + return -KEY_close; + } + + goto unknown; + + case 'r': + if (name[2] == 'y' && + name[3] == 'p' && + name[4] == 't') + { /* crypt */ + return -KEY_crypt; + } + + goto unknown; + + default: + goto unknown; + } + + case 'e': + if (name[1] == 'l' && + name[2] == 's' && + name[3] == 'i' && + name[4] == 'f') + { /* elsif */ + return KEY_elsif; + } + + goto unknown; + + case 'f': + switch (name[1]) + { + case 'c': + if (name[2] == 'n' && + name[3] == 't' && + name[4] == 'l') + { /* fcntl */ + return -KEY_fcntl; + } + + goto unknown; + + case 'l': + if (name[2] == 'o' && + name[3] == 'c' && + name[4] == 'k') + { /* flock */ + return -KEY_flock; + } + + goto unknown; + + default: + goto unknown; + } + + case 'i': + switch (name[1]) + { + case 'n': + if (name[2] == 'd' && + name[3] == 'e' && + name[4] == 'x') + { /* index */ + return -KEY_index; + } + + goto unknown; + + case 'o': + if (name[2] == 'c' && + name[3] == 't' && + name[4] == 'l') + { /* ioctl */ + return -KEY_ioctl; + } + + goto unknown; + + default: + goto unknown; + } + + case 'l': + switch (name[1]) + { + case 'o': + if (name[2] == 'c' && + name[3] == 'a' && + name[4] == 'l') + { /* local */ + return KEY_local; + } + + goto unknown; + + case 's': + if (name[2] == 't' && + name[3] == 'a' && + name[4] == 't') + { /* lstat */ + return -KEY_lstat; + } + + goto unknown; + + default: + goto unknown; + } + + case 'm': + if (name[1] == 'k' && + name[2] == 'd' && + name[3] == 'i' && + name[4] == 'r') + { /* mkdir */ + return -KEY_mkdir; + } + + goto unknown; + + case 'p': + if (name[1] == 'r' && + name[2] == 'i' && + name[3] == 'n' && + name[4] == 't') + { /* print */ + return KEY_print; + } + + goto unknown; + + case 'r': + switch (name[1]) + { + case 'e': + if (name[2] == 's' && + name[3] == 'e' && + name[4] == 't') + { /* reset */ + return -KEY_reset; + } + + goto unknown; + + case 'm': + if (name[2] == 'd' && + name[3] == 'i' && + name[4] == 'r') + { /* rmdir */ + return -KEY_rmdir; + } + + goto unknown; + + default: + goto unknown; + } + + case 's': + switch (name[1]) + { + case 'e': + if (name[2] == 'm' && + name[3] == 'o' && + name[4] == 'p') + { /* semop */ + return -KEY_semop; + } + + goto unknown; + + case 'h': + if (name[2] == 'i' && + name[3] == 'f' && + name[4] == 't') + { /* shift */ + return -KEY_shift; + } + + goto unknown; + + case 'l': + if (name[2] == 'e' && + name[3] == 'e' && + name[4] == 'p') + { /* sleep */ + return -KEY_sleep; + } + + goto unknown; + + case 'p': + if (name[2] == 'l' && + name[3] == 'i' && + name[4] == 't') + { /* split */ + return KEY_split; + } + + goto unknown; + + case 'r': + if (name[2] == 'a' && + name[3] == 'n' && + name[4] == 'd') + { /* srand */ + return -KEY_srand; + } + + goto unknown; + + case 't': + if (name[2] == 'u' && + name[3] == 'd' && + name[4] == 'y') + { /* study */ + return KEY_study; + } + + goto unknown; + + default: + goto unknown; + } + + case 't': + if (name[1] == 'i' && + name[2] == 'm' && + name[3] == 'e' && + name[4] == 's') + { /* times */ + return -KEY_times; + } + + goto unknown; + + case 'u': + switch (name[1]) + { + case 'm': + if (name[2] == 'a' && + name[3] == 's' && + name[4] == 'k') + { /* umask */ + return -KEY_umask; + } + + goto unknown; + + case 'n': + switch (name[2]) + { + case 'd': + if (name[3] == 'e' && + name[4] == 'f') + { /* undef */ + return KEY_undef; + } + + goto unknown; + + case 't': + if (name[3] == 'i') + { + switch (name[4]) + { + case 'e': + { /* untie */ + return KEY_untie; + } + + case 'l': + { /* until */ + return KEY_until; + } + + default: + goto unknown; + } + } + + goto unknown; + + default: + goto unknown; + } + + case 't': + if (name[2] == 'i' && + name[3] == 'm' && + name[4] == 'e') + { /* utime */ + return -KEY_utime; + } + + goto unknown; + + default: + goto unknown; + } + + case 'w': + switch (name[1]) + { + case 'h': + if (name[2] == 'i' && + name[3] == 'l' && + name[4] == 'e') + { /* while */ + return KEY_while; + } + + goto unknown; + + case 'r': + if (name[2] == 'i' && + name[3] == 't' && + name[4] == 'e') + { /* write */ + return -KEY_write; + } + + goto unknown; + + default: + goto unknown; + } + + default: + goto unknown; + } + + case 6: /* 33 tokens of length 6 */ + switch (name[0]) + { + case 'a': + if (name[1] == 'c' && + name[2] == 'c' && + name[3] == 'e' && + name[4] == 'p' && + name[5] == 't') + { /* accept */ + return -KEY_accept; + } + + goto unknown; + + case 'c': + switch (name[1]) + { + case 'a': + if (name[2] == 'l' && + name[3] == 'l' && + name[4] == 'e' && + name[5] == 'r') + { /* caller */ + return -KEY_caller; + } + + goto unknown; + + case 'h': + if (name[2] == 'r' && + name[3] == 'o' && + name[4] == 'o' && + name[5] == 't') + { /* chroot */ + return -KEY_chroot; + } + + goto unknown; + + default: + goto unknown; + } + + case 'd': + if (name[1] == 'e' && + name[2] == 'l' && + name[3] == 'e' && + name[4] == 't' && + name[5] == 'e') + { /* delete */ + return KEY_delete; + } + + goto unknown; + + case 'e': + switch (name[1]) + { + case 'l': + if (name[2] == 's' && + name[3] == 'e' && + name[4] == 'i' && + name[5] == 'f') + { /* elseif */ + if(ckWARN_d(WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif"); + } + + goto unknown; + + case 'x': + if (name[2] == 'i' && + name[3] == 's' && + name[4] == 't' && + name[5] == 's') + { /* exists */ + return KEY_exists; + } + + goto unknown; + + default: + goto unknown; + } + + case 'f': + switch (name[1]) + { + case 'i': + if (name[2] == 'l' && + name[3] == 'e' && + name[4] == 'n' && + name[5] == 'o') + { /* fileno */ + return -KEY_fileno; + } + + goto unknown; + + case 'o': + if (name[2] == 'r' && + name[3] == 'm' && + name[4] == 'a' && + name[5] == 't') + { /* format */ + return KEY_format; + } + + goto unknown; + + default: + goto unknown; + } + + case 'g': + if (name[1] == 'm' && + name[2] == 't' && + name[3] == 'i' && + name[4] == 'm' && + name[5] == 'e') + { /* gmtime */ + return -KEY_gmtime; + } + + goto unknown; + + case 'l': + switch (name[1]) + { + case 'e': + if (name[2] == 'n' && + name[3] == 'g' && + name[4] == 't' && + name[5] == 'h') + { /* length */ + return -KEY_length; + } + + goto unknown; + + case 'i': + if (name[2] == 's' && + name[3] == 't' && + name[4] == 'e' && + name[5] == 'n') + { /* listen */ + return -KEY_listen; + } + + goto unknown; + + default: + goto unknown; + } + + case 'm': + if (name[1] == 's' && + name[2] == 'g') + { + switch (name[3]) + { + case 'c': + if (name[4] == 't' && + name[5] == 'l') + { /* msgctl */ + return -KEY_msgctl; + } + + goto unknown; + + case 'g': + if (name[4] == 'e' && + name[5] == 't') + { /* msgget */ + return -KEY_msgget; + } + + goto unknown; + + case 'r': + if (name[4] == 'c' && + name[5] == 'v') + { /* msgrcv */ + return -KEY_msgrcv; + } + + goto unknown; + + case 's': + if (name[4] == 'n' && + name[5] == 'd') + { /* msgsnd */ + return -KEY_msgsnd; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + case 'p': + if (name[1] == 'r' && + name[2] == 'i' && + name[3] == 'n' && + name[4] == 't' && + name[5] == 'f') + { /* printf */ + return KEY_printf; + } + + goto unknown; + + case 'r': + switch (name[1]) + { + case 'e': + switch (name[2]) + { + case 'n': + if (name[3] == 'a' && + name[4] == 'm' && + name[5] == 'e') + { /* rename */ + return -KEY_rename; + } + + goto unknown; + + case 't': + if (name[3] == 'u' && + name[4] == 'r' && + name[5] == 'n') + { /* return */ + return KEY_return; + } + + goto unknown; + + default: + goto unknown; + } + + case 'i': + if (name[2] == 'n' && + name[3] == 'd' && + name[4] == 'e' && + name[5] == 'x') + { /* rindex */ + return -KEY_rindex; + } + + goto unknown; + + default: + goto unknown; + } + + case 's': + switch (name[1]) + { + case 'c': + if (name[2] == 'a' && + name[3] == 'l' && + name[4] == 'a' && + name[5] == 'r') + { /* scalar */ + return KEY_scalar; + } + + goto unknown; + + case 'e': + switch (name[2]) + { + case 'l': + if (name[3] == 'e' && + name[4] == 'c' && + name[5] == 't') + { /* select */ + return -KEY_select; + } + + goto unknown; + + case 'm': + switch (name[3]) + { + case 'c': + if (name[4] == 't' && + name[5] == 'l') + { /* semctl */ + return -KEY_semctl; + } + + goto unknown; + + case 'g': + if (name[4] == 'e' && + name[5] == 't') + { /* semget */ + return -KEY_semget; + } + + goto unknown; + + default: + goto unknown; + } + + default: + goto unknown; + } + + case 'h': + if (name[2] == 'm') + { + switch (name[3]) + { + case 'c': + if (name[4] == 't' && + name[5] == 'l') + { /* shmctl */ + return -KEY_shmctl; + } + + goto unknown; + + case 'g': + if (name[4] == 'e' && + name[5] == 't') + { /* shmget */ + return -KEY_shmget; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + case 'o': + if (name[2] == 'c' && + name[3] == 'k' && + name[4] == 'e' && + name[5] == 't') + { /* socket */ + return -KEY_socket; + } + + goto unknown; + + case 'p': + if (name[2] == 'l' && + name[3] == 'i' && + name[4] == 'c' && + name[5] == 'e') + { /* splice */ + return -KEY_splice; + } + + goto unknown; + + case 'u': + if (name[2] == 'b' && + name[3] == 's' && + name[4] == 't' && + name[5] == 'r') + { /* substr */ + return -KEY_substr; + } + + goto unknown; + + case 'y': + if (name[2] == 's' && + name[3] == 't' && + name[4] == 'e' && + name[5] == 'm') + { /* system */ + return -KEY_system; + } + + goto unknown; + + default: + goto unknown; + } + + case 'u': + if (name[1] == 'n') + { + switch (name[2]) + { + case 'l': + switch (name[3]) + { + case 'e': + if (name[4] == 's' && + name[5] == 's') + { /* unless */ + return KEY_unless; + } + + goto unknown; + + case 'i': + if (name[4] == 'n' && + name[5] == 'k') + { /* unlink */ + return -KEY_unlink; + } + + goto unknown; + + default: + goto unknown; + } + + case 'p': + if (name[3] == 'a' && + name[4] == 'c' && + name[5] == 'k') + { /* unpack */ + return -KEY_unpack; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + case 'v': + if (name[1] == 'a' && + name[2] == 'l' && + name[3] == 'u' && + name[4] == 'e' && + name[5] == 's') + { /* values */ + return -KEY_values; + } + + goto unknown; + + default: + goto unknown; + } + + case 7: /* 28 tokens of length 7 */ + switch (name[0]) + { + case 'D': + if (name[1] == 'E' && + name[2] == 'S' && + name[3] == 'T' && + name[4] == 'R' && + name[5] == 'O' && + name[6] == 'Y') + { /* DESTROY */ + return KEY_DESTROY; + } + + goto unknown; + + case '_': + if (name[1] == '_' && + name[2] == 'E' && + name[3] == 'N' && + name[4] == 'D' && + name[5] == '_' && + name[6] == '_') + { /* __END__ */ + return KEY___END__; + } + + goto unknown; + + case 'b': + if (name[1] == 'i' && + name[2] == 'n' && + name[3] == 'm' && + name[4] == 'o' && + name[5] == 'd' && + name[6] == 'e') + { /* binmode */ + return -KEY_binmode; + } + + goto unknown; + + case 'c': + if (name[1] == 'o' && + name[2] == 'n' && + name[3] == 'n' && + name[4] == 'e' && + name[5] == 'c' && + name[6] == 't') + { /* connect */ + return -KEY_connect; + } + + goto unknown; + + case 'd': + switch (name[1]) + { + case 'b': + if (name[2] == 'm' && + name[3] == 'o' && + name[4] == 'p' && + name[5] == 'e' && + name[6] == 'n') + { /* dbmopen */ + return -KEY_dbmopen; + } + + goto unknown; + + case 'e': + if (name[2] == 'f' && + name[3] == 'i' && + name[4] == 'n' && + name[5] == 'e' && + name[6] == 'd') + { /* defined */ + return KEY_defined; + } + + goto unknown; + + default: + goto unknown; + } + + case 'f': + if (name[1] == 'o' && + name[2] == 'r' && + name[3] == 'e' && + name[4] == 'a' && + name[5] == 'c' && + name[6] == 'h') + { /* foreach */ + return KEY_foreach; + } + + goto unknown; + + case 'g': + if (name[1] == 'e' && + name[2] == 't' && + name[3] == 'p') + { + switch (name[4]) + { + case 'g': + if (name[5] == 'r' && + name[6] == 'p') + { /* getpgrp */ + return -KEY_getpgrp; + } + + goto unknown; + + case 'p': + if (name[5] == 'i' && + name[6] == 'd') + { /* getppid */ + return -KEY_getppid; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + case 'l': + if (name[1] == 'c' && + name[2] == 'f' && + name[3] == 'i' && + name[4] == 'r' && + name[5] == 's' && + name[6] == 't') + { /* lcfirst */ + return -KEY_lcfirst; + } + + goto unknown; + + case 'o': + if (name[1] == 'p' && + name[2] == 'e' && + name[3] == 'n' && + name[4] == 'd' && + name[5] == 'i' && + name[6] == 'r') + { /* opendir */ + return -KEY_opendir; + } + + goto unknown; + + case 'p': + if (name[1] == 'a' && + name[2] == 'c' && + name[3] == 'k' && + name[4] == 'a' && + name[5] == 'g' && + name[6] == 'e') + { /* package */ + return KEY_package; + } + + goto unknown; + + case 'r': + if (name[1] == 'e') + { + switch (name[2]) + { + case 'a': + if (name[3] == 'd' && + name[4] == 'd' && + name[5] == 'i' && + name[6] == 'r') + { /* readdir */ + return -KEY_readdir; + } + + goto unknown; + + case 'q': + if (name[3] == 'u' && + name[4] == 'i' && + name[5] == 'r' && + name[6] == 'e') + { /* require */ + return KEY_require; + } + + goto unknown; + + case 'v': + if (name[3] == 'e' && + name[4] == 'r' && + name[5] == 's' && + name[6] == 'e') + { /* reverse */ + return -KEY_reverse; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + case 's': + switch (name[1]) + { + case 'e': + switch (name[2]) + { + case 'e': + if (name[3] == 'k' && + name[4] == 'd' && + name[5] == 'i' && + name[6] == 'r') + { /* seekdir */ + return -KEY_seekdir; + } + + goto unknown; + + case 't': + if (name[3] == 'p' && + name[4] == 'g' && + name[5] == 'r' && + name[6] == 'p') + { /* setpgrp */ + return -KEY_setpgrp; + } + + goto unknown; + + default: + goto unknown; + } + + case 'h': + if (name[2] == 'm' && + name[3] == 'r' && + name[4] == 'e' && + name[5] == 'a' && + name[6] == 'd') + { /* shmread */ + return -KEY_shmread; + } + + goto unknown; + + case 'p': + if (name[2] == 'r' && + name[3] == 'i' && + name[4] == 'n' && + name[5] == 't' && + name[6] == 'f') + { /* sprintf */ + return -KEY_sprintf; + } + + goto unknown; + + case 'y': + switch (name[2]) + { + case 'm': + if (name[3] == 'l' && + name[4] == 'i' && + name[5] == 'n' && + name[6] == 'k') + { /* symlink */ + return -KEY_symlink; + } + + goto unknown; + + case 's': + switch (name[3]) + { + case 'c': + if (name[4] == 'a' && + name[5] == 'l' && + name[6] == 'l') + { /* syscall */ + return -KEY_syscall; + } + + goto unknown; + + case 'o': + if (name[4] == 'p' && + name[5] == 'e' && + name[6] == 'n') + { /* sysopen */ + return -KEY_sysopen; + } + + goto unknown; + + case 'r': + if (name[4] == 'e' && + name[5] == 'a' && + name[6] == 'd') + { /* sysread */ + return -KEY_sysread; + } + + goto unknown; + + case 's': + if (name[4] == 'e' && + name[5] == 'e' && + name[6] == 'k') + { /* sysseek */ + return -KEY_sysseek; + } + + goto unknown; + + default: + goto unknown; + } + + default: + goto unknown; + } + + default: + goto unknown; + } + + case 't': + if (name[1] == 'e' && + name[2] == 'l' && + name[3] == 'l' && + name[4] == 'd' && + name[5] == 'i' && + name[6] == 'r') + { /* telldir */ + return -KEY_telldir; + } + + goto unknown; + + case 'u': + switch (name[1]) + { + case 'c': + if (name[2] == 'f' && + name[3] == 'i' && + name[4] == 'r' && + name[5] == 's' && + name[6] == 't') + { /* ucfirst */ + return -KEY_ucfirst; + } + + goto unknown; + + case 'n': + if (name[2] == 's' && + name[3] == 'h' && + name[4] == 'i' && + name[5] == 'f' && + name[6] == 't') + { /* unshift */ + return -KEY_unshift; + } + + goto unknown; + + default: + goto unknown; + } + + case 'w': + if (name[1] == 'a' && + name[2] == 'i' && + name[3] == 't' && + name[4] == 'p' && + name[5] == 'i' && + name[6] == 'd') + { /* waitpid */ + return -KEY_waitpid; + } + + goto unknown; + + default: + goto unknown; + } + + case 8: /* 26 tokens of length 8 */ + switch (name[0]) + { + case 'A': + if (name[1] == 'U' && + name[2] == 'T' && + name[3] == 'O' && + name[4] == 'L' && + name[5] == 'O' && + name[6] == 'A' && + name[7] == 'D') + { /* AUTOLOAD */ + return KEY_AUTOLOAD; + } + + goto unknown; + + case '_': + if (name[1] == '_') + { + switch (name[2]) + { + case 'D': + if (name[3] == 'A' && + name[4] == 'T' && + name[5] == 'A' && + name[6] == '_' && + name[7] == '_') + { /* __DATA__ */ + return KEY___DATA__; + } + + goto unknown; + + case 'F': + if (name[3] == 'I' && + name[4] == 'L' && + name[5] == 'E' && + name[6] == '_' && + name[7] == '_') + { /* __FILE__ */ + return -KEY___FILE__; + } + + goto unknown; + + case 'L': + if (name[3] == 'I' && + name[4] == 'N' && + name[5] == 'E' && + name[6] == '_' && + name[7] == '_') + { /* __LINE__ */ + return -KEY___LINE__; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + case 'c': + switch (name[1]) + { + case 'l': + if (name[2] == 'o' && + name[3] == 's' && + name[4] == 'e' && + name[5] == 'd' && + name[6] == 'i' && + name[7] == 'r') + { /* closedir */ + return -KEY_closedir; + } + + goto unknown; + + case 'o': + if (name[2] == 'n' && + name[3] == 't' && + name[4] == 'i' && + name[5] == 'n' && + name[6] == 'u' && + name[7] == 'e') + { /* continue */ + return -KEY_continue; + } + + goto unknown; + + default: + goto unknown; + } + + case 'd': + if (name[1] == 'b' && + name[2] == 'm' && + name[3] == 'c' && + name[4] == 'l' && + name[5] == 'o' && + name[6] == 's' && + name[7] == 'e') + { /* dbmclose */ + return -KEY_dbmclose; + } + + goto unknown; + + case 'e': + if (name[1] == 'n' && + name[2] == 'd') + { + switch (name[3]) + { + case 'g': + if (name[4] == 'r' && + name[5] == 'e' && + name[6] == 'n' && + name[7] == 't') + { /* endgrent */ + return -KEY_endgrent; + } + + goto unknown; + + case 'p': + if (name[4] == 'w' && + name[5] == 'e' && + name[6] == 'n' && + name[7] == 't') + { /* endpwent */ + return -KEY_endpwent; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + case 'f': + if (name[1] == 'o' && + name[2] == 'r' && + name[3] == 'm' && + name[4] == 'l' && + name[5] == 'i' && + name[6] == 'n' && + name[7] == 'e') + { /* formline */ + return -KEY_formline; + } + + goto unknown; + + case 'g': + if (name[1] == 'e' && + name[2] == 't') + { + switch (name[3]) + { + case 'g': + if (name[4] == 'r') + { + switch (name[5]) + { + case 'e': + if (name[6] == 'n' && + name[7] == 't') + { /* getgrent */ + return -KEY_getgrent; + } + + goto unknown; + + case 'g': + if (name[6] == 'i' && + name[7] == 'd') + { /* getgrgid */ + return -KEY_getgrgid; + } + + goto unknown; + + case 'n': + if (name[6] == 'a' && + name[7] == 'm') + { /* getgrnam */ + return -KEY_getgrnam; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + case 'l': + if (name[4] == 'o' && + name[5] == 'g' && + name[6] == 'i' && + name[7] == 'n') + { /* getlogin */ + return -KEY_getlogin; + } + + goto unknown; + + case 'p': + if (name[4] == 'w') + { + switch (name[5]) + { + case 'e': + if (name[6] == 'n' && + name[7] == 't') + { /* getpwent */ + return -KEY_getpwent; + } + + goto unknown; + + case 'n': + if (name[6] == 'a' && + name[7] == 'm') + { /* getpwnam */ + return -KEY_getpwnam; + } + + goto unknown; + + case 'u': + if (name[6] == 'i' && + name[7] == 'd') + { /* getpwuid */ + return -KEY_getpwuid; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + case 'r': + if (name[1] == 'e' && + name[2] == 'a' && + name[3] == 'd') + { + switch (name[4]) + { + case 'l': + if (name[5] == 'i' && + name[6] == 'n') + { + switch (name[7]) + { + case 'e': + { /* readline */ + return -KEY_readline; + } + + case 'k': + { /* readlink */ + return -KEY_readlink; + } + + default: + goto unknown; + } + } + + goto unknown; + + case 'p': + if (name[5] == 'i' && + name[6] == 'p' && + name[7] == 'e') + { /* readpipe */ + return -KEY_readpipe; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + case 's': + switch (name[1]) + { + case 'e': + if (name[2] == 't') + { + switch (name[3]) + { + case 'g': + if (name[4] == 'r' && + name[5] == 'e' && + name[6] == 'n' && + name[7] == 't') + { /* setgrent */ + return -KEY_setgrent; + } + + goto unknown; + + case 'p': + if (name[4] == 'w' && + name[5] == 'e' && + name[6] == 'n' && + name[7] == 't') + { /* setpwent */ + return -KEY_setpwent; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + case 'h': + switch (name[2]) + { + case 'm': + if (name[3] == 'w' && + name[4] == 'r' && + name[5] == 'i' && + name[6] == 't' && + name[7] == 'e') + { /* shmwrite */ + return -KEY_shmwrite; + } + + goto unknown; + + case 'u': + if (name[3] == 't' && + name[4] == 'd' && + name[5] == 'o' && + name[6] == 'w' && + name[7] == 'n') + { /* shutdown */ + return -KEY_shutdown; + } + + goto unknown; + + default: + goto unknown; + } + + case 'y': + if (name[2] == 's' && + name[3] == 'w' && + name[4] == 'r' && + name[5] == 'i' && + name[6] == 't' && + name[7] == 'e') + { /* syswrite */ + return -KEY_syswrite; + } + + goto unknown; + + default: + goto unknown; + } + + case 't': + if (name[1] == 'r' && + name[2] == 'u' && + name[3] == 'n' && + name[4] == 'c' && + name[5] == 'a' && + name[6] == 't' && + name[7] == 'e') + { /* truncate */ + return -KEY_truncate; + } + + goto unknown; + + default: + goto unknown; + } + + case 9: /* 8 tokens of length 9 */ + switch (name[0]) + { + case 'e': + if (name[1] == 'n' && + name[2] == 'd' && + name[3] == 'n' && + name[4] == 'e' && + name[5] == 't' && + name[6] == 'e' && + name[7] == 'n' && + name[8] == 't') + { /* endnetent */ + return -KEY_endnetent; + } + + goto unknown; + + case 'g': + if (name[1] == 'e' && + name[2] == 't' && + name[3] == 'n' && + name[4] == 'e' && + name[5] == 't' && + name[6] == 'e' && + name[7] == 'n' && + name[8] == 't') + { /* getnetent */ + return -KEY_getnetent; + } + + goto unknown; + + case 'l': + if (name[1] == 'o' && + name[2] == 'c' && + name[3] == 'a' && + name[4] == 'l' && + name[5] == 't' && + name[6] == 'i' && + name[7] == 'm' && + name[8] == 'e') + { /* localtime */ + return -KEY_localtime; + } + + goto unknown; + + case 'p': + if (name[1] == 'r' && + name[2] == 'o' && + name[3] == 't' && + name[4] == 'o' && + name[5] == 't' && + name[6] == 'y' && + name[7] == 'p' && + name[8] == 'e') + { /* prototype */ + return KEY_prototype; + } + + goto unknown; + + case 'q': + if (name[1] == 'u' && + name[2] == 'o' && + name[3] == 't' && + name[4] == 'e' && + name[5] == 'm' && + name[6] == 'e' && + name[7] == 't' && + name[8] == 'a') + { /* quotemeta */ + return -KEY_quotemeta; + } + + goto unknown; + + case 'r': + if (name[1] == 'e' && + name[2] == 'w' && + name[3] == 'i' && + name[4] == 'n' && + name[5] == 'd' && + name[6] == 'd' && + name[7] == 'i' && + name[8] == 'r') + { /* rewinddir */ + return -KEY_rewinddir; + } + + goto unknown; + + case 's': + if (name[1] == 'e' && + name[2] == 't' && + name[3] == 'n' && + name[4] == 'e' && + name[5] == 't' && + name[6] == 'e' && + name[7] == 'n' && + name[8] == 't') + { /* setnetent */ + return -KEY_setnetent; + } + + goto unknown; + + case 'w': + if (name[1] == 'a' && + name[2] == 'n' && + name[3] == 't' && + name[4] == 'a' && + name[5] == 'r' && + name[6] == 'r' && + name[7] == 'a' && + name[8] == 'y') + { /* wantarray */ + return -KEY_wantarray; + } + + goto unknown; + + default: + goto unknown; + } + + case 10: /* 9 tokens of length 10 */ + switch (name[0]) + { + case 'e': + if (name[1] == 'n' && + name[2] == 'd') + { + switch (name[3]) + { + case 'h': + if (name[4] == 'o' && + name[5] == 's' && + name[6] == 't' && + name[7] == 'e' && + name[8] == 'n' && + name[9] == 't') + { /* endhostent */ + return -KEY_endhostent; + } + + goto unknown; + + case 's': + if (name[4] == 'e' && + name[5] == 'r' && + name[6] == 'v' && + name[7] == 'e' && + name[8] == 'n' && + name[9] == 't') + { /* endservent */ + return -KEY_endservent; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + case 'g': + if (name[1] == 'e' && + name[2] == 't') + { + switch (name[3]) + { + case 'h': + if (name[4] == 'o' && + name[5] == 's' && + name[6] == 't' && + name[7] == 'e' && + name[8] == 'n' && + name[9] == 't') + { /* gethostent */ + return -KEY_gethostent; + } + + goto unknown; + + case 's': + switch (name[4]) + { + case 'e': + if (name[5] == 'r' && + name[6] == 'v' && + name[7] == 'e' && + name[8] == 'n' && + name[9] == 't') + { /* getservent */ + return -KEY_getservent; + } + + goto unknown; + + case 'o': + if (name[5] == 'c' && + name[6] == 'k' && + name[7] == 'o' && + name[8] == 'p' && + name[9] == 't') + { /* getsockopt */ + return -KEY_getsockopt; + } + + goto unknown; + + default: + goto unknown; + } + + default: + goto unknown; + } + } + + goto unknown; + + case 's': + switch (name[1]) + { + case 'e': + if (name[2] == 't') + { + switch (name[3]) + { + case 'h': + if (name[4] == 'o' && + name[5] == 's' && + name[6] == 't' && + name[7] == 'e' && + name[8] == 'n' && + name[9] == 't') + { /* sethostent */ + return -KEY_sethostent; + } + + goto unknown; + + case 's': + switch (name[4]) + { + case 'e': + if (name[5] == 'r' && + name[6] == 'v' && + name[7] == 'e' && + name[8] == 'n' && + name[9] == 't') + { /* setservent */ + return -KEY_setservent; + } + + goto unknown; + + case 'o': + if (name[5] == 'c' && + name[6] == 'k' && + name[7] == 'o' && + name[8] == 'p' && + name[9] == 't') + { /* setsockopt */ + return -KEY_setsockopt; + } + + goto unknown; + + default: + goto unknown; + } + + default: + goto unknown; + } + } + + goto unknown; + + case 'o': + if (name[2] == 'c' && + name[3] == 'k' && + name[4] == 'e' && + name[5] == 't' && + name[6] == 'p' && + name[7] == 'a' && + name[8] == 'i' && + name[9] == 'r') + { /* socketpair */ + return -KEY_socketpair; + } + + goto unknown; + + default: + goto unknown; + } + + default: + goto unknown; + } + + case 11: /* 8 tokens of length 11 */ + switch (name[0]) + { + case '_': + if (name[1] == '_' && + name[2] == 'P' && + name[3] == 'A' && + name[4] == 'C' && + name[5] == 'K' && + name[6] == 'A' && + name[7] == 'G' && + name[8] == 'E' && + name[9] == '_' && + name[10] == '_') + { /* __PACKAGE__ */ + return -KEY___PACKAGE__; + } + + goto unknown; + + case 'e': + if (name[1] == 'n' && + name[2] == 'd' && + name[3] == 'p' && + name[4] == 'r' && + name[5] == 'o' && + name[6] == 't' && + name[7] == 'o' && + name[8] == 'e' && + name[9] == 'n' && + name[10] == 't') + { /* endprotoent */ + return -KEY_endprotoent; + } + + goto unknown; + + case 'g': + if (name[1] == 'e' && + name[2] == 't') + { + switch (name[3]) + { + case 'p': + switch (name[4]) + { + case 'e': + if (name[5] == 'e' && + name[6] == 'r' && + name[7] == 'n' && + name[8] == 'a' && + name[9] == 'm' && + name[10] == 'e') + { /* getpeername */ + return -KEY_getpeername; + } + + goto unknown; + + case 'r': + switch (name[5]) + { + case 'i': + if (name[6] == 'o' && + name[7] == 'r' && + name[8] == 'i' && + name[9] == 't' && + name[10] == 'y') + { /* getpriority */ + return -KEY_getpriority; + } + + goto unknown; + + case 'o': + if (name[6] == 't' && + name[7] == 'o' && + name[8] == 'e' && + name[9] == 'n' && + name[10] == 't') + { /* getprotoent */ + return -KEY_getprotoent; + } + + goto unknown; + + default: + goto unknown; + } + + default: + goto unknown; + } + + case 's': + if (name[4] == 'o' && + name[5] == 'c' && + name[6] == 'k' && + name[7] == 'n' && + name[8] == 'a' && + name[9] == 'm' && + name[10] == 'e') + { /* getsockname */ + return -KEY_getsockname; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + case 's': + if (name[1] == 'e' && + name[2] == 't' && + name[3] == 'p' && + name[4] == 'r') + { + switch (name[5]) + { + case 'i': + if (name[6] == 'o' && + name[7] == 'r' && + name[8] == 'i' && + name[9] == 't' && + name[10] == 'y') + { /* setpriority */ + return -KEY_setpriority; + } + + goto unknown; + + case 'o': + if (name[6] == 't' && + name[7] == 'o' && + name[8] == 'e' && + name[9] == 'n' && + name[10] == 't') + { /* setprotoent */ + return -KEY_setprotoent; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + default: + goto unknown; + } + + case 12: /* 2 tokens of length 12 */ + if (name[0] == 'g' && + name[1] == 'e' && + name[2] == 't' && + name[3] == 'n' && + name[4] == 'e' && + name[5] == 't' && + name[6] == 'b' && + name[7] == 'y') + { + switch (name[8]) + { + case 'a': + if (name[9] == 'd' && + name[10] == 'd' && + name[11] == 'r') + { /* getnetbyaddr */ + return -KEY_getnetbyaddr; + } + + goto unknown; + + case 'n': + if (name[9] == 'a' && + name[10] == 'm' && + name[11] == 'e') + { /* getnetbyname */ + return -KEY_getnetbyname; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + case 13: /* 4 tokens of length 13 */ + if (name[0] == 'g' && + name[1] == 'e' && + name[2] == 't') + { + switch (name[3]) + { + case 'h': + if (name[4] == 'o' && + name[5] == 's' && + name[6] == 't' && + name[7] == 'b' && + name[8] == 'y') + { + switch (name[9]) + { + case 'a': + if (name[10] == 'd' && + name[11] == 'd' && + name[12] == 'r') + { /* gethostbyaddr */ + return -KEY_gethostbyaddr; + } + + goto unknown; + + case 'n': + if (name[10] == 'a' && + name[11] == 'm' && + name[12] == 'e') + { /* gethostbyname */ + return -KEY_gethostbyname; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + case 's': + if (name[4] == 'e' && + name[5] == 'r' && + name[6] == 'v' && + name[7] == 'b' && + name[8] == 'y') + { + switch (name[9]) + { + case 'n': + if (name[10] == 'a' && + name[11] == 'm' && + name[12] == 'e') + { /* getservbyname */ + return -KEY_getservbyname; + } + + goto unknown; + + case 'p': + if (name[10] == 'o' && + name[11] == 'r' && + name[12] == 't') + { /* getservbyport */ + return -KEY_getservbyport; + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + default: + goto unknown; + } + } + + goto unknown; + + case 14: /* 1 tokens of length 14 */ + if (name[0] == 'g' && + name[1] == 'e' && + name[2] == 't' && + name[3] == 'p' && + name[4] == 'r' && + name[5] == 'o' && + name[6] == 't' && + name[7] == 'o' && + name[8] == 'b' && + name[9] == 'y' && + name[10] == 'n' && + name[11] == 'a' && + name[12] == 'm' && + name[13] == 'e') + { /* getprotobyname */ + return -KEY_getprotobyname; + } + + goto unknown; + + case 16: /* 1 tokens of length 16 */ + if (name[0] == 'g' && + name[1] == 'e' && + name[2] == 't' && + name[3] == 'p' && + name[4] == 'r' && + name[5] == 'o' && + name[6] == 't' && + name[7] == 'o' && + name[8] == 'b' && + name[9] == 'y' && + name[10] == 'n' && + name[11] == 'u' && + name[12] == 'm' && + name[13] == 'b' && + name[14] == 'e' && + name[15] == 'r') + { /* getprotobynumber */ + return -KEY_getprotobynumber; + } + + goto unknown; + + default: + goto unknown; + } + +unknown: + return 0; } STATIC void -S_checkcomma(pTHX_ register char *s, char *name, char *what) +S_checkcomma(pTHX_ register char *s, const char *name, const char *what) { - char *w; + const char *w; if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ if (ckWARN(WARN_SYNTAX)) { @@ -6029,7 +9007,7 @@ S_checkcomma(pTHX_ register char *s, char *name, char *what) s++; if (*s == ',') { int kw; - *s = '\0'; + *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */ kw = keyword(w, s - w) || get_cv(w, FALSE) != 0; *s = ','; if (kw) @@ -6045,15 +9023,15 @@ S_checkcomma(pTHX_ register char *s, char *name, char *what) and type is used with error messages only. */ STATIC SV * -S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, +S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv, const char *type) { - dSP; - HV *table = GvHV(PL_hintgv); /* ^H */ + dVAR; dSP; + HV * const table = GvHV(PL_hintgv); /* ^H */ SV *res; SV **cvp; SV *cv, *typesv; - const char *why1, *why2, *why3; + const char *why1 = "", *why2 = "", *why3 = ""; if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { SV *msg; @@ -6075,7 +9053,7 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s", (type ? type: "undef"), why1, why2, why3); msgdone: - yyerror(SvPVX(msg)); + yyerror(SvPVX_const(msg)); SvREFCNT_dec(msg); return sv; } @@ -6113,9 +9091,8 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, /* Check the eval first */ if (!PL_in_eval && SvTRUE(ERRSV)) { - STRLEN n_a; sv_catpv(ERRSV, "Propagated"); - yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */ + yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */ (void)POPs; res = SvREFCNT_inc(sv); } @@ -6140,11 +9117,14 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, return res; } +/* Returns a NUL terminated string, with the length of the string written to + *slp + */ STATIC char * S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) { register char *d = dest; - register char *e = d + destlen - 3; /* two-character token, ending NUL */ + register char * const e = d + destlen - 3; /* two-character token, ending NUL */ for (;;) { if (d >= e) Perl_croak(aTHX_ ident_too_long); @@ -6178,11 +9158,11 @@ S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_packag } STATIC char * -S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni) +S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni) { register char *d; register char *e; - char *bracket = 0; + char *bracket = Nullch; char funny = *s++; if (isSPACE(*s)) @@ -6233,7 +9213,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des return s; } if (*s == '$' && s[1] && - (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) ) + (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) ) { return s; } @@ -6253,7 +9233,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des if (bracket) { if (isSPACE(s[-1])) { while (s < send) { - char ch = *s++; + const char ch = *s++; if (!SPACE_OR_TAB(ch)) { *d = ch; break; @@ -6357,11 +9337,14 @@ STATIC char * S_scan_pat(pTHX_ char *start, I32 type) { PMOP *pm; - char *s; + char *s = scan_str(start,FALSE,FALSE); - s = scan_str(start,FALSE,FALSE); - if (!s) - Perl_croak(aTHX_ "Search pattern not terminated"); + if (!s) { + char * const delimiter = skipspace(start); + Perl_croak(aTHX_ *delimiter == '?' + ? "Search pattern not terminated or ternary operator parsed as search pattern" + : "Search pattern not terminated" ); + } pm = (PMOP*)newPMOP(type, 0); if (PL_multi_open == '?') @@ -6375,8 +9358,8 @@ S_scan_pat(pTHX_ char *start, I32 type) pmflag(&pm->op_pmflags,*s++); } /* issue a warning if /c is specified,but /g is not */ - if (ckWARN(WARN_REGEXP) && - (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)) + if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL) + && ckWARN(WARN_REGEXP)) { Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g); } @@ -6391,6 +9374,7 @@ S_scan_pat(pTHX_ char *start, I32 type) STATIC char * S_scan_subst(pTHX_ char *start) { + dVAR; register char *s; register PMOP *pm; I32 first_start; @@ -6430,7 +9414,7 @@ S_scan_subst(pTHX_ char *start) } /* /c is not meaningful with s/// */ - if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE)) + if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) { Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst); } @@ -6486,17 +9470,25 @@ S_scan_trans(pTHX_ char *start) } complement = del = squash = 0; - while (strchr("cds", *s)) { - if (*s == 'c') + while (1) { + switch (*s) { + case 'c': complement = OPpTRANS_COMPLEMENT; - else if (*s == 'd') + break; + case 'd': del = OPpTRANS_DELETE; - else if (*s == 's') + break; + case 's': squash = OPpTRANS_SQUASH; + break; + default: + goto no_more; + } s++; } + no_more: - New(803, tbl, complement&&!del?258:256, short); + Newx(tbl, complement&&!del?258:256, short); o = newPVOP(OP_TRANS, 0, (char*)tbl); o->op_private &= ~OPpTRANS_ALL; o->op_private |= del|squash|complement| @@ -6516,10 +9508,12 @@ S_scan_heredoc(pTHX_ register char *s) I32 len; SV *tmpstr; char term; + const char newline[] = "\n"; + const char *found_newline; register char *d; register char *e; char *peek; - int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR)); + const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR)); s += 2; d = PL_tokenbuf; @@ -6527,7 +9521,7 @@ S_scan_heredoc(pTHX_ register char *s) if (!outer) *d++ = '\n'; for (peek = s; SPACE_OR_TAB(*peek); peek++) ; - if (*peek && strchr("`'\"",*peek)) { + if (*peek == '`' || *peek == '\'' || *peek =='"') { s = peek; term = *s++; s = delimcpy(d, e, s, PL_bufend, term, &len); @@ -6555,7 +9549,7 @@ S_scan_heredoc(pTHX_ register char *s) #ifndef PERL_STRICT_CR d = strchr(s, '\r'); if (d) { - char *olds = s; + char * const olds = s; s = d; while (s < PL_bufend) { if (*s == '\r') { @@ -6572,26 +9566,28 @@ S_scan_heredoc(pTHX_ register char *s) } *d = '\0'; PL_bufend = d; - SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr)); + SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr)); s = olds; } #endif - d = "\n"; - if (outer || !(d=ninstr(s,PL_bufend,d,d+1))) - herewas = newSVpvn(s,PL_bufend-s); - else - s--, herewas = newSVpvn(s,d-s); + if ( outer || !(found_newline = ninstr(s,PL_bufend,newline,newline+1)) ) { + herewas = newSVpvn(s,PL_bufend-s); + } + else { + s--; + herewas = newSVpvn(s,found_newline-s); + } s += SvCUR(herewas); tmpstr = NEWSV(87,79); sv_upgrade(tmpstr, SVt_PVIV); if (term == '\'') { op_type = OP_CONST; - SvIVX(tmpstr) = -1; + SvIV_set(tmpstr, -1); } else if (term == '`') { op_type = OP_BACKTICK; - SvIVX(tmpstr) = '\\'; + SvIV_set(tmpstr, '\\'); } CLINE; @@ -6601,7 +9597,7 @@ S_scan_heredoc(pTHX_ register char *s) if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) { char *bufptr = PL_sublex_info.super_bufptr; char *bufend = PL_sublex_info.super_bufend; - char *olds = s - SvCUR(herewas); + char * const olds = s - SvCUR(herewas); s = strchr(bufptr, '\n'); if (!s) s = bufend; @@ -6619,7 +9615,7 @@ S_scan_heredoc(pTHX_ register char *s) sv_setpvn(tmpstr,d+1,s-d); s += len - 1; sv_catpvn(herewas,s,bufend-s); - (void)strcpy(bufptr,SvPVX(herewas)); + Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char); s = olds; goto retval; @@ -6663,7 +9659,7 @@ S_scan_heredoc(pTHX_ register char *s) { PL_bufend[-2] = '\n'; PL_bufend--; - SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr)); + SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr)); } else if (PL_bufend[-1] == '\r') PL_bufend[-1] = '\n'; @@ -6677,14 +9673,15 @@ S_scan_heredoc(pTHX_ register char *s) sv_upgrade(sv, SVt_PVMG); sv_setsv(sv,PL_linestr); (void)SvIOK_on(sv); - SvIVX(sv) = 0; + SvIV_set(sv, 0); av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv); } if (*s == term && memEQ(s,PL_tokenbuf,len)) { - s = PL_bufend - 1; - *s = ' '; + STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr); + *(SvPVX(PL_linestr) + off ) = ' '; sv_catsv(PL_linestr,herewas); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */ } else { s = PL_bufend; @@ -6695,12 +9692,11 @@ S_scan_heredoc(pTHX_ register char *s) retval: PL_multi_end = CopLINE(PL_curcop); if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) { - SvLEN_set(tmpstr, SvCUR(tmpstr) + 1); - Renew(SvPVX(tmpstr), SvLEN(tmpstr), char); + SvPV_shrink_to_cur(tmpstr); } SvREFCNT_dec(herewas); if (!IN_BYTES) { - if (UTF && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr))) + if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr))) SvUTF8_on(tmpstr); else if (PL_encoding) sv_recode_to_utf8(tmpstr, PL_encoding); @@ -6731,7 +9727,7 @@ S_scan_inputsymbol(pTHX_ char *start) { register char *s = start; /* current position in buffer */ register char *d; - register char *e; + const char *e; char *end; I32 len; @@ -6789,7 +9785,7 @@ S_scan_inputsymbol(pTHX_ char *start) /* turn <> into */ if (!len) - (void)strcpy(d,"ARGV"); + Copy("ARGV",d,5,char); /* Check whether readline() is overriden */ if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV)) @@ -6811,8 +9807,9 @@ S_scan_inputsymbol(pTHX_ char *start) */ if ((tmp = pad_findmy(d)) != NOT_IN_PAD) { if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) { - SV *sym = sv_2mortal( - newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)),0)); + HV *stash = PAD_COMPNAME_OURSTASH(tmp); + HEK *stashname = HvNAME_HEK(stash); + SV *sym = sv_2mortal(newSVhek(stashname)); sv_catpvn(sym, "::", 2); sv_catpv(sym, d+1); d = SvPVX(sym); @@ -6924,7 +9921,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) I32 brackets = 1; /* bracket nesting level */ bool has_utf8 = FALSE; /* is there any utf8 content? */ I32 termcode; /* terminating char. code */ - U8 termstr[UTF8_MAXLEN]; /* terminating string */ + U8 termstr[UTF8_MAXBYTES]; /* terminating string */ STRLEN termlen; /* length of terminating string */ char *last = NULL; /* last position for nesting bracket */ @@ -6962,7 +9959,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) assuming. 79 is the SV's initial length. What a random number. */ sv = NEWSV(87,79); sv_upgrade(sv, SVt_PVIV); - SvIVX(sv) = termcode; + SvIV_set(sv, termcode); (void)SvPOK_only(sv); /* validate pointer */ /* move past delimiter and try to read a complete string */ @@ -6974,10 +9971,10 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) bool cont = TRUE; while (cont) { - int offset = s - SvPVX(PL_linestr); - bool found = sv_cat_decode(sv, PL_encoding, PL_linestr, + int offset = s - SvPVX_const(PL_linestr); + const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr, &offset, (char*)termstr, termlen); - char *ns = SvPVX(PL_linestr) + offset; + const char *ns = SvPVX_const(PL_linestr) + offset; char *svlast = SvEND(sv) - 1; for (; s < ns; s++) { @@ -6989,8 +9986,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) else { /* handle quoted delimiters */ if (SvCUR(sv) > 1 && *(svlast-1) == '\\') { - char *t; - for (t = svlast-2; t >= SvPVX(sv) && *t == '\\';) + const char *t; + for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';) t--; if ((svlast-1 - t) % 2) { if (!keep_quoted) { @@ -7005,10 +10002,11 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) cont = FALSE; } else { - char *t, *w; + const char *t; + char *w; if (!last) last = SvPVX(sv); - for (w = t = last; t < svlast; w++, t++) { + for (t = w = last; t < svlast; w++, t++) { /* At here, all closes are "was quoted" one, so we don't check PL_multi_close. */ if (*t == '\\') { @@ -7025,7 +10023,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) if (w < t) { *w++ = term; *w = '\0'; - SvCUR_set(sv, w - SvPVX(sv)); + SvCUR_set(sv, w - SvPVX_const(sv)); } last = w; if (--brackets <= 0) @@ -7103,7 +10101,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) } /* terminate the copied string and update the sv's end-of-string */ *to = '\0'; - SvCUR_set(sv, to - SvPVX(sv)); + SvCUR_set(sv, to - SvPVX_const(sv)); /* * this next chunk reads more into the buffer if we're not done yet @@ -7113,18 +10111,18 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) break; /* handle case where we are done yet :-) */ #ifndef PERL_STRICT_CR - if (to - SvPVX(sv) >= 2) { + if (to - SvPVX_const(sv) >= 2) { if ((to[-2] == '\r' && to[-1] == '\n') || (to[-2] == '\n' && to[-1] == '\r')) { to[-2] = '\n'; to--; - SvCUR_set(sv, to - SvPVX(sv)); + SvCUR_set(sv, to - SvPVX_const(sv)); } else if (to[-1] == '\r') to[-1] = '\n'; } - else if (to - SvPVX(sv) == 1 && to[-1] == '\r') + else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r') to[-1] = '\n'; #endif @@ -7148,7 +10146,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) sv_upgrade(sv, SVt_PVMG); sv_setsv(sv,PL_linestr); (void)SvIOK_on(sv); - SvIVX(sv) = 0; + SvIV_set(sv, 0); av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv); } @@ -7172,7 +10170,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* if we allocated too much space, give some back */ if (SvCUR(sv) + 5 < SvLEN(sv)) { SvLEN_set(sv, SvCUR(sv) + 1); - Renew(SvPVX(sv), SvLEN(sv), char); + SvPV_renew(sv, SvLEN(sv)); } /* decide whether this is the first or second quoted string we've read @@ -7209,16 +10207,16 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) */ char * -Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) +Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) { - register char *s = start; /* current position in buffer */ + register const char *s = start; /* current position in buffer */ register char *d; /* destination in temp buffer */ register char *e; /* end of temp buffer */ NV nv; /* number read, as a double */ SV *sv = Nullsv; /* place to put the converted number */ bool floatit; /* boolean: int or float? */ - char *lastub = 0; /* position of last underbar */ - static char number_too_long[] = "Number too long"; + const char *lastub = 0; /* position of last underbar */ + static char const number_too_long[] = "Number too long"; /* We use the first character to decide what type of number this is */ @@ -7245,17 +10243,18 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) I32 shift; bool overflowed = FALSE; bool just_zero = TRUE; /* just plain 0 or binary number? */ - static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 }; - static char* bases[5] = { "", "binary", "", "octal", - "hexadecimal" }; - static char* Bases[5] = { "", "Binary", "", "Octal", - "Hexadecimal" }; - static char *maxima[5] = { "", - "0b11111111111111111111111111111111", - "", - "037777777777", - "0xffffffff" }; - char *base, *Base, *max; + static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 }; + static const char* const bases[5] = + { "", "binary", "", "octal", "hexadecimal" }; + static const char* const Bases[5] = + { "", "Binary", "", "Octal", "Hexadecimal" }; + static const char* const maxima[5] = + { "", + "0b11111111111111111111111111111111", + "", + "037777777777", + "0xffffffff" }; + const char *base, *Base, *max; /* check for hex */ if (s[1] == 'x') { @@ -7301,7 +10300,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) /* _ are ignored -- but warned about if consecutive */ case '_': - if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) + if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s++; @@ -7381,7 +10380,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) sv = NEWSV(92,0); if (overflowed) { - if (ckWARN(WARN_PORTABLE) && n > 4294967295.0) + if (n > 4294967295.0 && ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ packWARN(WARN_PORTABLE), "%s number > %s non-portable", Base, max); @@ -7389,7 +10388,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) } else { #if UVSIZE > 4 - if (ckWARN(WARN_PORTABLE) && u > 0xffffffff) + if (u > 0xffffffff && ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ packWARN(WARN_PORTABLE), "%s number > %s non-portable", Base, max); @@ -7397,7 +10396,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) sv_setuv(sv, u); } if (just_zero && (PL_hints & HINT_NEW_INTEGER)) - sv = new_constant(start, s - start, "integer", + sv = new_constant(start, s - start, "integer", sv, Nullsv, NULL); else if (PL_hints & HINT_NEW_BINARY) sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL); @@ -7421,7 +10420,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) if -w is on */ if (*s == '_') { - if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) + if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s++; @@ -7463,7 +10462,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) if (d >= e) Perl_croak(aTHX_ number_too_long); if (*s == '_') { - if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) + if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s; @@ -7485,7 +10484,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) } /* read exponent part, if present */ - if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) { + if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) { floatit = TRUE; s++; @@ -7520,9 +10519,9 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) *d++ = *s++; } else { - if (ckWARN(WARN_SYNTAX) && - ((lastub && s == lastub + 1) || - (!isDIGIT(s[1]) && s[1] != '_'))) + if (((lastub && s == lastub + 1) || + (!isDIGIT(s[1]) && s[1] != '_')) + && ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s++; @@ -7585,7 +10584,7 @@ vstring: else lvalp->opval = Nullop; - return s; + return (char *)s; } STATIC char * @@ -7599,7 +10598,6 @@ S_scan_formline(pTHX_ register char *s) while (!needargs) { if (*s == '.') { - /*SUPPRESS 530*/ #ifdef PERL_STRICT_CR for (t = s+1;SPACE_OR_TAB(*t); t++) ; #else @@ -7611,7 +10609,7 @@ S_scan_formline(pTHX_ register char *s) } } if (PL_in_eval && !PL_rsfp) { - eol = memchr(s,'\n',PL_bufend-s); + eol = (char *) memchr(s,'\n',PL_bufend-s); if (!eol++) eol = PL_bufend; } @@ -7633,14 +10631,14 @@ S_scan_formline(pTHX_ register char *s) char *end = SvPVX(stuff) + SvCUR(stuff); end[-2] = '\n'; end[-1] = '\0'; - SvCUR(stuff)--; + SvCUR_set(stuff, SvCUR(stuff) - 1); } #endif } else break; } - s = eol; + s = (char*)eol; if (PL_rsfp) { s = filter_gets(PL_linestr, PL_rsfp, 0); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); @@ -7664,7 +10662,7 @@ S_scan_formline(pTHX_ register char *s) else PL_lex_state = LEX_FORMLINE; if (!IN_BYTES) { - if (UTF && is_utf8_string((U8*)SvPVX(stuff), SvCUR(stuff))) + if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff))) SvUTF8_on(stuff); else if (PL_encoding) sv_recode_to_utf8(stuff, PL_encoding); @@ -7695,7 +10693,7 @@ S_set_csh(pTHX) I32 Perl_start_subparse(pTHX_ I32 is_format, U32 flags) { - I32 oldsavestack_ix = PL_savestack_ix; + const I32 oldsavestack_ix = PL_savestack_ix; CV* outsidecv = PL_compcv; if (PL_compcv) { @@ -7721,7 +10719,7 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) #pragma segment Perl_yylex #endif int -Perl_yywarn(pTHX_ char *s) +Perl_yywarn(pTHX_ const char *s) { PL_in_eval |= EVAL_WARNONLY; yyerror(s); @@ -7730,17 +10728,18 @@ Perl_yywarn(pTHX_ char *s) } int -Perl_yyerror(pTHX_ char *s) +Perl_yyerror(pTHX_ const char *s) { - char *where = NULL; - char *context = NULL; + const char *where = NULL; + const char *context = NULL; int contlen = -1; SV *msg; if (!yychar || (yychar == ';' && !PL_rsfp)) where = "at EOF"; - else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 && - PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) { + else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr && + PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr && + PL_oldbufptr != PL_bufptr) { /* Only for NetWare: The code below is removed for NetWare because it abends/crashes on NetWare @@ -7755,8 +10754,8 @@ Perl_yyerror(pTHX_ char *s) context = PL_oldoldbufptr; contlen = PL_bufptr - PL_oldoldbufptr; } - else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 && - PL_oldbufptr != PL_bufptr) { + else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr && + PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) { /* Only for NetWare: The code below is removed for NetWare because it abends/crashes on NetWare @@ -7790,7 +10789,7 @@ Perl_yyerror(pTHX_ char *s) Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar); else Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255); - where = SvPVX(where_sv); + where = SvPVX_const(where_sv); } msg = sv_2mortal(newSVpv(s, 0)); Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ", @@ -7828,74 +10827,93 @@ Perl_yyerror(pTHX_ char *s) STATIC char* S_swallow_bom(pTHX_ U8 *s) { - STRLEN slen; - slen = SvCUR(PL_linestr); - switch (*s) { + const STRLEN slen = SvCUR(PL_linestr); + switch (s[0]) { case 0xFF: if (s[1] == 0xFE) { - /* UTF-16 little-endian */ + /* UTF-16 little-endian? (or UTF32-LE?) */ if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */ - Perl_croak(aTHX_ "Unsupported script encoding"); + Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE"); #ifndef PERL_NO_UTF16_FILTER - DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n")); + if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n"); s += 2; + utf16le: if (PL_bufend > (char*)s) { U8 *news; I32 newlen; filter_add(utf16rev_textfilter, NULL); - New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); - PL_bufend = (char*)utf16_to_utf8_reversed(s, news, - PL_bufend - (char*)s - 1, - &newlen); - Copy(news, s, newlen, U8); - SvCUR_set(PL_linestr, newlen); - PL_bufend = SvPVX(PL_linestr) + newlen; - news[newlen++] = '\0'; + Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); + utf16_to_utf8_reversed(s, news, + PL_bufend - (char*)s - 1, + &newlen); + sv_setpvn(PL_linestr, (const char*)news, newlen); Safefree(news); + SvUTF8_on(PL_linestr); + s = (U8*)SvPVX(PL_linestr); + PL_bufend = SvPVX(PL_linestr) + newlen; } #else - Perl_croak(aTHX_ "Unsupported script encoding"); + Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE"); #endif } break; case 0xFE: - if (s[1] == 0xFF) { /* UTF-16 big-endian */ + if (s[1] == 0xFF) { /* UTF-16 big-endian? */ #ifndef PERL_NO_UTF16_FILTER - DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n")); + if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n"); s += 2; + utf16be: if (PL_bufend > (char *)s) { U8 *news; I32 newlen; filter_add(utf16_textfilter, NULL); - New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); - PL_bufend = (char*)utf16_to_utf8(s, news, - PL_bufend - (char*)s, - &newlen); - Copy(news, s, newlen, U8); - SvCUR_set(PL_linestr, newlen); - PL_bufend = SvPVX(PL_linestr) + newlen; - news[newlen++] = '\0'; + Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); + utf16_to_utf8(s, news, + PL_bufend - (char*)s, + &newlen); + sv_setpvn(PL_linestr, (const char*)news, newlen); Safefree(news); + SvUTF8_on(PL_linestr); + s = (U8*)SvPVX(PL_linestr); + PL_bufend = SvPVX(PL_linestr) + newlen; } #else - Perl_croak(aTHX_ "Unsupported script encoding"); + Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE"); #endif } break; case 0xEF: if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) { - DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n")); + if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n"); s += 3; /* UTF-8 */ } break; case 0: - if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */ - s[2] == 0xFE && s[3] == 0xFF) - { - Perl_croak(aTHX_ "Unsupported script encoding"); + if (slen > 3) { + if (s[1] == 0) { + if (s[2] == 0xFE && s[3] == 0xFF) { + /* UTF-32 big-endian */ + Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE"); + } + } + else if (s[2] == 0 && s[3] != 0) { + /* Leading bytes + * 00 xx 00 xx + * are a good indicator of UTF-16BE. */ + if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n"); + goto utf16be; + } } + default: + if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) { + /* Leading bytes + * xx 00 xx 00 + * are a good indicator of UTF-16LE. */ + if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n"); + goto utf16le; + } } return (char*)s; } @@ -7921,38 +10939,42 @@ restore_rsfp(pTHX_ void *f) static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) { - I32 count = FILTER_READ(idx+1, sv, maxlen); + const STRLEN old = SvCUR(sv); + const I32 count = FILTER_READ(idx+1, sv, maxlen); + DEBUG_P(PerlIO_printf(Perl_debug_log, + "utf16_textfilter(%p): %d %d (%d)\n", + utf16_textfilter, idx, maxlen, (int) count)); if (count) { U8* tmps; - U8* tend; I32 newlen; - New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); - 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); + Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8); + Copy(SvPVX_const(sv), tmps, old, char); + utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old, + SvCUR(sv) - old, &newlen); + sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old); } - return count; + DEBUG_P({sv_dump(sv);}); + return SvCUR(sv); } static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen) { - I32 count = FILTER_READ(idx+1, sv, maxlen); + const STRLEN old = SvCUR(sv); + const I32 count = FILTER_READ(idx+1, sv, maxlen); + DEBUG_P(PerlIO_printf(Perl_debug_log, + "utf16rev_textfilter(%p): %d %d (%d)\n", + utf16rev_textfilter, idx, maxlen, (int) count)); if (count) { U8* tmps; - U8* tend; I32 newlen; - if (!*SvPV_nolen(sv)) - /* Game over, but don't feed an odd-length string to utf16_to_utf8 */ - return count; - - New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); - tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen); - sv_usepvn(sv, (char*)tmps, tend - tmps); + Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8); + Copy(SvPVX_const(sv), tmps, old, char); + utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old, + SvCUR(sv) - old, &newlen); + sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old); } + DEBUG_P({ sv_dump(sv); }); return count; } #endif @@ -7972,28 +10994,28 @@ passed in, for performance reasons. */ char * -Perl_scan_vstring(pTHX_ char *s, SV *sv) +Perl_scan_vstring(pTHX_ const char *s, SV *sv) { - char *pos = s; - char *start = s; + const char *pos = s; + const char *start = s; if (*pos == 'v') pos++; /* get past 'v' */ while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_')) pos++; if ( *pos != '.') { /* this may not be a v-string if followed by => */ - char *next = pos; + const char *next = pos; while (next < PL_bufend && isSPACE(*next)) ++next; if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) { /* return string not v-string */ sv_setpvn(sv,(char *)s,pos-s); - return pos; + return (char *)pos; } } if (!isALPHA(*pos)) { UV rev; - U8 tmpbuf[UTF8_MAXLEN+1]; + U8 tmpbuf[UTF8_MAXBYTES+1]; U8 *tmpend; if (*s == 'v') s++; /* get past 'v' */ @@ -8004,7 +11026,7 @@ Perl_scan_vstring(pTHX_ char *s, SV *sv) rev = 0; { /* this is atoi() that tolerates underscores */ - char *end = pos; + const char *end = pos; UV mult = 1; while (--end >= s) { UV orev; @@ -8040,6 +11062,15 @@ Perl_scan_vstring(pTHX_ char *s, SV *sv) sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start); SvRMAGICAL_on(sv); } - return s; + return (char *)s; } +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */