/* toke.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 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. * */ /* * "It all comes from here, the stench and the peril." --Frodo */ /* * This file is the lexer for Perl. It's closely linked to the * parser, perly.y. * * The main routine is yylex(), which returns the next token. */ #include "EXTERN.h" #define PERL_IN_TOKE_C #include "perl.h" #define yychar (*PL_yycharp) #define yylval (*PL_yylvalp) static const char ident_too_long[] = "Identifier too long"; static const char c_without_g[] = "Use of /c modifier is meaningless without /g"; static const char c_in_subst[] = "Use of /c modifier is meaningless in s///"; static void restore_rsfp(pTHX_ void *f); #ifndef PERL_NO_UTF16_FILTER static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen); static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen); #endif #define XFAKEBRACK 128 #define XENUMMASK 127 #ifdef USE_UTF8_SCRIPTS # define UTF (!IN_BYTES) #else # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8)) #endif /* In variables named $^X, these are the legal values for X. * 1999-02-27 mjd-perl-patch@plover.com */ #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x))) /* On MacOS, respect nonbreaking spaces */ #ifdef MACOS_TRADITIONAL #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t') #else #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t') #endif /* LEX_* are values for PL_lex_state, the state of the lexer. * They are arranged oddly so that the guard on the switch statement * can get by with a single comparison (if the compiler is smart enough). */ /* #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 #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 #endif #include "keywords.h" /* CLINE is a macro that ensures PL_copline has a sane value */ #ifdef CLINE #undef CLINE #endif #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline)) /* * Convenience functions to return different tokens and prime the * lexer for the next token. They all take an argument. * * TOKEN : generic token (used for '(', DOLSHARP, etc) * OPERATOR : generic operator * AOPERATOR : assignment operator * PREBLOCK : beginning the block after an if, while, foreach, ... * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref) * PREREF : *EXPR where EXPR is not a simple identifier * TERM : expression term * LOOPX : loop exiting command (goto, last, dump, etc) * FTST : file test operator * FUN0 : zero-argument function * FUN1 : not used, except for not, which isn't a UNIOP * BOop : bitwise or or xor * BAop : bitwise and * SHop : shift operator * PWop : power operator * PMop : pattern-matching operator * Aop : addition-level operator * Mop : multiplication-level operator * Eop : equality-testing operator * Rop : relational operator <= != gt * * Also see LOP and lop() below. */ #ifdef DEBUGGING /* Serve -DT. */ # define REPORT(retval) tokereport(s,(int)retval) #else # define REPORT(retval) (retval) #endif #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) { \ 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) { \ 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 /* 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[] = { { 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 */ STATIC int S_tokereport(pTHX_ const char* s, I32 rv) 38799749 { 38799749 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]); else ###### Perl_sv_catpv(aTHX_ report, "(opval=null)"); break; } ###### Perl_sv_catpvf(aTHX_ report, " at line %"IVdf" [", (IV)CopLINE(PL_curcop)); ###### 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_const(report)); }; 38799749 return (int)rv; } #endif /* * S_ao * * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN */ STATIC int S_ao(pTHX_ int toketype) 1092246 { 1092246 if (*PL_bufptr == '=') { 119912 PL_bufptr++; 119912 if (toketype == ANDAND) 21 yylval.ival = OP_ANDASSIGN; 119891 else if (toketype == OROR) 25020 yylval.ival = OP_ORASSIGN; 94871 else if (toketype == DORDOR) 6 yylval.ival = OP_DORASSIGN; 119912 toketype = ASSIGNOP; } 1092246 return toketype; } /* * S_no_op * When Perl expects an operator and finds something else, no_op * prints the warning. It always prints " found where * operator expected. It prints "Missing semicolon on previous line?" * if the surprise occurs at the start of the line. "do you need to * predeclare ..." is printed out for code like "sub bar; foo bar $x" * where the compiler doesn't know if foo is a method call or a function. * It prints "Missing operator before end of line" if there's nothing * after the missing operator, or "... before <...>" if there is something * after the missing operator. */ STATIC void S_no_op(pTHX_ const char *what, char *s) 15 { 15 char * const oldbp = PL_bufptr; 15 const bool is_first = (PL_oldbufptr == PL_linestart); 15 if (!s) ###### s = oldbp; else 15 PL_bufptr = s; 15 yywarn(Perl_form(aTHX_ "%s found where operator expected", what)); 15 if (ckWARN_d(WARN_SYNTAX)) { 14 if (is_first) ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\t(Missing semicolon on previous line?)\n"); 14 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) { 13 const char *t; 13 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ; 13 if (t < PL_bufptr && isSPACE(*t)) 3 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\t(Do you need to predeclare %.*s?)\n", t - PL_oldoldbufptr, PL_oldoldbufptr); } else { 1 assert(s >= oldbp); 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp); } } 15 PL_bufptr = oldbp; } /* * S_missingterm * Complain about missing quote/regexp/heredoc terminator. * If it's called with (char *)NULL then it cauterizes the line buffer. * If we're in a delimited string and the delimiter is a control * character, it's reformatted into a two-char sequence like ^C. * This is fatal. */ STATIC void S_missingterm(pTHX_ char *s) 4 { 4 char tmpbuf[3]; 4 char q; 4 if (s) { ###### char * const nl = strrchr(s,'\n'); ###### if (nl) ###### *nl = '\0'; } 4 else if ( #ifdef EBCDIC iscntrl(PL_multi_close) #else PL_multi_close < 32 || PL_multi_close == 127 #endif ) { ###### *tmpbuf = '^'; ###### tmpbuf[1] = toCTRL(PL_multi_close); ###### tmpbuf[2] = '\0'; ###### s = tmpbuf; } else { 4 *tmpbuf = (char)PL_multi_close; 4 tmpbuf[1] = '\0'; 4 s = tmpbuf; } 4 q = strchr(s,'"') ? '\'' : '"'; 4 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q); } /* * Perl_deprecate */ void Perl_deprecate(pTHX_ const char *s) 40 { 40 if (ckWARN(WARN_DEPRECATED)) 9 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s); } void Perl_deprecate_old(pTHX_ const char *s) 25 { /* This function should NOT be called for any new deprecated warnings */ /* Use Perl_deprecate instead */ /* */ /* It is here to maintain backward compatibility with the pre-5.8 */ /* warnings category hierarchy. The "deprecated" category used to */ /* live under the "syntax" category. It is now a top-level category */ /* in its own right. */ 25 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) 6 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of %s is deprecated", s); } /* * depcom * Deprecate a comma-less variable list. */ STATIC void S_depcom(pTHX) 6 { 6 deprecate_old("comma-less variable list"); } /* * experimental text filters for win32 carriage-returns, utf16-to-utf8 and * utf16-to-utf8-reversed. */ #ifdef PERL_CR_FILTER static void strip_return(SV *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') { /* hit a CR-LF, need to copy the rest */ register char *d = s - 1; *d++ = *s++; while (s < e) { if (*s == '\r' && s[1] == '\n') s++; *d++ = *s++; } SvCUR(sv) -= s - d; return; } } } STATIC I32 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) { const I32 count = FILTER_READ(idx+1, sv, maxlen); if (count > 0 && !maxlen) strip_return(sv); return count; } #endif /* * Perl_lex_start * Initialize variables. Uses the Perl save_stack to save its state (for * recursive calls to the parser). */ void Perl_lex_start(pTHX_ SV *line) 106267 { 106267 const char *s; 106267 STRLEN len; 106267 SAVEI32(PL_lex_dojoin); 106267 SAVEI32(PL_lex_brackets); 106267 SAVEI32(PL_lex_casemods); 106267 SAVEI32(PL_lex_starts); 106267 SAVEI32(PL_lex_state); 106267 SAVEVPTR(PL_lex_inpat); 106267 SAVEI32(PL_lex_inwhat); 106267 if (PL_lex_state == LEX_KNOWNEXT) { 23 I32 toke = PL_nexttoke; 46 while (--toke >= 0) { 23 SAVEI32(PL_nexttype[toke]); 23 SAVEVPTR(PL_nextval[toke]); } 23 SAVEI32(PL_nexttoke); } 106267 SAVECOPLINE(PL_curcop); 106267 SAVEPPTR(PL_bufptr); 106267 SAVEPPTR(PL_bufend); 106267 SAVEPPTR(PL_oldbufptr); 106267 SAVEPPTR(PL_oldoldbufptr); 106267 SAVEPPTR(PL_last_lop); 106267 SAVEPPTR(PL_last_uni); 106267 SAVEPPTR(PL_linestart); 106267 SAVESPTR(PL_linestr); 106267 SAVEGENERICPV(PL_lex_brackstack); 106267 SAVEGENERICPV(PL_lex_casestack); 106267 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp); 106267 SAVESPTR(PL_lex_stuff); 106267 SAVEI32(PL_lex_defer); 106267 SAVEI32(PL_sublex_info.sub_inwhat); 106267 SAVESPTR(PL_lex_repl); 106267 SAVEINT(PL_expect); 106267 SAVEINT(PL_lex_expect); 106267 PL_lex_state = LEX_NORMAL; 106267 PL_lex_defer = 0; 106267 PL_expect = XSTATE; 106267 PL_lex_brackets = 0; 106267 New(899, PL_lex_brackstack, 120, char); 106267 New(899, PL_lex_casestack, 12, char); 106267 PL_lex_casemods = 0; 106267 *PL_lex_casestack = '\0'; 106267 PL_lex_dojoin = 0; 106267 PL_lex_starts = 0; 106267 PL_lex_stuff = Nullsv; 106267 PL_lex_repl = Nullsv; 106267 PL_lex_inpat = 0; 106267 PL_nexttoke = 0; 106267 PL_lex_inwhat = 0; 106267 PL_sublex_info.sub_inwhat = 0; 106267 PL_linestr = line; 106267 if (SvREADONLY(PL_linestr)) 1753 PL_linestr = sv_2mortal(newSVsv(PL_linestr)); 106267 s = SvPV_const(PL_linestr, len); 106267 if (!len || s[len-1] != ';') { 82525 if (!(SvFLAGS(PL_linestr) & SVs_TEMP)) 45556 PL_linestr = sv_2mortal(newSVsv(PL_linestr)); 82525 sv_catpvn(PL_linestr, "\n;", 2); } 106267 SvTEMP_off(PL_linestr); 106267 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); 106267 PL_bufend = PL_bufptr + SvCUR(PL_linestr); 106267 PL_last_lop = PL_last_uni = Nullch; 106267 PL_rsfp = 0; } /* * Perl_lex_end * Finalizer for lexing operations. Must be called when the parser is * done with the lexer. */ void Perl_lex_end(pTHX) 100659 { 100659 PL_doextract = FALSE; } /* * S_incline * This subroutine has nothing to do with tilting, whether at windmills * or pinball tables. Its name is short for "increment line". It * increments the current line number in CopLINE(PL_curcop) and checks * to see whether the line starts with a comment of the form * # line 500 "foo.pm" * If so, it sets the current line number and file to the values in the comment. */ STATIC void S_incline(pTHX_ char *s) 8682471 { 8682471 char *t; 8682471 char *n; 8682471 char *e; 8682471 char ch; 8682471 CopLINE_inc(PL_curcop); 8682471 if (*s++ != '#') 8346618 return; 750322 while (SPACE_OR_TAB(*s)) s++; 335853 if (strnEQ(s, "line", 4)) 819 s += 4; else 819 return; 819 if (SPACE_OR_TAB(*s)) 806 s++; else 806 return; 806 while (SPACE_OR_TAB(*s)) s++; 806 if (!isDIGIT(*s)) 806 return; 806 n = s; 2049 while (isDIGIT(*s)) 1243 s++; 1006 while (SPACE_OR_TAB(*s)) 200 s++; 806 if (*s == '"' && (t = strchr(s+1, '"'))) { 200 s++; 200 e = t + 1; } else { 606 for (t = s; !isSPACE(*t); t++) ; 606 e = t; } 806 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f') ###### e++; 806 if (*e != '\n' && *e != '\0') ###### return; /* false alarm */ 806 ch = *t; 806 *t = '\0'; 806 if (t - s > 0) { 200 CopFILE_free(PL_curcop); 200 CopFILE_set(PL_curcop, s); } 806 *t = ch; 806 CopLINE_set(PL_curcop, atoi(n)-1); } /* * S_skipspace * Called to gobble the appropriate amount and type of whitespace. * Skips comments as well. */ STATIC char * S_skipspace(pTHX_ register char *s) 12968792 { 12968792 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { 556 while (s < PL_bufend && SPACE_OR_TAB(*s)) 63 s++; 493 return s; } 13174635 for (;;) { 13174634 STRLEN prevlen; 13174634 SSize_t oldprevlen, oldoldprevlen; 13174634 SSize_t oldloplen = 0, oldunilen = 0; 19417590 while (s < PL_bufend && isSPACE(*s)) { 6242956 if (*s++ == '\n' && PL_in_eval && !PL_rsfp) 31760 incline(s); } /* comment */ 13174634 if (s < PL_bufend && *s == '#') { 687852 while (s < PL_bufend && *s != '\n') 671612 s++; 16240 if (s < PL_bufend) { 16240 s++; 16240 if (PL_in_eval && !PL_rsfp) { 178 incline(s); 178 continue; } } } /* only continue to recharge the buffer if we're at the end * of the buffer, we're not reading from a source filter, and * we're in normal lexing mode */ 13174456 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE) 12966516 return s; /* try to recharge the buffer */ 207940 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) { /* end of file. Add on the -p or -n magic */ 1783 if (PL_minus_p) { ###### sv_setpv(PL_linestr, ";}continue{print or die qq(-p destination: $!\\n);}"); ###### PL_minus_n = PL_minus_p = 0; } 1783 else if (PL_minus_n) { 4 sv_setpvn(PL_linestr, ";}", 2); 4 PL_minus_n = 0; } else 1779 sv_setpvn(PL_linestr,";", 1); /* reset variables for next time we lex */ 1783 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr); 1783 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 1783 PL_last_lop = PL_last_uni = Nullch; /* Close the filehandle. Could be from -P preprocessor, * STDIN, or a regular file. If we were reading code from * STDIN (because the commandline held no -e or filename) * then we don't close it, we reset it so the code can * read from STDIN too. */ 1783 if (PL_preprocess && !PL_in_eval) ###### (void)PerlProc_pclose(PL_rsfp); 1783 else if ((PerlIO*)PL_rsfp == PerlIO_stdin()) ###### PerlIO_clearerr(PL_rsfp); else 1783 (void)PerlIO_close(PL_rsfp); 1783 PL_rsfp = Nullfp; 1783 return s; } /* not at end of file, so we only read another line */ /* make corresponding updates to old pointers, for yyerror() */ 206157 oldprevlen = PL_oldbufptr - PL_bufend; 206157 oldoldprevlen = PL_oldoldbufptr - PL_bufend; 206157 if (PL_last_uni) 23524 oldunilen = PL_last_uni - PL_bufend; 206157 if (PL_last_lop) 18980 oldloplen = PL_last_lop - PL_bufend; 206157 PL_linestart = PL_bufptr = s + prevlen; 206157 PL_bufend = s + SvCUR(PL_linestr); 206157 s = PL_bufptr; 206157 PL_oldbufptr = s + oldprevlen; 206157 PL_oldoldbufptr = s + oldoldprevlen; 206157 if (PL_last_uni) 23524 PL_last_uni = s + oldunilen; 206157 if (PL_last_lop) 18980 PL_last_lop = s + oldloplen; 206157 incline(s); /* debugger active and we're not compiling the debugger code, * so store the line into the debugger's array of lines */ 206157 if (PERLDB_LINE && PL_curstash != PL_debstash) { 1 SV * const sv = NEWSV(85,0); 1 sv_upgrade(sv, SVt_PVMG); 1 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr); 1 (void)SvIOK_on(sv); 1 SvIV_set(sv, 0); 1 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); } } } /* * S_check_uni * Check the unary operators to ensure there's no ambiguity in how they're * used. An ambiguous piece of code would be: * rand + 5 * This doesn't mean rand() + 5. Because rand() is a unary operator, * the +5 is its argument. */ STATIC void S_check_uni(pTHX) 14098 { 14098 char *s; 14098 char *t; 14098 if (PL_oldoldbufptr != PL_last_uni) 14059 return; 50 while (isSPACE(*PL_last_uni)) 11 PL_last_uni++; 39 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ; 39 if ((t = strchr(s, '(')) && t < PL_bufptr) 33 return; 6 if (ckWARN_d(WARN_AMBIGUOUS)){ 5 const char ch = *s; 5 *s = '\0'; 5 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Warning: Use of \"%s\" without parentheses is ambiguous", PL_last_uni); 5 *s = ch; } } /* * LOP : macro to build a list operator. Its behaviour has been replaced * with a subroutine, S_lop() for which LOP is just another name. */ #define LOP(f,x) return lop(f,x,s) /* * S_lop * Build a list operator (or something that might be one). The rules: * - if we have a next token, then it's a list operator [why?] * - if the next thing is an opening paren, then it's a function * - else it's a list operator */ STATIC I32 S_lop(pTHX_ I32 f, int x, char *s) 379099 { 379099 yylval.ival = f; 379099 CLINE; 379099 PL_expect = x; 379099 PL_bufptr = s; 379099 PL_last_lop = PL_oldbufptr; 379099 PL_last_lop_op = (OPCODE)f; 379099 if (PL_nexttoke) 224 return REPORT(LSTOP); 378875 if (*s == '(') 144139 return REPORT(FUNC); 234736 s = skipspace(s); 234736 if (*s == '(') 8428 return REPORT(FUNC); else 226308 return REPORT(LSTOP); } /* * S_force_next * When the lexer realizes it knows the next token (for instance, * it is reordering tokens for the parser) then it can call S_force_next * to know what token to return the next time the lexer is called. Caller * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer * handles the token correctly. */ STATIC void S_force_next(pTHX_ I32 type) 4267093 { 4267093 PL_nexttype[PL_nexttoke] = type; 4267093 PL_nexttoke++; 4267093 if (PL_lex_state != LEX_KNOWNEXT) { 4056399 PL_lex_defer = PL_lex_state; 4056399 PL_lex_expect = PL_expect; 4056399 PL_lex_state = LEX_KNOWNEXT; } } STATIC SV * S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len) 1121105 { 1121105 SV * const sv = newSVpvn(start,len); 1121105 if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len)) 117 SvUTF8_on(sv); 1121105 return sv; } /* * S_force_word * When the lexer knows the next thing is a word (for instance, it has * just seen -> and it knows that the next char is a word char, then * it calls S_force_word to stick the next word into the PL_next lookahead. * * Arguments: * char *start : buffer position (must be within PL_linestr) * int token : PL_next will be this type of bare word (e.g., METHOD,WORD) * int check_keyword : if true, Perl checks to make sure the word isn't * a keyword (do this if the word is a label, e.g. goto FOO) * int allow_pack : if true, : characters will also be allowed (require, * use, etc. do this) * int allow_initial_tick : used by the "sub" lexer only. */ STATIC char * S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick) 1085496 { 1085496 register char *s; 1085496 STRLEN len; 1085496 start = skipspace(start); 1085496 s = start; 1085496 if (isIDFIRST_lazy_if(s,UTF) || (allow_pack && *s == ':') || (allow_initial_tick && *s == '\'') ) { 1027203 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len); 1027203 if (check_keyword && keyword(PL_tokenbuf, len)) 35085 return start; 992118 if (token == METHOD) { 239230 s = skipspace(s); 239230 if (*s == '(') 192290 PL_expect = XTERM; else { 46940 PL_expect = XOPERATOR; } } 992118 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len)); 992118 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE; 992118 force_next(token); } 1050411 return s; } /* * S_force_ident * Called when the lexer wants $foo *foo &foo etc, but the program * text only contains the "foo" portion. The first argument is a pointer * to the "foo", and the second argument is the type symbol to prefix. * Forces the next token to be a "WORD". * Creates the symbol if it didn't already exist (via gv_fetchpv()). */ STATIC void S_force_ident(pTHX_ register const char *s, int kind) 133573 { 133573 if (s && *s) { 107587 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0)); 107587 PL_nextval[PL_nexttoke].opval = o; 107587 force_next(WORD); 107587 if (kind) { 107587 o->op_private = OPpCONST_ENTERED; /* XXX see note in pp_entereval() for why we forgo typo warnings if the symbol must be introduced in an eval. GSAR 96-10-12 */ 107587 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE, kind == '$' ? SVt_PV : kind == '@' ? SVt_PVAV : kind == '%' ? SVt_PVHV : SVt_PVGV ); } } } NV Perl_str_to_version(pTHX_ SV *sv) 26 { 26 NV retval = 0.0; 26 NV nshift = 1.0; 26 STRLEN len; 26 const char *start = SvPV_const(sv,len); 26 const char * const end = start + len; 26 const bool utf = SvUTF8(sv) ? TRUE : FALSE; 97 while (start < end) { 71 STRLEN skip; 71 UV n; 71 if (utf) 18 n = utf8n_to_uvchr((U8*)start, len, &skip, 0); else { 53 n = *(U8*)start; 53 skip = 1; } 71 retval += ((NV)n)/nshift; 71 start += skip; 71 nshift *= 1000; } 26 return retval; } /* * S_force_version * Forces the next token to be a version number. * If the next token appears to be an invalid version number, (e.g. "v2b"), * and if "guessing" is TRUE, then no new token is created (and the caller * must use an alternative parsing method). */ STATIC char * S_force_version(pTHX_ char *s, int guessing) 75705 { 75705 OP *version = Nullop; 75705 char *d; 75705 s = skipspace(s); 75705 d = s; 75705 if (*d == 'v') 14 d++; 75705 if (isDIGIT(*d)) { 71102 while (isDIGIT(*d) || *d == '_' || *d == '.') 60316 d++; 10786 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) { 10776 SV *ver; 10776 s = scan_num(s, &yylval); 10776 version = yylval.opval; 10776 ver = cSVOPx(version)->op_sv; 10776 if (SvPOK(ver) && !SvNIOK(ver)) { 26 SvUPGRADE(ver, SVt_PVNV); 26 SvNV_set(ver, str_to_version(ver)); 26 SvNOK_on(ver); /* hint that it is a version */ } } 10 else if (guessing) ###### return s; } /* NOTE: The parser sees the package name and the VERSION swapped */ 75705 PL_nextval[PL_nexttoke].opval = version; 75705 force_next(WORD); 75705 return s; } /* * S_tokeq * Tokenize a quoted string passed in as an SV. It finds the next * chunk, up to end of string or a backslash. It may make a new * SV containing that chunk (if HINT_NEW_STRING is on). It also * turns \\ into \. */ STATIC SV * S_tokeq(pTHX_ SV *sv) 1594633 { 1594633 register char *s; 1594633 register char *send; 1594633 register char *d; 1594633 STRLEN len = 0; 1594633 SV *pv = sv; 1594633 if (!SvLEN(sv)) ###### goto finish; 1594633 s = SvPV_force(sv, len); 1594633 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) 15481 goto finish; 1579152 send = s + len; 13635448 while (s < send && *s != '\\') 12056296 s++; 1579152 if (s == send) 1569368 goto finish; 9784 d = s; 9784 if ( PL_hints & HINT_NEW_STRING ) { 2 pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len)); 2 if (SvUTF8(sv)) ###### SvUTF8_on(pv); } 382219 while (s < send) { 372435 if (*s == '\\') { 20282 if (s + 1 < send && (s[1] == '\\')) 5107 s++; /* all that, just for this */ } 372435 *d++ = *s++; } 9784 *d = '\0'; 9784 SvCUR_set(sv, d - SvPVX_const(sv)); finish: 1594633 if ( PL_hints & HINT_NEW_STRING ) 6 return new_constant(NULL, 0, "q", sv, pv, "q"); 1594627 return sv; } /* * Now come three functions related to double-quote context, * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They * interact with PL_lex_state, and create fake ( ... ) argument lists * to handle functions and concatenation. * They assume that whoever calls them will be setting up a fake * join call, because each subthing puts a ',' after it. This lets * "lower \luPpEr" * become * join($, , 'lower ', lcfirst( 'uPpEr', ) ,) * * (I'm not sure whether the spurious commas at the end of lcfirst's * arguments and join's arguments are created or not). */ /* * S_sublex_start * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST). * * Pattern matching will set PL_lex_op to the pattern-matching op to * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise). * * OP_CONST and OP_READLINE are easy--just make the new op and return. * * Everything else becomes a FUNC. * * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we * had an OP_CONST or OP_READLINE). This just sets us up for a * call to S_sublex_push(). */ STATIC I32 S_sublex_start(pTHX) 2033243 { 2033243 const register I32 op_type = yylval.ival; 2033243 if (op_type == OP_NULL) { 6668 yylval.opval = PL_lex_op; 6668 PL_lex_op = Nullop; 6668 return THING; } 2026575 if (op_type == OP_CONST || op_type == OP_READLINE) { 1230534 SV *sv = tokeq(PL_lex_stuff); 1230534 if (SvTYPE(sv) == SVt_PVIV) { /* Overloaded constants, nothing fancy: Convert to SVt_PV: */ 1230531 STRLEN len; 1230531 const char *p = SvPV_const(sv, len); 1230531 SV * const nsv = newSVpvn(p, len); 1230531 if (SvUTF8(sv)) 139 SvUTF8_on(nsv); 1230531 SvREFCNT_dec(sv); 1230531 sv = nsv; } 1230534 yylval.opval = (OP*)newSVOP(op_type, 0, sv); 1230534 PL_lex_stuff = Nullsv; /* Allow // "foo" */ 1230534 if (op_type == OP_READLINE) ###### PL_expect = XTERMORDORDOR; 1230534 return THING; } 796041 PL_sublex_info.super_state = PL_lex_state; 796041 PL_sublex_info.sub_inwhat = op_type; 796041 PL_sublex_info.sub_op = PL_lex_op; 796041 PL_lex_state = LEX_INTERPPUSH; 796041 PL_expect = XTERM; 796041 if (PL_lex_op) { 227077 yylval.opval = PL_lex_op; 227077 PL_lex_op = Nullop; 227077 return PMFUNC; } else 568964 return FUNC; } /* * S_sublex_push * Create a new scope to save the lexing state. The scope will be * ended in S_sublex_done. Returns a '(', starting the function arguments * to the uc, lc, etc. found before. * Sets PL_lex_state to LEX_INTERPCONCAT. */ STATIC I32 S_sublex_push(pTHX) 796041 { dVAR; 796041 ENTER; 796041 PL_lex_state = PL_sublex_info.super_state; 796041 SAVEI32(PL_lex_dojoin); 796041 SAVEI32(PL_lex_brackets); 796041 SAVEI32(PL_lex_casemods); 796041 SAVEI32(PL_lex_starts); 796041 SAVEI32(PL_lex_state); 796041 SAVEVPTR(PL_lex_inpat); 796041 SAVEI32(PL_lex_inwhat); 796041 SAVECOPLINE(PL_curcop); 796041 SAVEPPTR(PL_bufptr); 796041 SAVEPPTR(PL_bufend); 796041 SAVEPPTR(PL_oldbufptr); 796041 SAVEPPTR(PL_oldoldbufptr); 796041 SAVEPPTR(PL_last_lop); 796041 SAVEPPTR(PL_last_uni); 796041 SAVEPPTR(PL_linestart); 796041 SAVESPTR(PL_linestr); 796041 SAVEGENERICPV(PL_lex_brackstack); 796041 SAVEGENERICPV(PL_lex_casestack); 796041 PL_linestr = PL_lex_stuff; 796041 PL_lex_stuff = Nullsv; 796041 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); 796041 PL_bufend += SvCUR(PL_linestr); 796041 PL_last_lop = PL_last_uni = Nullch; 796041 SAVEFREESV(PL_linestr); 796041 PL_lex_dojoin = FALSE; 796041 PL_lex_brackets = 0; 796041 New(899, PL_lex_brackstack, 120, char); 796041 New(899, PL_lex_casestack, 12, char); 796041 PL_lex_casemods = 0; 796041 *PL_lex_casestack = '\0'; 796041 PL_lex_starts = 0; 796041 PL_lex_state = LEX_INTERPCONCAT; 796041 CopLINE_set(PL_curcop, (line_t)PL_multi_start); 796041 PL_lex_inwhat = PL_sublex_info.sub_inwhat; 796041 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST) 220635 PL_lex_inpat = PL_sublex_info.sub_op; else 575406 PL_lex_inpat = Nullop; 796041 return '('; } /* * S_sublex_done * Restores lexer state after a S_sublex_push. */ STATIC I32 S_sublex_done(pTHX) 916316 { dVAR; 916316 if (!PL_lex_starts++) { 36076 SV * const sv = newSVpvn("",0); 36076 if (SvUTF8(PL_linestr)) 1 SvUTF8_on(sv); 36076 PL_expect = XOPERATOR; 36076 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); 36076 return THING; } 880240 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */ 576 PL_lex_state = LEX_INTERPCASEMOD; 576 return yylex(); } /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */ 879664 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) { 83629 PL_linestr = PL_lex_repl; 83629 PL_lex_inpat = 0; 83629 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); 83629 PL_bufend += SvCUR(PL_linestr); 83629 PL_last_lop = PL_last_uni = Nullch; 83629 SAVEFREESV(PL_linestr); 83629 PL_lex_dojoin = FALSE; 83629 PL_lex_brackets = 0; 83629 PL_lex_casemods = 0; 83629 *PL_lex_casestack = '\0'; 83629 PL_lex_starts = 0; 83629 if (SvEVALED(PL_lex_repl)) { 4461 PL_lex_state = LEX_INTERPNORMAL; 4461 PL_lex_starts++; /* we don't clear PL_lex_repl here, so that we can check later whether this is an evalled subst; that means we rely on the logic to ensure sublex_done() is called again only via the branch (in yylex()) that clears PL_lex_repl, else we'll loop */ } else { 79168 PL_lex_state = LEX_INTERPCONCAT; 79168 PL_lex_repl = Nullsv; } 83629 return ','; } else { 796035 LEAVE; 796035 PL_bufend = SvPVX(PL_linestr); 796035 PL_bufend += SvCUR(PL_linestr); 796035 PL_expect = XOPERATOR; 796035 PL_sublex_info.sub_inwhat = 0; 796035 return ')'; } } /* scan_const Extracts a pattern, double-quoted string, or transliteration. This is terrifying code. It looks at lex_inwhat and PL_lex_inpat to find out whether it's processing a pattern (PL_lex_inpat is true), a transliteration (lex_inwhat & OP_TRANS is true), or a double-quoted string. Returns a pointer to the character scanned up to. Iff this is advanced from the start pointer supplied (ie if anything was successfully parsed), will leave an OP for the substring scanned in yylval. Caller must intuit reason for not parsing further by looking at the next characters herself. In patterns: backslashes: double-quoted style: \r and \n regexp special ones: \D \s constants: \x3 backrefs: \1 (deprecated in substitution replacements) case and quoting: \U \Q \E stops on @ and $, but not for $ as tail anchor In transliterations: characters are VERY literal, except for - not at the start or end of the string, which indicates a range. scan_const expands the range to the full set of intermediate characters. In double-quoted strings: backslashes: double-quoted style: \r and \n constants: \x3 backrefs: \1 (deprecated) case and quoting: \U \Q \E stops on @ and $ scan_const does *not* construct ops to handle interpolated strings. It stops processing as soon as it finds an embedded $ or @ variable and leaves it to the caller to work out what's going on. @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo. $ in pattern could be $foo or could be tail anchor. Assumption: it's a tail anchor if $ is the last thing in the string, or if it's followed by one of ")| \n\t" \1 (backreferences) are turned into $1 The structure of the code is while (there's a character to process) { handle transliteration ranges skip regexp comments skip # initiated comments in //x patterns check for embedded @foo check for embedded scalars if (backslash) { leave intact backslashes from leave (below) deprecate \1 in strings and sub replacements handle string-changing backslashes \l \U \Q \E, etc. switch (what was escaped) { handle - in a transliteration (becomes a literal -) handle \132 octal characters handle 0x15 hex characters handle \cV (control V) handle printf backslashes (\f, \r, \n, etc) } (end switch) } (end if backslash) } (end while character to read) */ STATIC char * S_scan_const(pTHX_ char *start) 1154591 { 1154591 register char *send = PL_bufend; /* end of the constant */ 1154591 SV *sv = NEWSV(93, send - start); /* sv for the constant */ 1154591 register char *s = start; /* start of the constant */ 1154591 register char *d = SvPVX(sv); /* destination for copies */ 1154591 bool dorange = FALSE; /* are we in a translit range? */ 1154591 bool didrange = FALSE; /* did we just finish a range? */ 1154591 I32 has_utf8 = FALSE; /* Output constant is UTF8 */ 1154591 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */ 1154591 UV uv; 1154591 const char *leaveit = /* set of acceptably-backslashed characters */ PL_lex_inpat ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#" 1154591 : ""; 1154591 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { /* If we are doing a trans and we know we want UTF8 set expectation */ 9810 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF); 9810 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF); } 11676816 while (s < send || dorange) { /* get transliterations out of the way (they're most literal) */ 10965678 if (PL_lex_inwhat == OP_TRANS) { /* expand a range A-Z to the full set of characters. AIE! */ 28761 if (dorange) { 4946 I32 i; /* current expanded character */ 4946 I32 min; /* first character in range */ 4946 I32 max; /* last character in range */ 4946 if (has_utf8) { 3 char * const c = (char*)utf8_hop((U8*)d, -1); 3 char *e = d++; 9 while (e-- > c) 6 *(e + 1) = *e; 3 *c = (char)UTF_TO_NATIVE(0xff); /* mark the range as done, and continue */ 3 dorange = FALSE; 3 didrange = TRUE; 3 continue; } 4943 i = d - SvPVX_const(sv); /* remember current offset */ 4943 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */ 4943 d = SvPVX(sv) + i; /* refresh d after realloc */ 4943 d -= 2; /* eat the first char and the - */ 4943 min = (U8)*d; /* first char in range */ 4943 max = (U8)d[1]; /* last char in range */ 4943 if (min > max) { 1 Perl_croak(aTHX_ "Invalid range \"%c-%c\" in transliteration operator", (char)min, (char)max); } #ifdef EBCDIC if ((isLOWER(min) && isLOWER(max)) || (isUPPER(min) && isUPPER(max))) { if (isLOWER(min)) { for (i = min; i <= max; i++) if (isLOWER(i)) *d++ = NATIVE_TO_NEED(has_utf8,i); } else { for (i = min; i <= max; i++) if (isUPPER(i)) *d++ = NATIVE_TO_NEED(has_utf8,i); } } else #endif 158217 for (i = min; i <= max; i++) 153275 *d++ = (char)i; /* mark the range as done, and continue */ 4942 dorange = FALSE; 4942 didrange = TRUE; 4942 continue; } /* range begins (ignore - as first or last char) */ 23815 else if (*s == '-' && s+1 < send && s != start) { 4988 if (didrange) { 1 Perl_croak(aTHX_ "Ambiguous range in transliteration operator"); } 4987 if (has_utf8) { 41 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */ 41 s++; 41 continue; } 4946 dorange = TRUE; 4946 s++; } else { 18827 didrange = FALSE; } } /* if we get here, we're not doing a transliteration */ /* skip for regexp comments /(?#comment)/ and code /(?{code})/, except for the last char, which will be done separately. */ 10936917 else if (*s == '(' && PL_lex_inpat && s[1] == '?') { 18789 if (s[2] == '#') { 15 while (s+1 < send && *s != ')') 10 *d++ = NATIVE_TO_NEED(has_utf8,*s++); } 18784 else if (s[2] == '{' /* This should match regcomp.c */ || ((s[2] == 'p' || s[2] == '?') && s[3] == '{')) { 662 I32 count = 1; 662 char *regparse = s + (s[2] == '{' ? 3 : 4); 7200 char c; 7200 while (count && (c = *regparse)) { 6538 if (c == '\\' && regparse[1]) 1 regparse++; 6537 else if (c == '{') 3 count++; 6534 else if (c == '}') 663 count--; 6538 regparse++; } 662 if (*regparse != ')') 2 regparse--; /* Leave one char for continuation. */ 9755 while (s < regparse) 9093 *d++ = NATIVE_TO_NEED(has_utf8,*s++); } } /* likewise skip #-initiated comments in //x patterns */ 10918128 else if (*s == '#' && PL_lex_inpat && ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) { 42705 while (s+1 < send && *s != '\n') 40939 *d++ = NATIVE_TO_NEED(has_utf8,*s++); } /* check for embedded arrays (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-) */ 10916362 else if (*s == '@' && s[1] && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1]))) 10903538 break; /* check for embedded scalars. only stop if we're sure it's a variable. */ 10903538 else if (*s == '$') { 471072 if (!PL_lex_inpat) /* not a regexp, so $ must be var */ 403487 break; 67585 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) 20956 break; /* in regexp, $ might be tail anchor */ } /* End of else if chain - OP_TRANS rejoin rest */ /* backslashes */ 10523423 if (*s == '\\' && s+1 < send) { 3016662 s++; /* some backslashes we leave behind */ 3016662 if (*leaveit && *s && strchr(leaveit, *s)) { 188617 *d++ = NATIVE_TO_NEED(has_utf8,'\\'); 188617 *d++ = NATIVE_TO_NEED(has_utf8,*s++); 188617 continue; } /* deprecate \1 in strings and substitution replacements */ 2828045 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat && isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) { 2 if (ckWARN(WARN_SYNTAX)) 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s); 2 *--s = '$'; 2 break; } /* string-change backslash escapes */ 2828043 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) { 6180 --s; 6180 break; } /* if we get here, it's either a quoted -, or a digit */ 2821863 switch (*s) { /* quoted - in transliterations */ case '-': 431 if (PL_lex_inwhat == OP_TRANS) { 130 *d++ = *s++; 130 continue; } /* FALL THROUGH */ default: { 83044 if (ckWARN(WARN_MISC) && isALNUM(*s) && *s != '_') 2 Perl_warner(aTHX_ packWARN(WARN_MISC), "Unrecognized escape \\%c passed through", *s); /* default action is to copy the quoted character */ 2 goto default_action; } /* \132 indicates an octal constant */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': { 30645 I32 flags = 0; 30645 STRLEN len = 3; 30645 uv = grok_oct(s, &len, &flags, NULL); 30645 s += len; } 30645 goto NUM_ESCAPE_INSERT; /* \x24 indicates a hex constant */ case 'x': 2577790 ++s; 2577790 if (*s == '{') { 6113 char* const e = strchr(s, '}'); 6113 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES | 6113 PERL_SCAN_DISALLOW_PREFIX; 6113 STRLEN len; 6113 ++s; 6113 if (!e) { 1 yyerror("Missing right brace on \\x{}"); 1 continue; } 6112 len = e - s; 6112 uv = grok_hex(s, &len, &flags, NULL); 6112 s = e + 1; } else { { 2571677 STRLEN len = 2; 2571677 I32 flags = PERL_SCAN_DISALLOW_PREFIX; 2571677 uv = grok_hex(s, &len, &flags, NULL); 2571677 s += len; } } NUM_ESCAPE_INSERT: /* Insert oct or hex escaped character. * There will always enough room in sv since such * escapes will be longer than any UTF-8 sequence * they can end up as. */ /* We need to map to chars to ASCII before doing the tests to cover EBCDIC */ 2608435 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) { 76594 if (!has_utf8 && uv > 255) { /* Might need to recode whatever we have * accumulated so far if it contains any * hibit chars. * * (Can't we keep track of that and avoid * this rescan? --jhi) */ 3248 int hicount = 0; 3248 U8 *c; 6116 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) { 2868 if (!NATIVE_IS_INVARIANT(*c)) { 325 hicount++; } } 3248 if (hicount) { 46 const STRLEN offset = d - SvPVX_const(sv); 46 U8 *src, *dst; 46 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset; 46 src = (U8 *)d - 1; 46 dst = src+hicount; 46 d += hicount; 651 while (src >= (const U8 *)SvPVX_const(sv)) { 605 if (!NATIVE_IS_INVARIANT(*src)) { 325 const U8 ch = NATIVE_TO_ASCII(*src); 325 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch); 325 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch); } else { 280 *dst-- = *src; } 605 src--; } } } 76594 if (has_utf8 || uv > 255) { 5557 d = (char*)uvchr_to_utf8((U8*)d, uv); 5557 has_utf8 = TRUE; 5557 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { 53 PL_sublex_info.sub_op->op_private |= (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF); } } else { 71037 *d++ = (char)uv; } } else { 2531841 *d++ = (char) uv; } 2531841 continue; /* \N{LATIN SMALL LETTER A} is a named character */ case 'N': 156 ++s; 156 if (*s == '{') { 156 char* e = strchr(s, '}'); 156 SV *res; 156 STRLEN len; 156 const char *str; 156 if (!e) { ###### yyerror("Missing right brace on \\N{}"); ###### e = s - 1; ###### goto cont_scan; } 156 if (e > s + 2 && s[1] == 'U' && s[2] == '+') { /* \N{U+...} */ 1 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES | 1 PERL_SCAN_DISALLOW_PREFIX; 1 s += 3; 1 len = e - s; 1 uv = grok_hex(s, &len, &flags, NULL); 1 s = e + 1; 1 goto NUM_ESCAPE_INSERT; } 155 res = newSVpvn(s + 1, e - s - 1); 155 res = new_constant( Nullch, 0, "charnames", res, Nullsv, "\\N{...}" ); 153 if (has_utf8) 21 sv_utf8_upgrade(res); 153 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 * mapping, so this would be redundant (and wrong, * the code point would be doubly converted). * But leave this in just in case the pack U change * gets revoked, but the semantics is still * desireable for charnames. --jhi */ { UV uv = utf8_to_uvchr((const U8*)str, 0); if (uv < 0x100) { U8 tmpbuf[UTF8_MAXBYTES+1], *d; d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv)); sv_setpvn(res, (char *)tmpbuf, d - tmpbuf); str = SvPV_const(res, len); } } #endif 153 if (!has_utf8 && SvUTF8(res)) { 132 const char * const ostart = SvPVX_const(sv); 132 SvCUR_set(sv, d - ostart); 132 SvPOK_on(sv); 132 *d = '\0'; 132 sv_utf8_upgrade(sv); /* this just broke our allocation above... */ 132 SvGROW(sv, (STRLEN)(send - start)); 132 d = SvPVX(sv) + SvCUR(sv); 132 has_utf8 = TRUE; } 153 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */ ###### const char * const odest = SvPVX_const(sv); ###### SvGROW(sv, (SvLEN(sv) + len - (e - s + 4))); ###### d = SvPVX(sv) + (d - odest); } 153 Copy(str, d, len, char); 153 d += len; 153 SvREFCNT_dec(res); cont_scan: 153 s = e + 1; } else ###### yyerror("Missing braces on \\N{}"); ###### continue; /* \c is a control character */ case 'c': 3663 s++; 3663 if (s < send) { 3662 U8 c = *s++; #ifdef EBCDIC if (isLOWER(c)) c = toUPPER(c); #endif 3662 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c)); } else { 1 yyerror("Missing control char name in \\c"); } 1 continue; /* printf-style backslashes, formfeeds, newlines, etc */ case 'b': 121 *d++ = NATIVE_TO_NEED(has_utf8,'\b'); 121 break; case 'n': 112999 *d++ = NATIVE_TO_NEED(has_utf8,'\n'); 112999 break; case 'r': 490 *d++ = NATIVE_TO_NEED(has_utf8,'\r'); 490 break; case 'f': 219 *d++ = NATIVE_TO_NEED(has_utf8,'\f'); 219 break; case 't': 11444 *d++ = NATIVE_TO_NEED(has_utf8,'\t'); 11444 break; case 'e': 316 *d++ = ASCII_TO_NEED(has_utf8,'\033'); 316 break; case 'a': 846 *d++ = ASCII_TO_NEED(has_utf8,'\007'); 126435 break; } /* end switch */ 126435 s++; 126435 continue; } /* end if (backslash) */ default_action: /* If we started with encoded form, or already know we want it and then encode the next character */ 7589805 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) { 298 STRLEN len = 1; 298 const UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s); 298 const STRLEN need = UNISKIP(NATIVE_TO_UNI(uv)); 298 s += len; 298 if (need > len) { /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */ 2 const STRLEN off = d - SvPVX_const(sv); 2 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off; } 298 d = (char*)uvchr_to_utf8((U8*)d, uv); 298 has_utf8 = TRUE; } else { 7589507 *d++ = NATIVE_TO_NEED(has_utf8,*s++); } } /* while loop to process each character */ /* terminate the string and set up the sv */ 1154587 *d = '\0'; 1154587 SvCUR_set(sv, d - SvPVX_const(sv)); 1154587 if (SvCUR(sv) >= SvLEN(sv)) ###### Perl_croak(aTHX_ "panic: constant overflowed allocated space"); 1154587 SvPOK_on(sv); 1154587 if (PL_encoding && !has_utf8) { 136 sv_recode_to_utf8(sv, PL_encoding); 136 if (SvUTF8(sv)) 136 has_utf8 = TRUE; } 1154587 if (has_utf8) { 3657 SvUTF8_on(sv); 3657 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { 85 PL_sublex_info.sub_op->op_private |= (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF); } } /* shrink the sv if we allocated more than we used */ 1154587 if (SvCUR(sv) + 5 < SvLEN(sv)) { 641927 SvPV_shrink_to_cur(sv); } /* return the substring (via yylval) only if we parsed anything */ 1154587 if (s > PL_bufptr) { 1022593 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) 13 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"), sv, Nullsv, ( PL_lex_inwhat == OP_TRANS ? "tr" : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) ? "s" : "qq"))); 1022593 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); } else 131994 SvREFCNT_dec(sv); 1154587 return s; } /* S_intuit_more * Returns TRUE if there's more to the expression (e.g., a subscript), * FALSE otherwise. * * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/ * * ->[ and ->{ return TRUE * { and [ outside a pattern are always subscripts, so return TRUE * if we're outside a pattern and it's not { or [, then return FALSE * if we're in a pattern and the first char is a { * {4,5} (any digits around the comma) returns FALSE * if we're in a pattern and the first char is a [ * [] returns FALSE * [SOMETHING] has a funky algorithm to decide whether it's a * character class or not. It has to deal with things like * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/ * anything else returns TRUE */ /* This is the one truly awful dwimmer necessary to conflate C and sed. */ STATIC int S_intuit_more(pTHX_ register char *s) 5339601 { 5339601 if (PL_lex_brackets) 4128734 return TRUE; 1210867 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{')) 25100 return TRUE; 1185767 if (*s != '{' && *s != '[') 1118904 return FALSE; 66863 if (!PL_lex_inpat) 65371 return TRUE; /* In a pattern, so maybe we have {n,m}. */ 1492 if (*s == '{') { 1144 s++; 1144 if (!isDIGIT(*s)) 1144 return TRUE; ###### while (isDIGIT(*s)) ###### s++; ###### if (*s == ',') ###### s++; ###### while (isDIGIT(*s)) ###### s++; ###### if (*s == '}') ###### return FALSE; ###### return TRUE; } /* On the other hand, maybe we have a character class */ 348 s++; 348 if (*s == ']' || *s == '^') 32 return FALSE; else { /* this is terrifying, and it works */ 316 int weight = 2; /* let's weigh the evidence */ 316 char seen[256]; 316 unsigned char un_char = 255, last_un_char; 316 const char * const send = strchr(s,']'); 316 char tmpbuf[sizeof PL_tokenbuf * 4]; 316 if (!send) /* has to be an expression */ ###### return TRUE; 316 Zero(seen,256,char); 316 if (*s == '$') 4 weight -= 3; 312 else if (isDIGIT(*s)) { 304 if (s[1] != ']') { ###### if (isDIGIT(s[1]) && s[2] == ']') ###### weight -= 10; } else 304 weight -= 100; } 984 for (; s < send; s++) { 334 last_un_char = un_char; 334 un_char = (unsigned char)*s; 334 switch (*s) { case '@': case '&': case '$': 4 weight -= seen[un_char] * 10; 4 if (isALNUM_lazy_if(s+1,UTF)) { 4 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE); 4 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV)) ###### weight -= 100; else 4 weight -= 10; } ###### else if (*s == '$' && s[1] && strchr("[#!%*<>()-=",s[1])) { ###### if (/*{*/ strchr("])} =",s[2])) ###### weight -= 10; else ###### weight -= 1; } ###### break; case '\\': 2 un_char = 254; 2 if (s[1]) { 2 if (strchr("wds]",s[1])) 2 weight += 100; ###### else if (seen['\''] || seen['"']) ###### weight += 1; ###### else if (strchr("rnftbxcav",s[1])) ###### weight += 40; ###### else if (isDIGIT(s[1])) { ###### weight += 40; ###### while (s[1] && isDIGIT(s[1])) ###### s++; } } else ###### weight += 100; ###### break; case '-': 6 if (s[1] == '\\') ###### weight += 50; 6 if (strchr("aA01! ",last_un_char)) 2 weight += 30; 6 if (strchr("zZ79~",s[1])) 2 weight += 30; 6 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$')) 4 weight -= 5; /* cope with negative subscript */ 4 break; default: 322 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++; ###### *d = '\0'; ###### if (keyword(tmpbuf, d - tmpbuf)) ###### weight -= 150; } 322 if (un_char == last_un_char + 1) ###### weight += 5; 322 weight -= seen[un_char]; 334 break; } 334 seen[un_char]++; } 316 if (weight >= 0) /* probably a character class */ 6 return FALSE; } 310 return TRUE; } /* * S_intuit_method * * Does all the checking to disambiguate * foo bar * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args). * * First argument is the stuff after the first token, e.g. "bar". * * Not a method if bar is a filehandle. * Not a method if foo is a subroutine prototyped to take a filehandle. * Not a method if it's really "Foo $bar" * Method if it's "foo $bar" * Not a method if it's really "print foo $bar" * Method if it's really "foo package::" (interpreted as package->foo) * Not a method if bar is known to be a subroutine ("sub bar; foo bar") * Not a method if bar is a filehandle or package, but is quoted with * => */ STATIC int S_intuit_method(pTHX_ char *start, GV *gv) 24016 { 24016 char *s = start + (*start == '$'); 24016 char tmpbuf[sizeof PL_tokenbuf]; 24016 STRLEN len; 24016 GV* indirgv; 24016 if (gv) { 19523 CV *cv; 19523 if (GvIO(gv)) 2526 return 0; 16997 if ((cv = GvCVu(gv))) { 16798 const char *proto = SvPVX_const(cv); 16798 if (proto) { 2377 if (*proto == ';') 6 proto++; 2377 if (*proto == '*') 5 return 0; } } else 199 gv = 0; } 21485 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); /* start is the beginning of the possible filehandle/object, * and s is the end of it * tmpbuf is a copy of it */ 21485 if (*start == '$') { 10318 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf)) 10318 return 0; ###### s = skipspace(s); ###### PL_bufptr = start; ###### PL_expect = XREF; ###### return *s == '(' ? FUNCMETH : METHOD; } 11167 if (!keyword(tmpbuf, len)) { 7977 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') { 2 len -= 2; 2 tmpbuf[len] = '\0'; 2 goto bare_package; } 7975 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV); 7975 if (indirgv && GvCVu(indirgv)) 251 return 0; /* filehandle or package name makes it a method */ 7724 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) { 5388 s = skipspace(s); 5388 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>') ###### return 0; /* no assumptions -- "=>" quotes bearword */ bare_package: 5390 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(tmpbuf,len)); 5390 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE; 5390 PL_expect = XTERM; 5390 force_next(WORD); 5390 PL_bufptr = s; 5390 return *s == '(' ? FUNCMETH : METHOD; } } 5526 return 0; } /* * S_incl_perldb * Return a string of Perl code to load the debugger. If PERL5DB * is set, it will return the contents of that, otherwise a * compile-time require of perl5db.pl. */ STATIC const char* S_incl_perldb(pTHX) 4506 { 4506 if (PL_perldb) { 9 const char * const pdb = PerlEnv_getenv("PERL5DB"); 9 if (pdb) 9 return pdb; ###### SETERRNO(0,SS_NORMAL); ###### return "BEGIN { require 'perl5db.pl' }"; } 4497 return ""; } /* Encoded script support. filter_add() effectively inserts a * 'pre-processing' function into the current source input stream. * Note that the filter function only applies to the current source file * (e.g., it will not affect files 'require'd or 'use'd by this one). * * The datasv parameter (which may be NULL) can be used to pass * private data to this instance of the filter. The filter function * can recover the SV using the FILTER_DATA macro and use it to * store private buffers and state information. * * The supplied datasv parameter is upgraded to a PVIO type * and the IoDIRP/IoANY field is used to store the function pointer, * and IOf_FAKE_DIRP is enabled on datasv to mark this as such. * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for * private use must be set using malloc'd pointers. */ SV * Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) 2094 { 2094 if (!funcp) ###### return Nullsv; 2094 if (!PL_rsfp_filters) 2090 PL_rsfp_filters = newAV(); 2094 if (!datasv) 2048 datasv = NEWSV(255,0); 2094 SvUPGRADE(datasv, SVt_PVIO); 2094 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */ 2094 IoFLAGS(datasv) |= IOf_FAKE_DIRP; DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n", 2094 IoANY(datasv), SvPV_nolen(datasv))); 2094 av_unshift(PL_rsfp_filters, 1); 2094 av_store(PL_rsfp_filters, 0, datasv) ; 2094 return(datasv); } /* Delete most recently added instance of this filter function. */ void Perl_filter_del(pTHX_ filter_t funcp) 2073 { 2073 SV *datasv; #ifdef DEBUGGING 2073 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp))); #endif 2073 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0) 2073 return; /* if filter is on top of stack (usual case) just pop it off */ 2073 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters)); 2073 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) { 2073 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP; 2073 IoANY(datasv) = (void *)NULL; 2073 sv_free(av_pop(PL_rsfp_filters)); 2073 return; } /* we need to search for the correct entry and clear it */ ###### Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)"); } /* 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) 5145 { 5145 filter_t funcp; 5145 SV *datasv = NULL; 5145 if (!PL_rsfp_filters) ###### return -1; 5145 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, 229 "filter_read %d: from rsfp\n", idx)); 229 if (maxlen) { /* Want a block */ 39 int len ; 39 const int old_len = SvCUR(buf_sv); /* ensure buf_sv is large enough */ 39 SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ; 39 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){ 6 if (PerlIO_error(PL_rsfp)) ###### return -1; /* error */ else 6 return 0 ; /* end of file */ } 33 SvCUR_set(buf_sv, old_len + len) ; } else { /* Want a line */ 190 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) { 31 if (PerlIO_error(PL_rsfp)) ###### return -1; /* error */ else 31 return 0 ; /* end of file */ } } 192 return SvCUR(buf_sv); } /* Skip this filter slot if filter has been deleted */ 4916 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 */ 4916 funcp = DPTR2FPTR(filter_t, IoANY(datasv)); DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: via function %p (%s)\n", 4916 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 */ 4916 return (*funcp)(aTHX_ idx, buf_sv, maxlen); } STATIC char * S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) 10229110 { #ifdef PERL_CR_FILTER if (!PL_rsfp_filters) { filter_add(S_cr_textfilter,NULL); } #endif 10229110 if (PL_rsfp_filters) { 4891 if (!append) 3169 SvCUR_set(sv, 0); /* start with empty line */ 4891 if (FILTER_READ(0, sv, 0) > 0) 2806 return ( SvPVX(sv) ) ; else 2084 return Nullch ; } else 10224219 return (sv_gets(sv, fp, append)); } STATIC HV * S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) 30 { 30 GV *gv; 30 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__")) 1 return PL_curstash; 29 if (len > 2 && (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') && (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV))) { 1 return GvHV(gv); /* Foo:: */ } /* use constant CLASS => 'MyClass' */ 28 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) { 2 SV *sv; 2 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) { 2 pkgname = SvPV_nolen_const(sv); } } 28 return gv_stashpv(pkgname, FALSE); } #ifdef DEBUGGING static const char* const exp_name[] = { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK", "ATTRTERM", "TERMBLOCK", "TERMORDORDOR" }; #endif /* yylex Works out what to call the token just pulled out of the input stream. The yacc parser takes care of taking the ops we return and stitching them into a tree. Returns: PRIVATEREF Structure: if read an identifier if we're in a my declaration croak if they tried to say my($foo::bar) build the ops for a my() declaration if it's an access to a my() variable are we in a sort block? croak if my($a); $a <=> $b build ops for access to a my() variable if in a dq string, and they've said @foo and we can't find @foo croak build ops for a bareword if we already built the token before, use it. */ #ifdef __SC__ #pragma segment Perl_yylex #endif int Perl_yylex(pTHX) 39968763 { 39968763 register char *s = PL_bufptr; 39968763 register char *d; 39968763 register I32 tmp; 39968763 STRLEN len; 39968763 GV *gv = Nullgv; 39968763 GV **gvp = 0; 39968763 bool bof = FALSE; 39968763 I32 orig_keyword = 0; DEBUG_T( { PerlIO_printf(Perl_debug_log, "### LEX_%s\n", lex_state_names[PL_lex_state]); 39968763 } ); /* check if there's an identifier for us to look at */ 39968763 if (PL_pending_ident) 5127241 return REPORT(S_pending_ident(aTHX)); /* no identifier pending identification */ 34841522 switch (PL_lex_state) { #ifdef COMMENTARY case LEX_NORMAL: /* Some compilers will produce faster */ case LEX_INTERPNORMAL: /* code if we comment these out. */ break; #endif /* when we've already built the next token, just pull it out of the queue */ case LEX_KNOWNEXT: 4267092 PL_nexttoke--; 4267092 yylval = PL_nextval[PL_nexttoke]; 4267092 if (!PL_nexttoke) { 4056398 PL_lex_state = PL_lex_defer; 4056398 PL_expect = PL_lex_expect; 4056398 PL_lex_defer = LEX_NORMAL; } DEBUG_T({ PerlIO_printf(Perl_debug_log, "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr, 4267092 (IV)PL_nexttype[PL_nexttoke]); }); 4267092 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 \ */ case LEX_INTERPCASEMOD: #ifdef DEBUGGING 7413 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\') ###### Perl_croak(aTHX_ "panic: INTERPCASEMOD"); #endif /* handle \E or end of string */ 7413 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') { /* if at a \E */ 3993 if (PL_lex_casemods) { 3411 const char oldmod = PL_lex_casestack[--PL_lex_casemods]; 3411 PL_lex_casestack[PL_lex_casemods] = '\0'; 3411 if (PL_bufptr != PL_bufend && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) { 2756 PL_bufptr += 2; 2756 PL_lex_state = LEX_INTERPCONCAT; } 3411 return REPORT(')'); } 582 if (PL_bufptr != PL_bufend) 6 PL_bufptr += 2; 582 PL_lex_state = LEX_INTERPCONCAT; 582 return yylex(); } else { DEBUG_T({ PerlIO_printf(Perl_debug_log, 3420 "### Saw case modifier at '%s'\n", PL_bufptr); }); 3420 s = PL_bufptr + 1; 3420 if (s[1] == '\\' && s[2] == 'E') { 5 PL_bufptr = s + 3; 5 PL_lex_state = LEX_INTERPCONCAT; 5 return yylex(); } else { 3415 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) 5 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */ 3415 if ((*s == 'L' || *s == 'U') && (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) { 2 PL_lex_casestack[--PL_lex_casemods] = '\0'; 2 return REPORT(')'); } 3413 if (PL_lex_casemods > 10) 2 Renew(PL_lex_casestack, PL_lex_casemods + 2, char); 3413 PL_lex_casestack[PL_lex_casemods++] = *s; 3413 PL_lex_casestack[PL_lex_casemods] = '\0'; 3413 PL_lex_state = LEX_INTERPCONCAT; 3413 PL_nextval[PL_nexttoke].ival = 0; 3413 force_next('('); 3413 if (*s == 'l') 15 PL_nextval[PL_nexttoke].ival = OP_LCFIRST; 3398 else if (*s == 'u') 82 PL_nextval[PL_nexttoke].ival = OP_UCFIRST; 3316 else if (*s == 'L') 273 PL_nextval[PL_nexttoke].ival = OP_LC; 3043 else if (*s == 'U') 232 PL_nextval[PL_nexttoke].ival = OP_UC; 2811 else if (*s == 'Q') 2811 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA; else ###### Perl_croak(aTHX_ "panic: yylex"); 3413 PL_bufptr = s + 1; } 3413 force_next(FUNC); 3413 if (PL_lex_starts) { 1565 s = PL_bufptr; 1565 PL_lex_starts = 0; /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ 1565 if (PL_lex_casemods == 1 && PL_lex_inpat) 1157 OPERATOR(','); else 408 Aop(OP_CONCAT); } else 1848 return yylex(); } case LEX_INTERPPUSH: 796041 return REPORT(sublex_push()); case LEX_INTERPSTART: 1148407 if (PL_bufptr == PL_bufend) 711138 return REPORT(sublex_done()); DEBUG_T({ PerlIO_printf(Perl_debug_log, 437269 "### Interpolated variable at '%s'\n", PL_bufptr); }); 437269 PL_expect = XTERM; 437269 PL_lex_dojoin = (*PL_bufptr == '@'); 437269 PL_lex_state = LEX_INTERPNORMAL; 437269 if (PL_lex_dojoin) { 12824 PL_nextval[PL_nexttoke].ival = 0; 12824 force_next(','); 12824 force_ident("\"", '$'); 12824 PL_nextval[PL_nexttoke].ival = 0; 12824 force_next('$'); 12824 PL_nextval[PL_nexttoke].ival = 0; 12824 force_next('('); 12824 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */ 12824 force_next(FUNC); } 437269 if (PL_lex_starts++) { 324436 s = PL_bufptr; /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ 324436 if (!PL_lex_casemods && PL_lex_inpat) 12811 OPERATOR(','); else 311625 Aop(OP_CONCAT); } 112833 return yylex(); case LEX_INTERPENDMAYBE: 393225 if (intuit_more(PL_bufptr)) { 46561 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */ 46561 break; } /* FALL THROUGH */ case LEX_INTERPEND: 441730 if (PL_lex_dojoin) { 12824 PL_lex_dojoin = FALSE; 12824 PL_lex_state = LEX_INTERPCONCAT; 12824 return REPORT(')'); } 428906 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl && SvEVALED(PL_lex_repl)) { 4385 if (PL_bufptr != PL_bufend) 2 Perl_croak(aTHX_ "Bad evalled substitution pattern"); 4383 PL_lex_repl = Nullsv; } /* FALLTHROUGH */ case LEX_INTERPCONCAT: #ifdef DEBUGGING 1369138 if (PL_lex_brackets) ###### Perl_croak(aTHX_ "panic: INTERPCONCAT"); #endif 1369138 if (PL_bufptr == PL_bufend) 205178 return REPORT(sublex_done()); 1163960 if (SvIVX(PL_linestr) == '\'') { 9369 SV *sv = newSVsv(PL_linestr); 9369 if (!PL_lex_inpat) 5 sv = tokeq(sv); 9364 else if ( PL_hints & HINT_NEW_RE ) 2 sv = new_constant(NULL, 0, "qr", sv, sv, "q"); 9369 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); 9369 s = PL_bufend; } else { 1154591 s = scan_const(PL_bufptr); 1154587 if (*s == '\\') 6180 PL_lex_state = LEX_INTERPCASEMOD; else 1148407 PL_lex_state = LEX_INTERPSTART; } 1163956 if (s != PL_bufptr) { 1031962 PL_nextval[PL_nexttoke] = yylval; 1031962 PL_expect = XTERM; 1031962 force_next(THING); 1031962 if (PL_lex_starts++) { /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ 304101 if (!PL_lex_casemods && PL_lex_inpat) 13060 OPERATOR(','); else 291041 Aop(OP_CONCAT); } else { 727861 PL_bufptr = s; 727861 return yylex(); } } 131994 return yylex(); case LEX_FORMLINE: 265 PL_lex_state = LEX_NORMAL; 265 s = scan_formline(PL_bufptr); 265 if (!PL_lex_formbrack) 88 goto rightbracket; 177 OPERATOR(';'); } 27240340 s = PL_bufptr; 27240340 PL_oldoldbufptr = PL_oldbufptr; 27240340 PL_oldbufptr = s; DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at [%s]\n", exp_name[PL_expect], s); 27240340 } ); retry: 66447326 switch (*s) { default: 2 if (isIDFIRST_lazy_if(s,UTF)) 2 goto keylookup; ###### Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255); case 4: case 26: 6653408 goto fake_eof; /* emulate EOF on ^D or ^Z */ case 0: 6653408 if (!PL_rsfp) { 105470 PL_last_uni = 0; 105470 PL_last_lop = 0; 105470 if (PL_lex_brackets) { 2 if (PL_lex_formbrack) 1 yyerror("Format not terminated"); else 1 yyerror("Missing right curly or square bracket"); } DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Tokener got EOF\n"); 105470 } ); 105470 TOKEN(0); } 6547938 if (s++ < PL_bufend) 7 goto retry; /* ignore stray nulls */ 6547931 PL_last_uni = 0; 6547931 PL_last_lop = 0; 6547931 if (!PL_in_eval && !PL_preambled) { 4506 PL_preambled = TRUE; 4506 sv_setpv(PL_linestr,incl_perldb()); 4506 if (SvCUR(PL_linestr)) 9 sv_catpvn(PL_linestr,";", 1); 4506 if (PL_preambleav){ 1414 while(AvFILLp(PL_preambleav) >= 0) { 711 SV *tmpsv = av_shift(PL_preambleav); 711 sv_catsv(PL_linestr, tmpsv); 711 sv_catpvn(PL_linestr, ";", 1); 711 sv_free(tmpsv); } 703 sv_free((SV*)PL_preambleav); 703 PL_preambleav = NULL; } 4506 if (PL_minus_n || PL_minus_p) { 21 sv_catpv(PL_linestr, "LINE: while (<>) {"); 21 if (PL_minus_l) 3 sv_catpv(PL_linestr,"chomp;"); 21 if (PL_minus_a) { 5 if (PL_minus_F) { 2 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 { /* "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. */ 2 const char *splits = PL_splitstr; 2 sv_catpvn(PL_linestr, "our @F=split(q", 15); 15 do { /* Need to \ \s */ 15 if (*splits == '\\') 2 sv_catpvn(PL_linestr, splits, 1); 15 sv_catpvn(PL_linestr, splits, 1); 15 } while (*splits++); /* This loop will embed the trailing NUL of PL_linestr as the last thing it does before terminating. */ 2 sv_catpvn(PL_linestr, ");", 2); } } else 3 sv_catpv(PL_linestr,"our @F=split(' ');"); } } 4506 sv_catpvn(PL_linestr, "\n", 1); 4506 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); 4506 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 4506 PL_last_lop = PL_last_uni = Nullch; 4506 if (PERLDB_LINE && PL_curstash != PL_debstash) { 9 SV * const sv = NEWSV(85,0); 9 sv_upgrade(sv, SVt_PVMG); 9 sv_setsv(sv,PL_linestr); 9 (void)SvIOK_on(sv); 9 SvIV_set(sv, 0); 9 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); } 9 goto retry; } 8418620 do { 8418620 bof = PL_rsfp ? TRUE : FALSE; 8418620 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { fake_eof: 38009 if (PL_rsfp) { 37719 if (PL_preprocess && !PL_in_eval) 3 (void)PerlProc_pclose(PL_rsfp); 37716 else if ((PerlIO *)PL_rsfp == PerlIO_stdin()) 19 PerlIO_clearerr(PL_rsfp); else 37697 (void)PerlIO_close(PL_rsfp); 37719 PL_rsfp = Nullfp; 37719 PL_doextract = FALSE; } 38009 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) { 16 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print;}" : ";}"); 16 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); 16 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 16 PL_last_lop = PL_last_uni = Nullch; 16 PL_minus_n = PL_minus_p = 0; 16 goto retry; } 37993 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); 37993 PL_last_lop = PL_last_uni = Nullch; 37993 sv_setpvn(PL_linestr,"",0); 37993 TOKEN(';'); /* not infinite loop because rsfp is NULL now */ } /* If it looks like the start of a BOM or raw UTF-16, * check if it in fact is. */ 8396125 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 */ # define FTELL_FOR_PIPE_IS_BROKEN # endif # else # ifdef __GLIBC__ # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */ # define FTELL_FOR_PIPE_IS_BROKEN # endif # endif # endif #endif #ifdef FTELL_FOR_PIPE_IS_BROKEN /* This loses the possibility to detect the bof * situation on perl -P when the libc5 is being used. * Workaround? Maybe attach some extra state to PL_rsfp? */ if (!PL_preprocess) bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr); #else 1751063 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr); #endif 1751063 if (bof) { 1685 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 1685 s = swallow_bom((U8*)s); } } 8396125 if (PL_doextract) { /* Incest with pod. */ 1944147 if (*s == '=' && strnEQ(s, "=cut", 4)) { 68952 sv_setpvn(PL_linestr, "", 0); 68952 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); 68952 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 68952 PL_last_lop = PL_last_uni = Nullch; 68952 PL_doextract = FALSE; } } 8396125 incline(s); 8396125 } while (PL_doextract); 6520930 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; 6520930 if (PERLDB_LINE && PL_curstash != PL_debstash) { 937 SV * const sv = NEWSV(85,0); 937 sv_upgrade(sv, SVt_PVMG); 937 sv_setsv(sv,PL_linestr); 937 (void)SvIOK_on(sv); 937 SvIV_set(sv, 0); 937 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); } 6520930 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 6520930 PL_last_lop = PL_last_uni = Nullch; 6520930 if (CopLINE(PL_curcop) == 1) { 42348 while (s < PL_bufend && isSPACE(*s)) 1925 s++; 40423 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */ ###### s++; 40423 d = Nullch; 40423 if (!PL_in_eval) { 5049 if (*s == '#' && *(s+1) == '!') 1048 d = s + 2; #ifdef ALTERNATE_SHEBANG else { static char const as[] = ALTERNATE_SHEBANG; if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1)) d = s + (sizeof(as) - 1); } #endif /* ALTERNATE_SHEBANG */ } 40423 if (d) { 1073 char *ipath; 1073 char *ipathend; 1073 while (isSPACE(*d)) 25 d++; 1048 ipath = d; 14461 while (*d && !isSPACE(*d)) 13413 d++; 1048 ipathend = d; #ifdef ARG_ZERO_IS_SCRIPT if (ipathend > ipath) { /* * HP-UX (at least) sets argv[0] to the script name, * which makes $^X incorrect. And Digital UNIX and Linux, * at least, set argv[0] to the basename of the Perl * interpreter. So, having found "#!", we'll set it right. */ SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */ assert(SvPOK(x) || SvGMAGICAL(x)); if (sv_eq(x, CopFILESV(PL_curcop))) { sv_setpvn(x, ipath, ipathend - ipath); SvSETMAGIC(x); } else { STRLEN blen; STRLEN 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] == '/') { sv_setpvn(x, ipath, ipathend - ipath); SvSETMAGIC(x); } } } TAINT_NOT; /* $^X is always tainted, but that's OK */ } #endif /* ARG_ZERO_IS_SCRIPT */ /* * Look for options. */ 1048 d = instr(s,"perl -"); 1048 if (!d) { 684 d = instr(s,"perl"); #if defined(DOSISH) /* avoid getting into infinite loops when shebang * line contains "Perl" rather than "perl" */ if (!d) { for (d = ipathend-4; d >= ipath; --d) { if ((*d == 'p' || *d == 'P') && !ibcmp(d, "perl", 4)) { break; } } if (d < ipath) d = Nullch; } #endif } #ifdef ALTERNATE_SHEBANG /* * If the ALTERNATE_SHEBANG on this system starts with a * character that can be part of a Perl expression, then if * we see it but not "perl", we're probably looking at the * start of Perl code, not a request to hand off to some * other interpreter. Similarly, if "perl" is there, but * not in the first 'word' of the line, we assume the line * contains the start of the Perl program. */ if (d && *s != '#') { const char *c = ipath; while (*c && !strchr("; \t\r\n\f\v#", *c)) c++; if (c < d) d = Nullch; /* "perl" not in first word; ignore */ else *s = '#'; /* Don't try to parse shebang line */ } #endif /* ALTERNATE_SHEBANG */ #ifndef MACOS_TRADITIONAL 1048 if (!d && *s == '#' && ipathend > ipath && !PL_minus_c && !instr(s,"indir") && instr(PL_origargv[0],"perl")) { dVAR; ###### char **newargv; ###### *ipathend = '\0'; ###### s = ipathend + 1; ###### while (s < PL_bufend && isSPACE(*s)) ###### s++; ###### if (s < PL_bufend) { ###### Newz(899,newargv,PL_origargc+3,char*); ###### newargv[1] = s; ###### while (s < PL_bufend && !isSPACE(*s)) ###### s++; ###### *s = '\0'; ###### Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*); } else ###### newargv = PL_origargv; ###### newargv[0] = ipath; ###### PERL_FPU_PRE_EXEC ###### PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv)); ###### PERL_FPU_POST_EXEC ###### Perl_croak(aTHX_ "Can't exec %s", ipath); } #endif 1048 if (d) { 1048 const U32 oldpdb = PL_perldb; 1048 const bool oldn = PL_minus_n; 1048 const bool oldp = PL_minus_p; 5809 while (*d && !isSPACE(*d)) d++; 1447 while (SPACE_OR_TAB(*d)) d++; 1048 if (*d++ == '-') { 392 const bool switches_done = PL_doswitches; 818 do { 818 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); } 818 d = moreswitches(d); 818 } while (d); 392 if (PL_doswitches && !switches_done) { 1 int argc = PL_origargc; 1 char **argv = PL_origargv; 2 do { 2 argc--,argv++; 2 } while (argc && argv[0][0] == '-' && argv[0][1]); 1 init_argv_symbols(argc,argv); } 392 if ((PERLDB_LINE && !oldpdb) || ((PL_minus_n || PL_minus_p) && !(oldn || oldp))) /* if we have already added "LINE: while (<>) {", we must not do it again */ { 6 sv_setpvn(PL_linestr, "", 0); 6 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); 6 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 6 PL_last_lop = PL_last_uni = Nullch; 6 PL_preambled = FALSE; 6 if (PERLDB_LINE) ###### (void)gv_fetchfile(PL_origfilename); ###### goto retry; } 386 if (PL_doswitches && !switches_done) { ###### int argc = PL_origargc; ###### char **argv = PL_origargv; ###### do { ###### argc--,argv++; ###### } while (argc && argv[0][0] == '-' && argv[0][1]); ###### init_argv_symbols(argc,argv); } } } } } 6520924 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { 155 PL_bufptr = s; 155 PL_lex_state = LEX_FORMLINE; 155 return yylex(); } 26156837 goto retry; case '\r': #ifdef PERL_STRICT_CR Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r'); Perl_croak(aTHX_ "\t(Maybe you didn't strip carriage returns after a network transfer?)\n"); #endif case ' ': case '\t': case '\f': case 013: #ifdef MACOS_TRADITIONAL case '\312': #endif 26156837 s++; 26156837 goto retry; case '#': case '\n': 6455967 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) { 47885 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) { /* handle eval qq[#line 1 "foo"\n ...] */ 181 CopLINE_dec(PL_curcop); 181 incline(s); } 47885 d = PL_bufend; 268266 while (s < d && *s != '\n') 220381 s++; 47885 if (s < d) 47885 s++; ###### else if (s > d) /* Found by Ilya: feed random input to Perl. */ ###### Perl_croak(aTHX_ "panic: input overflow"); 47885 incline(s); 47885 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { 76 PL_bufptr = s; 76 PL_lex_state = LEX_FORMLINE; 76 return yylex(); } } else { 6408082 *s = '\0'; 6408082 PL_bufend = s; } 6408082 goto retry; case '-': 596704 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) { 35950 I32 ftst = 0; 35950 s++; 35950 PL_bufptr = s; 35950 tmp = *s++; 71137 while (s < PL_bufend && SPACE_OR_TAB(*s)) 35187 s++; 35950 if (strnEQ(s,"=>",2)) { ###### s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE); DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Saw unary minus before =>, forcing word '%s'\n", s); ###### } ); ###### OPERATOR('-'); /* unary minus */ } 35950 PL_last_uni = PL_oldbufptr; 35950 switch (tmp) { 1655 case 'r': ftst = OP_FTEREAD; break; 2626 case 'w': ftst = OP_FTEWRITE; break; 922 case 'x': ftst = OP_FTEEXEC; break; 2 case 'o': ftst = OP_FTEOWNED; break; 2 case 'R': ftst = OP_FTRREAD; break; 4 case 'W': ftst = OP_FTRWRITE; break; 2 case 'X': ftst = OP_FTREXEC; break; 1 case 'O': ftst = OP_FTROWNED; break; 2972 case 'e': ftst = OP_FTIS; break; 8 case 'z': ftst = OP_FTZERO; break; 4464 case 's': ftst = OP_FTSIZE; break; 8063 case 'f': ftst = OP_FTFILE; break; 12288 case 'd': ftst = OP_FTDIR; break; 1740 case 'l': ftst = OP_FTLINK; break; 8 case 'p': ftst = OP_FTPIPE; break; 11 case 'S': ftst = OP_FTSOCK; break; 6 case 'u': ftst = OP_FTSUID; break; 5 case 'g': ftst = OP_FTSGID; break; 10 case 'k': ftst = OP_FTSVTX; break; 10 case 'b': ftst = OP_FTBLK; break; 108 case 'c': ftst = OP_FTCHR; break; 241 case 't': ftst = OP_FTTTY; break; 82 case 'T': ftst = OP_FTTEXT; break; 404 case 'B': ftst = OP_FTBINARY; break; case 'M': case 'A': case 'C': 314 gv_fetchpv("\024",TRUE, SVt_PV); 314 switch (tmp) { 306 case 'M': ftst = OP_FTMTIME; break; 4 case 'A': ftst = OP_FTATIME; break; 4 case 'C': ftst = OP_FTCTIME; break; 35950 default: break; } 35950 break; default: 35950 break; } 35950 if (ftst) { 35948 PL_last_lop_op = (OPCODE)ftst; DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Saw file test %c\n", (int)ftst); 35948 } ); 35948 FTST(ftst); } else { /* Assume it was a minus followed by a one-letter named * subroutine call (or a -bareword), then. */ DEBUG_T( { PerlIO_printf(Perl_debug_log, "### '-%c' looked like a file test but was not\n", (int) tmp); 2 } ); 2 s = --PL_bufptr; } } 560756 tmp = *s++; 560756 if (*s == tmp) { 14147 s++; 14147 if (PL_expect == XOPERATOR) 12250 TERM(POSTDEC); else 1897 OPERATOR(PREDEC); } 546609 else if (*s == '>') { 495232 s++; 495232 s = skipspace(s); 495232 if (isIDFIRST_lazy_if(s,UTF)) { 239230 s = force_word(s,METHOD,FALSE,TRUE,FALSE); 239230 TOKEN(ARROW); } 256002 else if (*s == '$') 1393 OPERATOR(ARROW); else 254609 TERM(ARROW); } 51377 if (PL_expect == XOPERATOR) 23904 Aop(OP_SUBTRACT); else { 27473 if (isSPACE(*s) || !isSPACE(*PL_bufptr)) 13302 check_uni(); 27473 OPERATOR('-'); /* unary minus */ } case '+': 82457 tmp = *s++; 82457 if (*s == tmp) { 37868 s++; 37868 if (PL_expect == XOPERATOR) 30749 TERM(POSTINC); else 7119 OPERATOR(PREINC); } 44589 if (PL_expect == XOPERATOR) 42883 Aop(OP_ADD); else { 1706 if (isSPACE(*s) || !isSPACE(*PL_bufptr)) 695 check_uni(); 1706 OPERATOR('+'); } case '*': 70556 if (PL_expect != XOPERATOR) { 59972 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE); 59972 PL_expect = XOPERATOR; 59972 force_ident(PL_tokenbuf, '*'); 59972 if (!*PL_tokenbuf) 25986 PREREF('*'); 33986 TERM('*'); } 10584 s++; 10584 if (*s == '*') { 1658 s++; 1658 PWop(OP_POW); } 8926 Mop(OP_MULTIPLY); case '%': 93761 if (PL_expect == XOPERATOR) { 2952 ++s; 2952 Mop(OP_MODULO); } 90809 PL_tokenbuf[0] = '%'; 90809 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE); 90809 if (!PL_tokenbuf[1]) { 23908 PREREF('%'); } 66901 PL_pending_ident = '%'; 66901 TERM('%'); case '^': 522 s++; 522 BOop(OP_BIT_XOR); case '[': 225673 PL_lex_brackets++; /* FALL THROUGH */ case '~': case ',': 1740784 tmp = *s++; 1740784 OPERATOR(tmp); case ':': 94287 if (s[1] == ':') { 150 len = 0; 150 goto just_a_word; } 94137 s++; 94137 switch (PL_expect) { 91912 OP *attrs; case XOPERATOR: 91912 if (!PL_in_my || PL_lex_state != LEX_NORMAL) 1142 break; 1142 PL_bufptr = s; /* update in case we back off */ 1142 goto grabattrs; case XATTRBLOCK: 105 PL_expect = XBLOCK; 105 goto grabattrs; case XATTRTERM: 8 PL_expect = XTERMBLOCK; grabattrs: 1255 s = skipspace(s); 1255 attrs = Nullop; 2465 while (isIDFIRST_lazy_if(s,UTF)) { 1261 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); 1261 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) { ###### if (tmp < 0) tmp = -tmp; ###### switch (tmp) { case KEY_or: case KEY_and: case KEY_err: case KEY_for: case KEY_unless: case KEY_if: case KEY_while: case KEY_until: 1261 goto got_attrs; default: 1261 break; } } 1261 if (*d == '(') { 60 d = scan_str(d,TRUE,TRUE); 60 if (!d) { /* MUST advance bufptr here to avoid bogus "at end of line" context messages from yyerror(). */ 4 PL_bufptr = s + len; 4 yyerror("Unterminated attribute parameter in attribute list"); 4 if (attrs) ###### op_free(attrs); 4 return REPORT(0); /* EOF indicator */ } } 1257 if (PL_lex_stuff) { 56 SV *sv = newSVpvn(s, len); 56 sv_catsv(sv, PL_lex_stuff); 56 attrs = append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, sv)); 56 SvREFCNT_dec(PL_lex_stuff); 56 PL_lex_stuff = Nullsv; } else { 1201 if (len == 6 && strnEQ(s, "unique", len)) { 1086 if (PL_in_my == KEY_our) #ifdef USE_ITHREADS GvUNIQUE_on(cGVOPx_gv(yylval.opval)); #else ; /* skip to avoid loading attributes.pm */ #endif else ###### Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables"); } /* NOTE: any CV attrs applied here need to be part of the CVf_BUILTIN_ATTRS define in cv.h! */ 115 else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len)) 54 CvLVALUE_on(PL_compcv); 61 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len)) 15 CvLOCKED_on(PL_compcv); 46 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len)) 6 CvMETHOD_on(PL_compcv); 40 else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len)) 9 CvASSERTION_on(PL_compcv); /* After we've set the flags, it could be argued that we don't need to do the attributes.pm-based setting process, and shouldn't bother appending recognized flags. To experiment with that, uncomment the following "else". (Note that's already been uncommented. That keeps the above-applied built-in attributes from being intercepted (and possibly rejected) by a package's attribute routines, but is justified by the performance win for the common case of applying only built-in attributes.) */ else 31 attrs = append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, newSVpvn(s, len))); } 1257 s = skipspace(d); 1257 if (*s == ':' && s[1] != ':') 6 s = skipspace(s+1); 1251 else if (s == d) 1251 break; /* require real whitespace or :'s */ } 1251 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */ 1251 if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) { 4 const char q = ((*s == '\'') ? '"' : '\''); /* If here for an expression, and parsed no attrs, back off. */ 4 if (tmp == '=' && !attrs) { 1 s = PL_bufptr; 1 break; } /* MUST advance bufptr here to avoid bogus "at end of line" context messages from yyerror(). */ 3 PL_bufptr = s; 3 if (!*s) ###### yyerror("Unterminated attribute list"); else 3 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list", q, *s, q)); 3 if (attrs) 3 op_free(attrs); 3 OPERATOR(':'); } got_attrs: 1247 if (attrs) { 77 PL_nextval[PL_nexttoke].opval = attrs; 77 force_next(THING); } 1247 TOKEN(COLONATTR); } 92883 OPERATOR(':'); case '(': 1769795 s++; 1769795 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr) 310753 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */ else 1459042 PL_expect = XTERM; 1769795 s = skipspace(s); 1769795 TOKEN('('); case ';': 2552416 CLINE; 2552416 tmp = *s++; 2552416 OPERATOR(tmp); case ')': 1769590 tmp = *s++; 1769590 s = skipspace(s); 1769590 if (*s == '{') 439150 PREBLOCK(tmp); 1330440 TERM(tmp); case ']': 225673 s++; 225673 if (PL_lex_brackets <= 0) ###### yyerror("Unmatched right square bracket"); else 225673 --PL_lex_brackets; 225673 if (PL_lex_state == LEX_INTERPNORMAL) { 11644 if (PL_lex_brackets == 0) { 11178 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>')) 11139 PL_lex_state = LEX_INTERPEND; } } 225673 TERM(']'); case '{': leftbracket: 1488694 s++; 1488694 if (PL_lex_brackets > 100) { 50 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char); } 1488694 switch (PL_expect) { case XTERM: 24929 if (PL_lex_formbrack) { 3 s--; 3 PRETERMBLOCK(DO); } 24926 if (PL_oldoldbufptr == PL_last_lop) 1486 PL_lex_brackstack[PL_lex_brackets++] = XTERM; else 23440 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; 24926 OPERATOR(HASHBRACK); case XOPERATOR: 486923 while (s < PL_bufend && SPACE_OR_TAB(*s)) 1672 s++; 485251 d = s; 485251 PL_tokenbuf[0] = '\0'; 485251 if (d < PL_bufend && *d == '-') { 2034 PL_tokenbuf[0] = '-'; 2034 d++; 2034 while (d < PL_bufend && SPACE_OR_TAB(*d)) ###### d++; } 485251 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) { 268367 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE, &len); 270613 while (d < PL_bufend && SPACE_OR_TAB(*d)) 2246 d++; 268367 if (*d == '}') { 261779 const char minus = (PL_tokenbuf[0] == '-'); 261779 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE); 261779 if (minus) 2034 force_next('-'); } } /* FALL THROUGH */ case XATTRBLOCK: case XBLOCK: 1288955 PL_lex_brackstack[PL_lex_brackets++] = XSTATE; 1288955 PL_expect = XSTATE; 1288955 break; case XATTRTERM: case XTERMBLOCK: 45899 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; 45899 PL_expect = XSTATE; 45899 break; default: { 128911 const char *t; 128911 if (PL_oldoldbufptr == PL_last_lop) 19151 PL_lex_brackstack[PL_lex_brackets++] = XTERM; else 109760 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; 128911 s = skipspace(s); 128911 if (*s == '}') { 3 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) { 1 PL_expect = XTERM; /* This hack is to get the ${} in the message. */ 1 PL_bufptr = s+1; 1 yyerror("syntax error"); 1 break; } 2 OPERATOR(HASHBRACK); } /* This hack serves to disambiguate a pair of curlies * as being a block or an anon hash. Normally, expectation * determines that, but in cases where we're not in a * position to expect anything in particular (like inside * 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 * curly in order to force resolution as an anon hash. * * XXX should probably propagate the outer expectation * into eval"" to rely less on this hack, but that could * potentially break current behavior of eval"". * GSAR 97-07-21 */ 128908 t = s; 128908 if (*s == '\'' || *s == '"' || *s == '`') { /* common case: get past first string, handling escapes */ 36054 for (t++; t < PL_bufend && *t != *s;) 527653 if (*t++ == '\\' && (*t == '\\' || *t == *s)) 11 t++; 36043 t++; } 92865 else if (*s == 'q') { 1182 if (++t < PL_bufend && (!isALNUM(*t) || ((*t == 'q' || *t == 'x') && ++t < PL_bufend && !isALNUM(*t)))) { /* skip q//-like construct */ 799 const char *tmps; 799 char open, close, term; 799 I32 brackets = 1; 804 while (t < PL_bufend && isSPACE(*t)) 5 t++; /* check for q => */ 799 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') { 2 OPERATOR(HASHBRACK); } 797 term = *t; 797 open = term; 797 if (term && (tmps = strchr("([{< )]}> )]}>",term))) 792 term = tmps[5]; 797 close = term; 797 if (open == close) 22 for (t++; t < PL_bufend; t++) { 22 if (*t == '\\' && t+1 < PL_bufend && open != '\\') ###### t++; 22 else if (*t == open) 5 break; } else { 3973 for (t++; t < PL_bufend; t++) { 3973 if (*t == '\\' && t+1 < PL_bufend) ###### t++; 3973 else if (*t == close && --brackets <= 0) 792 break; 3181 else if (*t == open) 1 brackets++; } } 797 t++; } else /* skip plain q word */ 2775 while (t < PL_bufend && isALNUM_lazy_if(t,UTF)) 2392 t += UTF8SKIP(t); } 91683 else if (isALNUM_lazy_if(t,UTF)) { 28476 t += UTF8SKIP(t); 156237 while (t < PL_bufend && isALNUM_lazy_if(t,UTF)) 127761 t += UTF8SKIP(t); } 143050 while (t < PL_bufend && isSPACE(*t)) 14144 t++; /* if comma follows first term, call it an anon hash */ /* XXX it could be a comma expression with loop modifiers */ 128906 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s))) || (*t == '=' && t[1] == '>'))) 47 OPERATOR(HASHBRACK); 128859 if (PL_expect == XREF) 113790 PL_expect = XTERM; else { 15069 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE; 15069 PL_expect = XSTATE; } } 1463714 break; } 1463714 yylval.ival = CopLINE(PL_curcop); 1463714 if (isSPACE(*s) || *s == '#') 840761 PL_copline = NOLINE; /* invalidate current command line number */ 1463714 TOKEN('{'); case '}': rightbracket: 1488693 s++; 1488693 if (PL_lex_brackets <= 0) 8 yyerror("Unmatched right curly bracket"); else 1488685 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets]; 1488693 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL) ###### PL_lex_formbrack = 0; 1488693 if (PL_lex_state == LEX_INTERPNORMAL) { 28945 if (PL_lex_brackets == 0) { 26692 if (PL_expect & XFAKEBRACK) { 1 PL_expect &= XENUMMASK; 1 PL_lex_state = LEX_INTERPEND; 1 PL_bufptr = s; 1 return yylex(); /* ignore fake brackets */ } 26691 if (*s == '-' && s[1] == '>') 95 PL_lex_state = LEX_INTERPENDMAYBE; 26596 else if (*s != '[' && *s != '{') 26022 PL_lex_state = LEX_INTERPEND; } } 1488692 if (PL_expect & XFAKEBRACK) { 4 PL_expect &= XENUMMASK; 4 PL_bufptr = s; 4 return yylex(); /* ignore fake brackets */ } 1488688 force_next('}'); 1488688 TOKEN(';'); case '&': 196998 s++; 196998 tmp = *s++; 196998 if (tmp == '&') 84443 AOPERATOR(ANDAND); 112555 s--; 112555 if (PL_expect == XOPERATOR) { 20413 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart) { 1 CopLINE_dec(PL_curcop); 1 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi); 1 CopLINE_inc(PL_curcop); } 20413 BAop(OP_BIT_AND); } 92142 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE); 92142 if (*PL_tokenbuf) { 60777 PL_expect = XOPERATOR; 60777 force_ident(PL_tokenbuf, '&'); } else 31365 PREREF('&'); 60777 yylval.ival = (OPpENTERSUB_AMPER<<8); 60777 TERM('&'); case '|': 156569 s++; 156569 tmp = *s++; 156569 if (tmp == '|') 115439 AOPERATOR(OROR); 41130 s--; 41130 BOop(OP_BIT_OR); case '=': 1956246 s++; 1956246 tmp = *s++; 1956246 if (tmp == '=') 63690 Eop(OP_EQ); 1892556 if (tmp == '>') 489414 OPERATOR(','); 1403142 if (tmp == '~') 163841 PMop(OP_MATCH); 1239301 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp)) 50 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp); 1239292 s--; 1239292 if (PL_expect == XSTATE && isALPHA(tmp) && (s == PL_linestart+1 || s[-2] == '\n') ) { 68954 if (PL_in_eval && !PL_rsfp) { ###### d = PL_bufend; ###### while (s < d) { ###### if (*s++ == '\n') { ###### incline(s); ###### if (strnEQ(s,"=cut",4)) { ###### s = strchr(s,'\n'); ###### if (s) ###### s++; else ###### s = d; ###### incline(s); ###### goto retry; } } } 68954 goto retry; } 68954 s = PL_bufend; 68954 PL_doextract = TRUE; 68954 goto retry; } 1170338 if (PL_lex_brackets < PL_lex_formbrack) { 89 const char *t; #ifdef PERL_STRICT_CR for (t = s; SPACE_OR_TAB(*t); t++) ; #else 89 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ; #endif 89 if (*t == '\n' || *t == '#') { 89 s--; 89 PL_expect = XBLOCK; 89 goto leftbracket; } } 1170249 yylval.ival = 0; 1170249 OPERATOR(ASSIGNOP); case '!': 102081 s++; 102081 tmp = *s++; 102081 if (tmp == '=') { /* was this !=~ where !~ was meant? * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */ 10978 if (*s == '~' && ckWARN(WARN_SYNTAX)) { 7 const char *t = s+1; 14 while (t < PL_bufend && isSPACE(*t)) 7 ++t; 7 if (*t == '/' || *t == '?' || ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) || (*t == 't' && t[1] == 'r' && !isALNUM(t[2]))) 7 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "!=~ should be !~"); } 10978 Eop(OP_NE); } 91103 if (tmp == '~') 15169 PMop(OP_NOT); 75934 s--; 75934 OPERATOR('!'); case '<': 60498 if (PL_expect != XOPERATOR) { 33311 if (s[1] != '<' && !strchr(s,'>')) 2 check_uni(); 33311 if (s[1] == '<') 26511 s = scan_heredoc(s); else 6800 s = scan_inputsymbol(s); 33308 TERM(sublex_start()); } 27187 s++; 27187 tmp = *s++; 27187 if (tmp == '<') 844 SHop(OP_LEFT_SHIFT); 26343 if (tmp == '=') { 8755 tmp = *s++; 8755 if (tmp == '>') 2841 Eop(OP_NCMP); 5914 s--; 5914 Rop(OP_LE); } 17588 s--; 17588 Rop(OP_LT); case '>': 34748 s++; 34748 tmp = *s++; 34748 if (tmp == '>') 466 SHop(OP_RIGHT_SHIFT); 34282 if (tmp == '=') 8274 Rop(OP_GE); 26008 s--; 26008 Rop(OP_GT); case '$': 4544311 CLINE; 4544311 if (PL_expect == XOPERATOR) { 2 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { 2 PL_expect = XTERM; 2 depcom(); 2 return REPORT(','); /* grandfather non-comma-format format */ } } 4544309 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) { 9035 PL_tokenbuf[0] = '@'; 9035 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); 9035 if (PL_expect == XOPERATOR) ###### no_op("Array length", s); 9035 if (!PL_tokenbuf[1]) 4143 PREREF(DOLSHARP); 4892 PL_expect = XOPERATOR; 4892 PL_pending_ident = '#'; 4892 TOKEN(DOLSHARP); } 4535274 PL_tokenbuf[0] = '$'; 4535274 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); 4535274 if (PL_expect == XOPERATOR) ###### no_op("Scalar", s); 4535274 if (!PL_tokenbuf[1]) { 40874 if (s == PL_bufend) 1 yyerror("Final $ should be \\$ or $name"); 40874 PREREF('$'); } /* This kludge not intended to be bulletproof. */ 4494400 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) { 135 yylval.opval = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase)); 135 yylval.opval->op_private = OPpCONST_ARYBASE; 135 TERM(THING); } 4494265 d = s; 4494265 tmp = (I32)*s; 4494265 if (PL_lex_state == LEX_NORMAL) 4053885 s = skipspace(s); 4494265 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { 3673112 char *t; 3673112 if (*s == '[') { 130803 PL_tokenbuf[0] = '@'; 130803 if (ckWARN(WARN_SYNTAX)) { 62445 for(t = s + 1; isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$'; t++) ; 62445 if (*t++ == ',') { 1 PL_bufptr = skipspace(PL_bufptr); 2 while (t < PL_bufend && *t != ']') 1 t++; 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Multidimensional syntax %.*s not supported", (t - PL_bufptr) + 1, PL_bufptr); } } } 3542309 else if (*s == '{') { 231171 PL_tokenbuf[0] = '%'; 231171 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") && (t = strchr(s, '}')) && (t = strchr(t, '='))) { 1321 char tmpbuf[sizeof PL_tokenbuf]; 1321 for (t++; isSPACE(*t); t++) ; 1321 if (isIDFIRST_lazy_if(t,UTF)) { 869 STRLEN len; 869 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len); 1735 for (; isSPACE(*t); t++) ; 869 if (*t == ';' && get_cv(tmpbuf, FALSE)) 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "You need to quote \"%s\"", tmpbuf); } } } } 4494265 PL_expect = XOPERATOR; 4494265 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) { 1595174 const bool islop = (PL_last_lop == PL_oldoldbufptr); 1595174 if (!islop || PL_last_lop_op == OP_GREPSTART) 1578847 PL_expect = XOPERATOR; 16327 else if (strchr("$@\"'`q", *s)) 8987 PL_expect = XTERM; /* e.g. print $fh "foo" */ 7340 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF)) 7 PL_expect = XTERM; /* e.g. print $fh &sub */ 7333 else if (isIDFIRST_lazy_if(s,UTF)) { 3489 char tmpbuf[sizeof PL_tokenbuf]; 3489 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); 3489 if ((tmp = keyword(tmpbuf, len))) { /* binary operators exclude handle interpretations */ 3202 switch (tmp) { case -KEY_x: case -KEY_eq: case -KEY_ne: case -KEY_gt: case -KEY_lt: case -KEY_ge: case -KEY_le: case -KEY_cmp: 3005 break; default: 3005 PL_expect = XTERM; /* e.g. print $fh length() */ 3005 break; } } else { 287 PL_expect = XTERM; /* e.g. print $fh subr() */ } } 3844 else if (isDIGIT(*s)) 21 PL_expect = XTERM; /* e.g. print $fh 3 */ 3823 else if (*s == '.' && isDIGIT(s[1])) ###### PL_expect = XTERM; /* e.g. print $fh .3 */ 3823 else if ((*s == '?' || *s == '-' || *s == '+') && !isSPACE(s[1]) && s[1] != '=') 9 PL_expect = XTERM; /* e.g. print $fh -1 */ 3814 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/') 2 PL_expect = XTERM; /* e.g. print $fh /.../ XXX except DORDOR operator */ 3812 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=') 555 PL_expect = XTERM; /* print $fh <<"EOF" */ } 4494265 PL_pending_ident = '$'; 4494265 TOKEN('$'); case '@': 640969 if (PL_expect == XOPERATOR) ###### no_op("Array", s); 640969 PL_tokenbuf[0] = '@'; 640969 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); 640969 if (!PL_tokenbuf[1]) { 79786 PREREF('@'); } 561183 if (PL_lex_state == LEX_NORMAL) 548980 s = skipspace(s); 561183 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { 499476 if (*s == '{') 5644 PL_tokenbuf[0] = '%'; /* Warn about @ where they meant $. */ 499476 if (ckWARN(WARN_SYNTAX)) { 170012 if (*s == '[' || *s == '{') { 1597 const char *t = s + 1; 4147 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t))) 2550 t++; 1597 if (*t == '}' || *t == ']') { 11 t++; 11 PL_bufptr = skipspace(PL_bufptr); 11 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Scalar value %.*s better written as $%.*s", t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1); } } } } 561183 PL_pending_ident = '@'; 561183 TERM('@'); case '/': /* may be division, defined-or, or pattern */ 108884 if (PL_expect == XTERMORDORDOR && s[1] == '/') { 10 s += 2; 10 AOPERATOR(DORDOR); } case '?': /* may either be conditional or pattern */ 201747 if(PL_expect == XOPERATOR) { 97713 tmp = *s++; 97713 if(tmp == '?') { 92869 OPERATOR('?'); } else { 4844 tmp = *s++; 4844 if(tmp == '/') { /* A // operator. */ 21 AOPERATOR(DORDOR); } else { 4823 s--; 4823 Mop(OP_DIVIDE); } } } else { /* Disable warning on "study /blah/" */ 104034 if (PL_oldoldbufptr == PL_last_uni && (*PL_last_uni != 's' || s - PL_last_uni < 5 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy_if(PL_last_uni+5,UTF) )) ###### check_uni(); 104034 s = scan_pat(s,OP_MATCH); 104030 TERM(sublex_start()); } case '.': 139350 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack #ifdef PERL_STRICT_CR && s[1] == '\n' #else && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n')) #endif && (s == PL_linestart || s[-1] == '\n') ) { ###### PL_lex_formbrack = 0; ###### PL_expect = XSTATE; ###### goto rightbracket; } 139350 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) { 139317 tmp = *s++; 139317 if (*s == tmp) { 7553 s++; 7553 if (*s == tmp) { 26 s++; 26 yylval.ival = OPf_SPECIAL; } else 7527 yylval.ival = 0; 7553 OPERATOR(DOTDOT); } 131764 if (PL_expect != XOPERATOR) 4 check_uni(); 131764 Aop(OP_CONCAT); } /* FALL THROUGH */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': 859883 s = scan_num(s, &yylval); DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Saw number in '%s'\n", s); 859881 } ); 859881 if (PL_expect == XOPERATOR) 5 no_op("Number",s); 859881 TERM(THING); case '\'': 986727 s = scan_str(s,FALSE,FALSE); DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Saw string before '%s'\n", s); 986727 } ); 986727 if (PL_expect == XOPERATOR) { 2 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { 2 PL_expect = XTERM; 2 depcom(); 2 return REPORT(','); /* grandfather non-comma-format format */ } else ###### no_op("String",s); } 986725 if (!s) ###### missingterm((char*)0); 986725 yylval.ival = OP_CONST; 986725 TERM(sublex_start()); case '"': 762597 s = scan_str(s,FALSE,FALSE); DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Saw string before '%s'\n", s); 762597 } ); 762597 if (PL_expect == XOPERATOR) { 2 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { 2 PL_expect = XTERM; 2 depcom(); 2 return REPORT(','); /* grandfather non-comma-format format */ } else ###### no_op("String",s); } 762595 if (!s) ###### missingterm((char*)0); 762595 yylval.ival = OP_CONST; /* FIXME. I think that this can be const if char *d is replaced by more localised variables. */ 5677019 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) { 5456001 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) { 541577 yylval.ival = OP_STRINGIFY; 541577 break; } } 762595 TERM(sublex_start()); case '`': 2160 s = scan_str(s,FALSE,FALSE); DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Saw backtick string before '%s'\n", s); 2160 } ); 2160 if (PL_expect == XOPERATOR) ###### no_op("Backticks",s); 2160 if (!s) ###### missingterm((char*)0); 2160 yylval.ival = OP_BACKTICK; 2160 set_csh(); 2160 TERM(sublex_start()); case '\\': 89292 s++; 89292 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s)) 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression", *s, *s); 89292 if (PL_expect == XOPERATOR) ###### no_op("Backslash",s); 89292 OPERATOR(REFGEN); case 'v': 47194 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) { 1598 char *start = s + 2; 1834 while (isDIGIT(*start) || *start == '_') 236 start++; 1598 if (*start == '.' && isDIGIT(start[1])) { 1566 s = scan_num(s, &yylval); 1566 TERM(THING); } /* avoid v123abc() or $h{v1}, allow C */ 32 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE || PL_expect == XTERMORDORDOR)) { 32 const char c = *start; 32 GV *gv; 32 *start = '\0'; 32 gv = gv_fetchpv(s, FALSE, SVt_PVCV); 32 *start = c; 32 if (!gv) { 31 s = scan_num(s, &yylval); 31 TERM(THING); } } } 10296 goto keylookup; case 'x': 10296 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) { 126 s++; 126 Mop(OP_REPEAT); } 4471483 goto keylookup; case '_': case 'a': case 'A': case 'b': case 'B': case 'c': case 'C': case 'd': case 'D': case 'e': case 'E': case 'f': case 'F': case 'g': case 'G': case 'h': case 'H': case 'i': case 'I': case 'j': case 'J': case 'k': case 'K': case 'l': case 'L': case 'm': case 'M': case 'n': case 'N': case 'o': case 'O': case 'p': case 'P': case 'q': case 'Q': case 'r': case 'R': case 's': case 'S': case 't': case 'T': case 'u': case 'U': case 'V': case 'w': case 'W': case 'X': case 'y': case 'Y': case 'z': case 'Z': keylookup: { 4471483 orig_keyword = 0; 4471483 gv = Nullgv; 4471483 gvp = 0; 4471483 PL_bufptr = s; 4471483 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); /* Some keywords can be followed by any delimiter, including ':' */ 4471483 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) || (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') || (PL_tokenbuf[0] == 'q' && strchr("qwxr", PL_tokenbuf[1]))))); /* x::* is just a word, unless x is "CORE" */ 4471483 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE")) 116039 goto just_a_word; 4355444 d = s; 7892199 while (d < PL_bufend && isSPACE(*d)) 3536755 d++; /* no comments skipped here, or s### is misparsed */ /* Is this a label? */ 4355444 if (!tmp && PL_expect == XSTATE && d < PL_bufend && *d == ':' && *(d + 1) != ':') { 7104 s = d + 1; 7104 yylval.pval = savepv(PL_tokenbuf); 7104 CLINE; 7104 TOKEN(LABEL); } /* Check for keywords */ 4348340 tmp = keyword(PL_tokenbuf, len); /* Is this a word before a => operator? */ 4348340 if (*d == '=' && d[1] == '>') { 128987 CLINE; 128987 yylval.opval = (OP*)newSVOP(OP_CONST, 0, S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len)); 128987 yylval.opval->op_private = OPpCONST_BARE; 128987 TERM(WORD); } 4219353 if (tmp < 0) { /* second-class keyword? */ 909147 GV *ogv = Nullgv; /* override (winner) */ 909147 GV *hgv = Nullgv; /* hidden (loser) */ 909147 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) { 593990 CV *cv; 593990 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) && (cv = GvCVu(gv))) { 1547 if (GvIMPORTED_CV(gv)) 289 ogv = gv; 1258 else if (! CvMETHOD(cv)) 1258 hgv = gv; } 593990 if (!ogv && (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) && (gv = *gvp) != (GV*)&PL_sv_undef && GvCVu(gv) && GvIMPORTED_CV(gv)) { 8 ogv = gv; } } 909147 if (ogv) { 297 orig_keyword = tmp; 297 tmp = 0; /* overridden by import or by GLOBAL */ } 908850 else if (gv && !gvp && -tmp==KEY_lock /* XXX generalizable kludge */ && GvCVu(gv) && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE)) { 1248 tmp = 0; /* any sub overrides "weak" keyword */ } 907602 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 */ 4 tmp = 0; } else { /* no override */ 907598 tmp = -tmp; 907598 if (tmp == KEY_dump && ckWARN(WARN_MISC)) { 1 Perl_warner(aTHX_ packWARN(WARN_MISC), "dump() better written as CORE::dump()"); } 907598 gv = Nullgv; 907598 gvp = 0; 907598 if (ckWARN(WARN_AMBIGUOUS) && hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */ 1 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous call resolved as CORE::%s(), %s", GvENAME(hgv), "qualify as such or use &"); } } reserved_word: 4224384 switch (tmp) { default: /* not a keyword */ just_a_word: { 468471 SV *sv; 468471 int pkgname = 0; 468471 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); /* Get the rest if it looks like a package qualifier */ 468471 if (*s == '\'' || (*s == ':' && s[1] == ':')) { 116193 STRLEN morelen; 116193 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len, TRUE, &morelen); 116193 if (!morelen) ###### Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf, *s == '\'' ? "'" : "::"); 116193 len += morelen; 116193 pkgname = 1; } 468471 if (PL_expect == XOPERATOR) { 11 if (PL_bufptr == PL_linestart) { 1 CopLINE_dec(PL_curcop); 1 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi); 1 CopLINE_inc(PL_curcop); } else 10 no_op("Bareword",s); } /* Look for a subroutine with this name in current package, unless name is "Foo::", in which case Foo is a bearword (and a package name). */ 468471 if (len > 2 && PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':') { 18 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV)) 1 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword \"%s\" refers to nonexistent package", PL_tokenbuf); 18 len -= 2; 18 PL_tokenbuf[len] = '\0'; 18 gv = Nullgv; 18 gvp = 0; } else { 468453 len = 0; 468453 if (!gv) 466904 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV); } /* if we saw a global override before, get the right name */ 468471 if (gvp) { 8 sv = newSVpvn("CORE::GLOBAL::",14); 8 sv_catpv(sv,PL_tokenbuf); } 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. */ 468463 sv = newSVpv(PL_tokenbuf,len); } /* Presume this is going to be a bareword of some sort. */ 468471 CLINE; 468471 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); 468471 yylval.opval->op_private = OPpCONST_BARE; /* UTF-8 package name? */ 468471 if (UTF && !IN_BYTES && is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv))) 213 SvUTF8_on(sv); /* And if "Foo::", then that's what it certainly is. */ 468471 if (len) 18 goto safe_bareword; /* See if it's the indirect object for a list operator. */ 468453 if (PL_oldoldbufptr && PL_oldoldbufptr < PL_bufptr && (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) && /* NO SKIPSPACE BEFORE HERE! */ (PL_expect == XREF || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF)) { 49436 bool immediate_paren = *s == '('; /* (Now we can afford to cross potential line boundary.) */ 49436 s = skipspace(s); /* Two barewords in a row may indicate method call. */ 49436 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv))) ###### return REPORT(tmp); /* If not a declared subroutine, it's an indirect object. */ /* (But it's an indir obj regardless for sort.) */ 49436 if ( !immediate_paren && (PL_last_lop_op == OP_SORT || ((!gv || !GvCVu(gv)) && (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)))) { 46683 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR; 46683 goto bareword; } } 421770 PL_expect = XOPERATOR; 421770 s = skipspace(s); /* Is this a word before a => operator? */ 421770 if (*s == '=' && s[1] == '>' && !pkgname) { 11 CLINE; 11 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf); 11 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len)) ###### SvUTF8_on(((SVOP*)yylval.opval)->op_sv); 11 TERM(WORD); } /* If followed by a paren, it's certainly a subroutine. */ 421759 if (*s == '(') { 315755 CLINE; 315755 if (gv && GvCVu(gv)) { 206469 for (d = s + 1; SPACE_OR_TAB(*d); d++) ; 206469 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) { 157 s = d + 1; 157 goto its_constant; } } 315598 PL_nextval[PL_nexttoke].opval = yylval.opval; 315598 PL_expect = XOPERATOR; 315598 force_next(WORD); 315598 yylval.ival = 0; 315598 TOKEN('&'); } /* If followed by var or block, call it a method (unless sub) */ 106004 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) { 57 PL_last_lop = PL_oldbufptr; 57 PL_last_lop_op = OP_METHOD; 57 PREBLOCK(METHOD); } /* If followed by a bareword, see if it looks like indir obj. */ 105947 if (!orig_keyword && (isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv))) 5390 return REPORT(tmp); /* Not a method, so call it a subroutine (if defined) */ 100557 if (gv && GvCVu(gv)) { 66213 CV* cv; 66213 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS)) 5 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of -%s resolved as -&%s()", PL_tokenbuf, PL_tokenbuf); /* Check for a constant sub */ 66213 cv = GvCV(gv); 66213 if ((sv = cv_const_sv(cv))) { its_constant: 19211 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv); 19211 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv); 19211 yylval.opval->op_private = 0; 19211 TOKEN(WORD); } /* Resolve to GV now. */ 47159 op_free(yylval.opval); 47159 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); 47159 yylval.opval->op_private |= OPpENTERSUB_NOPAREN; 47159 PL_last_lop = PL_oldbufptr; 47159 PL_last_lop_op = OP_ENTERSUB; /* Is there a prototype? */ 47159 if (SvPOK(cv)) { 4263 STRLEN len; 4263 const char *proto = SvPV_const((SV*)cv, len); 4263 if (!len) 1276 TERM(FUNC0SUB); 2987 if (*proto == '$' && proto[1] == '\0') 582 OPERATOR(UNIOPSUB); 2436 while (*proto == ';') 31 proto++; 2405 if (*proto == '&' && *s == '{') { 547 sv_setpv(PL_subname, PL_curstash ? "__ANON__" : "__ANON__::__ANON__"); 547 PREBLOCK(LSTOPSUB); } } 44754 PL_nextval[PL_nexttoke].opval = yylval.opval; 44754 PL_expect = XTERM; 44754 force_next(WORD); 44754 TOKEN(NOAMP); } /* Call it a bare word */ 34344 if (PL_hints & HINT_STRICT_SUBS) 26902 yylval.opval->op_private |= OPpCONST_STRICT; else { bareword: 54125 if (ckWARN(WARN_RESERVED)) { 22343 if (lastchar != '-') { 22342 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ; 22342 if (!*d && !gv_stashpv(PL_tokenbuf,FALSE)) 1 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved, PL_tokenbuf); } } } safe_bareword: 81045 if ((lastchar == '*' || lastchar == '%' || lastchar == '&') && ckWARN_d(WARN_AMBIGUOUS)) { 3 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Operator or semicolon missing before %c%s", lastchar, PL_tokenbuf); 3 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of %c resolved as operator %c", lastchar, lastchar); } 81045 TOKEN(WORD); } case KEY___FILE__: 260 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0)); 260 TERM(THING); case KEY___LINE__: 116 yylval.opval = (OP*)newSVOP(OP_CONST, 0, Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop))); 116 TERM(THING); case KEY___PACKAGE__: 4972 yylval.opval = (OP*)newSVOP(OP_CONST, 0, (PL_curstash ? newSVhek(HvNAME_HEK(PL_curstash)) : &PL_sv_undef)); 4972 TERM(THING); case KEY___DATA__: case KEY___END__: { 15515 GV *gv; 15515 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) { 284 const char *pname = "main"; 284 if (PL_tokenbuf[2] == 'D') 128 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash); 284 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO); 284 GvMULTI_on(gv); 284 if (!GvIO(gv)) ###### GvIOp(gv) = newIO(); 284 IoIFP(GvIOp(gv)) = PL_rsfp; #if defined(HAS_FCNTL) && defined(F_SETFD) { 284 const int fd = PerlIO_fileno(PL_rsfp); 284 fcntl(fd,F_SETFD,fd >= 3); } #endif /* Mark this internal pseudo-handle as clean */ 284 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT; 284 if (PL_preprocess) ###### IoTYPE(GvIOp(gv)) = IoTYPE_PIPE; 284 else if ((PerlIO*)PL_rsfp == PerlIO_stdin()) ###### IoTYPE(GvIOp(gv)) = IoTYPE_STD; else 284 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY; #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS) /* if the script was opened in binmode, we need to revert * it to text mode for compatibility; but only iff it has CRs * XXX this is a questionable hack at best. */ if (PL_bufend-PL_bufptr > 2 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r') { Off_t loc = 0; if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) { loc = PerlIO_tell(PL_rsfp); (void)PerlIO_seek(PL_rsfp, 0L, 0); } #ifdef NETWARE if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) { #else if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) { #endif /* NETWARE */ #ifdef PERLIO_IS_STDIO /* really? */ # if defined(__BORLANDC__) /* XXX see note in do_binmode() */ ((FILE*)PL_rsfp)->flags &= ~_F_BIN; # endif #endif if (loc > 0) PerlIO_seek(PL_rsfp, loc, 0); } } #endif #ifdef PERLIO_LAYERS 284 if (!IN_BYTES) { 283 if (UTF) 2 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8"); 281 else if (PL_encoding) { 7 SV *name; 7 dSP; 7 ENTER; 7 SAVETMPS; 7 PUSHMARK(sp); 7 EXTEND(SP, 1); 7 XPUSHs(PL_encoding); 7 PUTBACK; 7 call_method("name", G_SCALAR); 7 SPAGAIN; 7 name = POPs; 7 PUTBACK; 7 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, Perl_form(aTHX_ ":encoding(%"SVf")", name)); 7 FREETMPS; 7 LEAVE; } } #endif 284 PL_rsfp = Nullfp; } 284 goto fake_eof; } case KEY_AUTOLOAD: case KEY_DESTROY: case KEY_BEGIN: case KEY_CHECK: case KEY_INIT: case KEY_END: 7231 if (PL_expect == XSTATE) { 7230 s = PL_bufptr; 7230 goto really_sub; } 5031 goto just_a_word; case KEY_CORE: 5031 if (*s == ':' && s[1] == ':') { 5031 s += 2; 5031 d = s; 5031 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); 5031 if (!(tmp = keyword(PL_tokenbuf, len))) ###### Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf); 5031 if (tmp < 0) 5002 tmp = -tmp; 5002 goto reserved_word; } 1934 goto just_a_word; case KEY_abs: 1934 UNI(OP_ABS); case KEY_alarm: 37 UNI(OP_ALARM); case KEY_accept: 16 LOP(OP_ACCEPT,XTERM); case KEY_and: 45343 OPERATOR(ANDOP); case KEY_atan2: 166 LOP(OP_ATAN2,XTERM); case KEY_bind: 56 LOP(OP_BIND,XTERM); case KEY_binmode: 2454 LOP(OP_BINMODE,XTERM); case KEY_bless: 5926 LOP(OP_BLESS,XTERM); case KEY_chop: 2247 UNI(OP_CHOP); case KEY_continue: 756 PREBLOCK(CONTINUE); case KEY_chdir: 4374 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */ 4374 UNI(OP_CHDIR); case KEY_close: 11032 UNI(OP_CLOSE); case KEY_closedir: 2635 UNI(OP_CLOSEDIR); case KEY_cmp: 3231 Eop(OP_SCMP); case KEY_caller: 32088 UNI(OP_CALLER); case KEY_crypt: #ifdef FCRYPT if (!PL_cryptseen) { PL_cryptseen = TRUE; init_des(); } #endif 9 LOP(OP_CRYPT,XTERM); case KEY_chmod: 4536 LOP(OP_CHMOD,XTERM); case KEY_chown: 5 LOP(OP_CHOWN,XTERM); case KEY_connect: 84 LOP(OP_CONNECT,XTERM); case KEY_chr: 1454 UNI(OP_CHR); case KEY_cos: 168 UNI(OP_COS); case KEY_chroot: 2 UNI(OP_CHROOT); case KEY_do: 17147 s = skipspace(s); 17147 if (*s == '{') 16029 PRETERMBLOCK(DO); 1118 if (*s != '\'') 1015 s = force_word(s,WORD,TRUE,TRUE,FALSE); 1118 OPERATOR(DO); case KEY_die: 29596 PL_hints |= HINT_BLOCK_SCOPE; 29596 LOP(OP_DIE,XTERM); case KEY_defined: 122592 UNI(OP_DEFINED); case KEY_delete: 10834 UNI(OP_DELETE); case KEY_dbmopen: 2 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV); 2 LOP(OP_DBMOPEN,XTERM); case KEY_dbmclose: 2 UNI(OP_DBMCLOSE); case KEY_dump: 3 s = force_word(s,WORD,TRUE,FALSE,FALSE); 3 LOOPX(OP_DUMP); case KEY_else: 97851 PREBLOCK(ELSE); case KEY_elsif: 67708 yylval.ival = CopLINE(PL_curcop); 67708 OPERATOR(ELSIF); case KEY_eq: 163908 Eop(OP_SEQ); case KEY_exists: 23185 UNI(OP_EXISTS); case KEY_exit: 3486 UNI(OP_EXIT); case KEY_eval: 22067 s = skipspace(s); 22067 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM; 22067 UNIBRACK(OP_ENTEREVAL); case KEY_eof: 385 UNI(OP_EOF); case KEY_err: 10 OPERATOR(DOROP); case KEY_exp: 195 UNI(OP_EXP); case KEY_each: 2335 UNI(OP_EACH); case KEY_exec: 385 set_csh(); 385 LOP(OP_EXEC,XREF); case KEY_endhostent: 1 FUN0(OP_EHOSTENT); case KEY_endnetent: 1 FUN0(OP_ENETENT); case KEY_endservent: 1 FUN0(OP_ESERVENT); case KEY_endprotoent: 1 FUN0(OP_EPROTOENT); case KEY_endpwent: 5 FUN0(OP_EPWENT); case KEY_endgrent: 4 FUN0(OP_EGRENT); case KEY_for: case KEY_foreach: 76905 yylval.ival = CopLINE(PL_curcop); 76905 s = skipspace(s); 76905 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) { 33297 char *p = s; 33297 if ((PL_bufend - p) >= 3 && strnEQ(p, "my", 2) && isSPACE(*(p + 2))) 33290 p += 2; 7 else if ((PL_bufend - p) >= 4 && strnEQ(p, "our", 3) && isSPACE(*(p + 3))) 7 p += 3; 33297 p = skipspace(p); 33297 if (isIDFIRST_lazy_if(p,UTF)) { ###### p = scan_ident(p, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE); ###### p = skipspace(p); } 33297 if (*p != '$') ###### Perl_croak(aTHX_ "Missing $ on loop variable"); } 76905 OPERATOR(FOR); case KEY_formline: 99 LOP(OP_FORMLINE,XTERM); case KEY_fork: 70 FUN0(OP_FORK); case KEY_fcntl: 119 LOP(OP_FCNTL,XTERM); case KEY_fileno: 855 UNI(OP_FILENO); case KEY_flock: 68 LOP(OP_FLOCK,XTERM); case KEY_gt: 79 Rop(OP_SGT); case KEY_ge: 5579 Rop(OP_SGE); case KEY_grep: 13071 LOP(OP_GREPSTART, XREF); case KEY_goto: 38125 s = force_word(s,WORD,TRUE,FALSE,FALSE); 38125 LOOPX(OP_GOTO); case KEY_gmtime: 222 UNI(OP_GMTIME); case KEY_getc: 130 UNIDOR(OP_GETC); case KEY_getppid: 8 FUN0(OP_GETPPID); case KEY_getpgrp: 5 UNI(OP_GETPGRP); case KEY_getpriority: 5 LOP(OP_GETPRIORITY,XTERM); case KEY_getprotobyname: 82 UNI(OP_GPBYNAME); case KEY_getprotobynumber: 15 LOP(OP_GPBYNUMBER,XTERM); case KEY_getprotoent: 4 FUN0(OP_GPROTOENT); case KEY_getpwent: 6 FUN0(OP_GPWENT); case KEY_getpwnam: 103 UNI(OP_GPWNAM); case KEY_getpwuid: 130 UNI(OP_GPWUID); case KEY_getpeername: 62 UNI(OP_GETPEERNAME); case KEY_gethostbyname: 37 UNI(OP_GHBYNAME); case KEY_gethostbyaddr: 9 LOP(OP_GHBYADDR,XTERM); case KEY_gethostent: 3 FUN0(OP_GHOSTENT); case KEY_getnetbyname: 5 UNI(OP_GNBYNAME); case KEY_getnetbyaddr: 3 LOP(OP_GNBYADDR,XTERM); case KEY_getnetent: 3 FUN0(OP_GNETENT); case KEY_getservbyname: 69 LOP(OP_GSBYNAME,XTERM); case KEY_getservbyport: 4 LOP(OP_GSBYPORT,XTERM); case KEY_getservent: 4 FUN0(OP_GSERVENT); case KEY_getsockname: 18 UNI(OP_GETSOCKNAME); case KEY_getsockopt: 26 LOP(OP_GSOCKOPT,XTERM); case KEY_getgrent: 4 FUN0(OP_GGRENT); case KEY_getgrnam: 5 UNI(OP_GGRNAM); case KEY_getgrgid: 17 UNI(OP_GGRGID); case KEY_getlogin: 4 FUN0(OP_GETLOGIN); case KEY_glob: 496 set_csh(); 496 LOP(OP_GLOB,XTERM); case KEY_hex: 1076 UNI(OP_HEX); case KEY_if: 449054 yylval.ival = CopLINE(PL_curcop); 449054 OPERATOR(IF); case KEY_index: 4526 LOP(OP_INDEX,XTERM); case KEY_int: 4843 UNI(OP_INT); case KEY_ioctl: 105 LOP(OP_IOCTL,XTERM); case KEY_join: 23488 LOP(OP_JOIN,XTERM); case KEY_keys: 18330 UNI(OP_KEYS); case KEY_kill: 100 LOP(OP_KILL,XTERM); case KEY_last: 23012 s = force_word(s,WORD,TRUE,FALSE,FALSE); 23012 LOOPX(OP_LAST); case KEY_lc: 3677 UNI(OP_LC); case KEY_lcfirst: 14 UNI(OP_LCFIRST); case KEY_local: 51078 yylval.ival = 0; 51078 OPERATOR(LOCAL); case KEY_length: 22580 UNI(OP_LENGTH); case KEY_lt: 193 Rop(OP_SLT); case KEY_le: 3754 Rop(OP_SLE); case KEY_localtime: 573 UNI(OP_LOCALTIME); case KEY_log: 191 UNI(OP_LOG); case KEY_link: 39 LOP(OP_LINK,XTERM); case KEY_listen: 16 LOP(OP_LISTEN,XTERM); case KEY_lock: 1 UNI(OP_LOCK); case KEY_lstat: 2649 UNI(OP_LSTAT); case KEY_m: 29770 s = scan_pat(s,OP_MATCH); 29764 TERM(sublex_start()); case KEY_map: 19639 LOP(OP_MAPSTART, XREF); case KEY_mkdir: 681 LOP(OP_MKDIR,XTERM); case KEY_msgctl: 7 LOP(OP_MSGCTL,XTERM); case KEY_msgget: 4 LOP(OP_MSGGET,XTERM); case KEY_msgrcv: 4 LOP(OP_MSGRCV,XTERM); case KEY_msgsnd: 4 LOP(OP_MSGSND,XTERM); case KEY_our: case KEY_my: 640466 PL_in_my = tmp; 640466 s = skipspace(s); 640466 if (isIDFIRST_lazy_if(s,UTF)) { 30 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); 30 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3)) ###### goto really_sub; 30 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len); 30 if (!PL_in_my_stash) { 3 char tmpbuf[1024]; 3 PL_bufptr = s; 3 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf); 3 yyerror(tmpbuf); } } 640466 yylval.ival = 1; 640466 OPERATOR(MY); case KEY_next: 29686 s = force_word(s,WORD,TRUE,FALSE,FALSE); 29686 LOOPX(OP_NEXT); case KEY_ne: 25453 Eop(OP_SNE); case KEY_no: 12055 if (PL_expect != XSTATE) ###### yyerror("\"no\" not allowed in expression"); 12055 s = force_word(s,WORD,FALSE,TRUE,FALSE); 12055 s = force_version(s, FALSE); 12055 yylval.ival = 0; 12055 OPERATOR(USE); case KEY_not: 18568 if (*s == '(' || (s = skipspace(s), *s == '(')) 9375 FUN1(OP_NOT); else 9193 OPERATOR(NOTOP); case KEY_open: 10448 s = skipspace(s); 10448 if (isIDFIRST_lazy_if(s,UTF)) { 2130 const char *t; 2130 for (d = s; isALNUM_lazy_if(d,UTF); d++) ; 2130 for (t=d; *t && isSPACE(*t); t++) ; 2130 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE) /* [perl #16184] */ && !(t[0] == '=' && t[1] == '>') ) { 4 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE), "Precedence problem: open %.*s should be open(%.*s)", d - s, s, d - s, s); } } 10448 LOP(OP_OPEN,XTERM); case KEY_or: 54424 yylval.ival = OP_OR; 54424 OPERATOR(OROP); case KEY_ord: 3574 UNI(OP_ORD); case KEY_oct: 953 UNI(OP_OCT); case KEY_opendir: 1936 LOP(OP_OPEN_DIR,XTERM); case KEY_print: 60989 checkcomma(s,PL_tokenbuf,"filehandle"); 60989 LOP(OP_PRINT,XREF); case KEY_printf: 1059 checkcomma(s,PL_tokenbuf,"filehandle"); 1059 LOP(OP_PRTF,XREF); case KEY_prototype: 188 UNI(OP_PROTOTYPE); case KEY_push: 53718 LOP(OP_PUSH,XTERM); case KEY_pop: 9438 UNIDOR(OP_POP); case KEY_pos: 2471 UNIDOR(OP_POS); case KEY_pack: 2209 LOP(OP_PACK,XTERM); case KEY_package: 39129 s = force_word(s,WORD,FALSE,TRUE,FALSE); 39129 OPERATOR(PACKAGE); case KEY_pipe: 70 LOP(OP_PIPE_OP,XTERM); case KEY_q: 7311 s = scan_str(s,FALSE,FALSE); 7311 if (!s) 1 missingterm((char*)0); 7310 yylval.ival = OP_CONST; 7310 TERM(sublex_start()); case KEY_quotemeta: 506 UNI(OP_QUOTEMETA); case KEY_qw: 54440 s = scan_str(s,FALSE,FALSE); 54440 if (!s) 1 missingterm((char*)0); 54439 PL_expect = XOPERATOR; 54439 force_next(')'); 54439 if (SvCUR(PL_lex_stuff)) { 54324 OP *words = Nullop; 54324 int warned = 0; 54324 d = SvPV_force(PL_lex_stuff, len); 426014 while (len) { 1069312 SV *sv; 1069312 for (; isSPACE(*d) && len; --len, ++d) ; 371690 if (len) { 364094 const char *b = d; 364094 if (!warned && ckWARN(WARN_QW)) { 1469384 for (; !isSPACE(*d) && len; --len, ++d) { 688436 if (*d == ',') { 1 Perl_warner(aTHX_ packWARN(WARN_QW), "Possible attempt to separate words with commas"); 1 ++warned; } 688435 else if (*d == '#') { 1 Perl_warner(aTHX_ packWARN(WARN_QW), "Possible attempt to put comments in qw() list"); 1 ++warned; } } } else { 2561711 for (; !isSPACE(*d) && len; --len, ++d) ; } 364094 sv = newSVpvn(b, d-b); 364094 if (DO_UTF8(PL_lex_stuff)) 5 SvUTF8_on(sv); 364094 words = append_elem(OP_LIST, words, newSVOP(OP_CONST, 0, tokeq(sv))); } } 54324 if (words) { 54290 PL_nextval[PL_nexttoke].opval = words; 54290 force_next(THING); } } 54439 if (PL_lex_stuff) { 54439 SvREFCNT_dec(PL_lex_stuff); 54439 PL_lex_stuff = Nullsv; } 54439 PL_expect = XTERM; 54439 TOKEN('('); case KEY_qq: 14049 s = scan_str(s,FALSE,FALSE); 14049 if (!s) 1 missingterm((char*)0); 14048 yylval.ival = OP_STRINGIFY; 14048 if (SvIVX(PL_lex_stuff) == '\'') 12 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */ 14048 TERM(sublex_start()); case KEY_qr: 9659 s = scan_pat(s,OP_QR); 9652 TERM(sublex_start()); case KEY_qx: 21 s = scan_str(s,FALSE,FALSE); 21 if (!s) 1 missingterm((char*)0); 20 yylval.ival = OP_BACKTICK; 20 set_csh(); 20 TERM(sublex_start()); case KEY_return: 193588 OLDLOP(OP_RETURN); case KEY_require: 84668 s = skipspace(s); 84668 if (isDIGIT(*s)) { 3663 s = force_version(s, FALSE); } 81005 else if (*s != 'v' || !isDIGIT(s[1]) || (s = force_version(s, TRUE), *s == 'v')) { 81002 *PL_tokenbuf = '\0'; 81002 s = force_word(s,WORD,TRUE,TRUE,FALSE); 81002 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF)) 74948 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE); 6054 else if (*s == '<') ###### yyerror("<> should be quotes"); } 84668 UNI(OP_REQUIRE); case KEY_reset: 13 UNI(OP_RESET); case KEY_redo: 2978 s = force_word(s,WORD,TRUE,FALSE,FALSE); 2978 LOOPX(OP_REDO); case KEY_rename: 1202 LOP(OP_RENAME,XTERM); case KEY_rand: 174 UNI(OP_RAND); case KEY_rmdir: 638 UNI(OP_RMDIR); case KEY_rindex: 389 LOP(OP_RINDEX,XTERM); case KEY_read: 1792 LOP(OP_READ,XTERM); case KEY_readdir: 2514 UNI(OP_READDIR); case KEY_readline: 27 set_csh(); 27 UNIDOR(OP_READLINE); case KEY_readpipe: ###### set_csh(); ###### UNI(OP_BACKTICK); case KEY_rewinddir: 100 UNI(OP_REWINDDIR); case KEY_recv: 32 LOP(OP_RECV,XTERM); case KEY_reverse: 1585 LOP(OP_REVERSE,XTERM); case KEY_readlink: 887 UNIDOR(OP_READLINK); case KEY_ref: 53830 UNI(OP_REF); case KEY_s: 77195 s = scan_subst(s); 77189 if (yylval.opval) 77189 TERM(sublex_start()); else ###### TOKEN(1); /* force error */ case KEY_chomp: 4584 UNI(OP_CHOMP); case KEY_scalar: 7603 UNI(OP_SCALAR); case KEY_select: 2124 LOP(OP_SELECT,XTERM); case KEY_seek: 465 LOP(OP_SEEK,XTERM); case KEY_semctl: 17 LOP(OP_SEMCTL,XTERM); case KEY_semget: 3 LOP(OP_SEMGET,XTERM); case KEY_semop: 2 LOP(OP_SEMOP,XTERM); case KEY_send: 59 LOP(OP_SEND,XTERM); case KEY_setpgrp: 2 LOP(OP_SETPGRP,XTERM); case KEY_setpriority: 2 LOP(OP_SETPRIORITY,XTERM); case KEY_sethostent: 1 UNI(OP_SHOSTENT); case KEY_setnetent: 1 UNI(OP_SNETENT); case KEY_setservent: 1 UNI(OP_SSERVENT); case KEY_setprotoent: 1 UNI(OP_SPROTOENT); case KEY_setpwent: 7 FUN0(OP_SPWENT); case KEY_setgrent: 4 FUN0(OP_SGRENT); case KEY_seekdir: 3 LOP(OP_SEEKDIR,XTERM); case KEY_setsockopt: 118 LOP(OP_SSOCKOPT,XTERM); case KEY_shift: 96319 UNIDOR(OP_SHIFT); case KEY_shmctl: 2 LOP(OP_SHMCTL,XTERM); case KEY_shmget: 2 LOP(OP_SHMGET,XTERM); case KEY_shmread: 2 LOP(OP_SHMREAD,XTERM); case KEY_shmwrite: 2 LOP(OP_SHMWRITE,XTERM); case KEY_shutdown: 18 LOP(OP_SHUTDOWN,XTERM); case KEY_sin: 195 UNI(OP_SIN); case KEY_sleep: 114 UNI(OP_SLEEP); case KEY_socket: 80 LOP(OP_SOCKET,XTERM); case KEY_socketpair: 16 LOP(OP_SOCKPAIR,XTERM); case KEY_sort: 8352 checkcomma(s,PL_tokenbuf,"subroutine name"); 8352 s = skipspace(s); 8352 if (*s == ';' || *s == ')') /* probably a close */ ###### Perl_croak(aTHX_ "sort is now a reserved word"); 8352 PL_expect = XTERM; 8352 s = force_word(s,WORD,TRUE,TRUE,FALSE); 8352 LOP(OP_SORT,XREF); case KEY_split: 12931 LOP(OP_SPLIT,XTERM); case KEY_sprintf: 14880 LOP(OP_SPRINTF,XTERM); case KEY_splice: 3308 LOP(OP_SPLICE,XTERM); case KEY_sqrt: 256 UNI(OP_SQRT); case KEY_srand: 15 UNI(OP_SRAND); case KEY_stat: 7071 UNI(OP_STAT); case KEY_study: 4588 UNI(OP_STUDY); case KEY_substr: 16286 LOP(OP_SUBSTR,XTERM); case KEY_format: case KEY_sub: really_sub: { 314466 char tmpbuf[sizeof PL_tokenbuf]; 314466 SSize_t tboffset = 0; 314466 expectation attrful; 314466 bool have_name, have_proto, bad_proto; 314466 const int key = tmp; 314466 s = skipspace(s); 314466 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' || (*s == ':' && s[1] == ':')) { 296122 PL_expect = XBLOCK; 296122 attrful = XATTRBLOCK; /* remember buffer pos'n for later force_word */ 296122 tboffset = s - PL_oldbufptr; 296122 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); 296122 if (strchr(tmpbuf, ':')) 3290 sv_setpv(PL_subname, tmpbuf); else { 292832 sv_setsv(PL_subname,PL_curstname); 292832 sv_catpvn(PL_subname,"::",2); 292832 sv_catpvn(PL_subname,tmpbuf,len); } 296122 s = skipspace(d); 296122 have_name = TRUE; } else { 18344 if (key == KEY_my) ###### Perl_croak(aTHX_ "Missing name in \"my sub\""); 18344 PL_expect = XTERMBLOCK; 18344 attrful = XATTRTERM; 18344 sv_setpvn(PL_subname,"?",1); 18344 have_name = FALSE; } 314466 if (key == KEY_format) { 89 if (*s == '=') 89 PL_lex_formbrack = PL_lex_brackets + 1; 89 if (have_name) 86 (void) force_word(PL_oldbufptr + tboffset, WORD, FALSE, TRUE, TRUE); 89 OPERATOR(FORMAT); } /* Look for a prototype */ 314377 if (*s == '(') { 28863 char *p; 28863 s = scan_str(s,FALSE,FALSE); 28863 if (!s) ###### Perl_croak(aTHX_ "Prototype not terminated"); /* strip spaces and check for bad characters */ 28863 d = SvPVX(PL_lex_stuff); 28863 tmp = 0; 28863 bad_proto = FALSE; 68933 for (p = d; *p; ++p) { 40070 if (!isSPACE(*p)) { 39892 d[tmp++] = *p; 39892 if (!strchr("$@%*;[]&\\", *p)) 12 bad_proto = TRUE; } } 28863 d[tmp] = '\0'; 28863 if (bad_proto && ckWARN(WARN_SYNTAX)) 4 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Illegal character in prototype for %"SVf" : %s", PL_subname, d); 28863 SvCUR_set(PL_lex_stuff, tmp); 28863 have_proto = TRUE; 28863 s = skipspace(s); } else 285514 have_proto = FALSE; 314377 if (*s == ':' && s[1] != ':') 113 PL_expect = attrful; 314264 else if (*s != '{' && key == KEY_sub) { 30705 if (!have_name) 6 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine"); 30699 else if (*s != ';') 2 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname); } 314369 if (have_proto) { 28861 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff); 28861 PL_lex_stuff = Nullsv; 28861 force_next(THING); } 314369 if (!have_name) { 18335 sv_setpv(PL_subname, PL_curstash ? "__ANON__" : "__ANON__::__ANON__"); 18335 TOKEN(ANONSUB); } 296034 (void) force_word(PL_oldbufptr + tboffset, WORD, FALSE, TRUE, TRUE); 296034 if (key == KEY_my) ###### TOKEN(MYSUB); 296034 TOKEN(SUB); } case KEY_system: 864 set_csh(); 864 LOP(OP_SYSTEM,XREF); case KEY_symlink: 25 LOP(OP_SYMLINK,XTERM); case KEY_syscall: 18 LOP(OP_SYSCALL,XTERM); case KEY_sysopen: 133 LOP(OP_SYSOPEN,XTERM); case KEY_sysseek: 79 LOP(OP_SYSSEEK,XTERM); case KEY_sysread: 721 LOP(OP_SYSREAD,XTERM); case KEY_syswrite: 843 LOP(OP_SYSWRITE,XTERM); case KEY_tr: 6376 s = scan_trans(s); 6371 TERM(sublex_start()); case KEY_tell: 434 UNI(OP_TELL); case KEY_telldir: 5 UNI(OP_TELLDIR); case KEY_tie: 2230 LOP(OP_TIE,XTERM); case KEY_tied: 1521 UNI(OP_TIED); case KEY_time: 585 FUN0(OP_TIME); case KEY_times: 135 FUN0(OP_TMS); case KEY_truncate: 148 LOP(OP_TRUNCATE,XTERM); case KEY_uc: 2739 UNI(OP_UC); case KEY_ucfirst: 27 UNI(OP_UCFIRST); case KEY_untie: 185 UNI(OP_UNTIE); case KEY_until: 204 yylval.ival = CopLINE(PL_curcop); 204 OPERATOR(UNTIL); case KEY_unless: 161485 yylval.ival = CopLINE(PL_curcop); 161485 OPERATOR(UNLESS); case KEY_unlink: 4727 LOP(OP_UNLINK,XTERM); case KEY_undef: 37879 UNIDOR(OP_UNDEF); case KEY_unpack: 1810 LOP(OP_UNPACK,XTERM); case KEY_utime: 959 LOP(OP_UTIME,XTERM); case KEY_umask: 88 UNIDOR(OP_UMASK); case KEY_unshift: 7593 LOP(OP_UNSHIFT,XTERM); case KEY_use: 59984 if (PL_expect != XSTATE) ###### yyerror("\"use\" not allowed in expression"); 59984 s = skipspace(s); 59984 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { 6974 s = force_version(s, TRUE); 6974 if (*s == ';' || (s = skipspace(s), *s == ';')) { 6974 PL_nextval[PL_nexttoke].opval = Nullop; 6974 force_next(WORD); } ###### else if (*s == 'v') { ###### s = force_word(s,WORD,FALSE,TRUE,FALSE); ###### s = force_version(s, FALSE); } } else { 53010 s = force_word(s,WORD,FALSE,TRUE,FALSE); 53010 s = force_version(s, FALSE); } 59984 yylval.ival = 1; 59984 OPERATOR(USE); case KEY_values: 1147 UNI(OP_VALUES); case KEY_vec: 37154 LOP(OP_VEC,XTERM); case KEY_while: 33629 yylval.ival = CopLINE(PL_curcop); 33629 OPERATOR(WHILE); case KEY_warn: 21775 PL_hints |= HINT_BLOCK_SCOPE; 21775 LOP(OP_WARN,XTERM); case KEY_wait: 10 FUN0(OP_WAIT); case KEY_waitpid: 85 LOP(OP_WAITPID,XTERM); case KEY_wantarray: 5760 FUN0(OP_WANTARRAY); case KEY_write: #ifdef EBCDIC { char ctl_l[2]; ctl_l[0] = toCTRL('L'); ctl_l[1] = '\0'; gv_fetchpv(ctl_l,TRUE, SVt_PV); } #else 280 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */ #endif 280 UNI(OP_ENTERWRITE); case KEY_x: 8857 if (PL_expect == XOPERATOR) 8848 Mop(OP_REPEAT); 9 check_uni(); 9 goto just_a_word; case KEY_xor: 1200 yylval.ival = OP_XOR; 1200 OPERATOR(OROP); case KEY_y: 77 s = scan_trans(s); 71 TERM(sublex_start()); } }} } #ifdef __SC__ #pragma segment Main #endif static int S_pending_ident(pTHX) 5127241 { 5127241 register char *d; 5127241 register I32 tmp = 0; /* pit holds the identifier we read and pending_ident is reset */ 5127241 char pit = PL_pending_ident; 5127241 PL_pending_ident = 0; DEBUG_T({ PerlIO_printf(Perl_debug_log, 5127241 "### Tokener saw identifier '%s'\n", PL_tokenbuf); }); /* if we're in a my(), we can't allow dynamics here. $foo'bar has already been turned into $foo::bar, so just check for colons. if it's a legal name, the OP is a PADANY. */ 5127241 if (PL_in_my) { 849655 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */ 68821 if (strchr(PL_tokenbuf,':')) ###### yyerror(Perl_form(aTHX_ "No package name allowed for " "variable %s in \"our\"", PL_tokenbuf)); 68821 tmp = allocmy(PL_tokenbuf); } else { 780834 if (strchr(PL_tokenbuf,':')) ###### yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf)); 780834 yylval.opval = newOP(OP_PADANY, 0); 780834 yylval.opval->op_targ = allocmy(PL_tokenbuf); 780834 return PRIVATEREF; } } /* build the ops for accesses to a my() variable. Deny my($a) or my($b) in a sort block, *if* $a or $b is then used in a comparison. This catches most, but not all cases. For instance, it catches sort { my($a); $a <=> $b } but not sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; } (although why you'd do that is anyone's guess). */ 4346407 if (!strchr(PL_tokenbuf,':')) { 4266501 if (!PL_in_my) 4197680 tmp = pad_findmy(PL_tokenbuf); 4266501 if (tmp != NOT_IN_PAD) { /* might be an "our" variable" */ 3235177 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) { /* build ops for a bareword */ 205985 HV *stash = PAD_COMPNAME_OURSTASH(tmp); 205985 HEK *stashname = HvNAME_HEK(stash); 205985 SV *sym = newSVhek(stashname); 205985 sv_catpvn(sym, "::", 2); 205985 sv_catpv(sym, PL_tokenbuf+1); 205985 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym); 205985 yylval.opval->op_private = OPpCONST_ENTERED; 205985 gv_fetchsv(sym, (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADDMULTI ), ((PL_tokenbuf[0] == '$') ? SVt_PV : (PL_tokenbuf[0] == '@') ? SVt_PVAV : SVt_PVHV)); 205985 return WORD; } /* if it's a sort block and they're naming $a or $b */ 3029192 if (PL_last_lop_op == OP_SORT && PL_tokenbuf[0] == '$' && (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b') && !PL_tokenbuf[2]) { 2308 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart; d < PL_bufend && *d != '\n'; d++) { 2242 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) { ###### Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison", PL_tokenbuf); } } } 3029192 yylval.opval = newOP(OP_PADANY, 0); 3029192 yylval.opval->op_targ = tmp; 3029192 return PRIVATEREF; } } /* Whine if they've said @foo in a doublequoted string, and @foo isn't a variable we can find in the symbol table. */ 1111230 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) { 3281 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV); 3281 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) && ckWARN(WARN_AMBIGUOUS)) { /* Downgraded from fatal to warning 20000522 mjd */ 2 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Possible unintended interpolation of %s in string", PL_tokenbuf); } } /* build ops for a bareword */ 1111230 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0)); 1111230 yylval.opval->op_private = OPpCONST_ENTERED; 1111230 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE, ((PL_tokenbuf[0] == '$') ? SVt_PV : (PL_tokenbuf[0] == '@') ? SVt_PVAV : SVt_PVHV)); 1111230 return WORD; } /* * The following code was generated by perl_keyword.pl. */ I32 Perl_keyword (pTHX_ const char *name, I32 len) 4498037 { 4498037 switch (len) { case 1: /* 5 tokens of length 1 */ 139618 switch (name[0]) { case 'm': { /* m */ 29771 return KEY_m; } case 'q': { /* q */ 7485 return KEY_q; } case 's': { /* s */ 78702 return KEY_s; } case 'x': { /* x */ 8864 return -KEY_x; } case 'y': { /* y */ 79 return KEY_y; } default: 1456410 goto unknown; } case 2: /* 18 tokens of length 2 */ 1456410 switch (name[0]) { case 'd': 17148 if (name[1] == 'o') { /* do */ 17148 return KEY_do; } 164117 goto unknown; case 'e': 164117 if (name[1] == 'q') { /* eq */ 164115 return -KEY_eq; } 5661 goto unknown; case 'g': 5661 switch (name[1]) { case 'e': { /* ge */ 5580 return -KEY_ge; } case 't': { /* gt */ 80 return -KEY_gt; } default: 470230 goto unknown; } case 'i': 470230 if (name[1] == 'f') { /* if */ 465720 return KEY_if; } 7718 goto unknown; case 'l': 7718 switch (name[1]) { case 'c': { /* lc */ 3698 return -KEY_lc; } case 'e': { /* le */ 3755 return -KEY_le; } case 't': { /* lt */ 194 return -KEY_lt; } default: 588422 goto unknown; } case 'm': 588422 if (name[1] == 'y') { /* my */ 588403 return KEY_my; } 37519 goto unknown; case 'n': 37519 switch (name[1]) { case 'e': { /* ne */ 25457 return -KEY_ne; } case 'o': { /* no */ 12056 return KEY_no; } default: 64061 goto unknown; } case 'o': 64061 if (name[1] == 'r') { /* or */ 55597 return -KEY_or; } 78439 goto unknown; case 'q': 78439 switch (name[1]) { case 'q': { /* qq */ 14245 return KEY_qq; } case 'r': { /* qr */ 9661 return KEY_qr; } case 'w': { /* qw */ 54506 return KEY_qw; } case 'x': { /* qx */ 23 return KEY_qx; } default: 6381 goto unknown; } case 't': 6381 if (name[1] == 'r') { /* tr */ 6377 return KEY_tr; } 2745 goto unknown; case 'u': 2745 if (name[1] == 'c') { /* uc */ 2742 return -KEY_uc; } 707721 goto unknown; default: 707721 goto unknown; } case 3: /* 28 tokens of length 3 */ 707721 switch (name[0]) { case 'E': 1098 if (name[1] == 'N' && name[2] == 'D') { /* END */ 1027 return KEY_END; } 51343 goto unknown; case 'a': 51343 switch (name[1]) { case 'b': 1942 if (name[2] == 's') { /* abs */ 1936 return -KEY_abs; } 46244 goto unknown; case 'n': 46244 if (name[2] == 'd') { /* and */ 46243 return -KEY_and; } 8753 goto unknown; default: 8753 goto unknown; } case 'c': 8753 switch (name[1]) { case 'h': 1457 if (name[2] == 'r') { /* chr */ 1457 return -KEY_chr; } 3234 goto unknown; case 'm': 3234 if (name[2] == 'p') { /* cmp */ 3234 return -KEY_cmp; } 217 goto unknown; case 'o': 217 if (name[2] == 's') { /* cos */ 169 return -KEY_cos; } 30775 goto unknown; default: 30775 goto unknown; } case 'd': 30775 if (name[1] == 'i' && name[2] == 'e') { /* die */ 29601 return -KEY_die; } 605 goto unknown; case 'e': 605 switch (name[1]) { case 'o': 386 if (name[2] == 'f') { /* eof */ 386 return -KEY_eof; } 16 goto unknown; case 'r': 16 if (name[2] == 'r') { /* err */ 15 return -KEY_err; } 196 goto unknown; case 'x': 196 if (name[2] == 'p') { /* exp */ 196 return -KEY_exp; } 20929 goto unknown; default: 20929 goto unknown; } case 'f': 20929 if (name[1] == 'o' && name[2] == 'r') { /* for */ 20766 return KEY_for; } 1116 goto unknown; case 'h': 1116 if (name[1] == 'e' && name[2] == 'x') { /* hex */ 1077 return -KEY_hex; } 5476 goto unknown; case 'i': 5476 if (name[1] == 'n' && name[2] == 't') { /* int */ 4844 return -KEY_int; } 665 goto unknown; case 'l': 665 if (name[1] == 'o' && name[2] == 'g') { /* log */ 335 return -KEY_log; } 19962 goto unknown; case 'm': 19962 if (name[1] == 'a' && name[2] == 'p') { /* map */ 19683 return KEY_map; } 21026 goto unknown; case 'n': 21026 if (name[1] == 'o' && name[2] == 't') { /* not */ 18598 return -KEY_not; } 57448 goto unknown; case 'o': 57448 switch (name[1]) { case 'c': 954 if (name[2] == 't') { /* oct */ 954 return -KEY_oct; } 3577 goto unknown; case 'r': 3577 if (name[2] == 'd') { /* ord */ 3577 return -KEY_ord; } 52070 goto unknown; case 'u': 52070 if (name[2] == 'r') { /* our */ 52069 return KEY_our; } 12258 goto unknown; default: 12258 goto unknown; } case 'p': 12258 if (name[1] == 'o') { 11930 switch (name[2]) { case 'p': { /* pop */ 9441 return -KEY_pop; } case 's': { /* pos */ 2489 return KEY_pos; } default: 53949 goto unknown; } } 53949 goto unknown; case 'r': 53949 if (name[1] == 'e' && name[2] == 'f') { /* ref */ 53903 return -KEY_ref; } 307991 goto unknown; case 's': 307991 switch (name[1]) { case 'i': 196 if (name[2] == 'n') { /* sin */ 196 return -KEY_sin; } 307211 goto unknown; case 'u': 307211 if (name[2] == 'b') { /* sub */ 307199 return KEY_sub; } 2953 goto unknown; default: 2953 goto unknown; } case 't': 2953 if (name[1] == 'i' && name[2] == 'e') { /* tie */ 2232 return KEY_tie; } 60013 goto unknown; case 'u': 60013 if (name[1] == 's' && name[2] == 'e') { /* use */ 59985 return KEY_use; } 37158 goto unknown; case 'v': 37158 if (name[1] == 'e' && name[2] == 'c') { /* vec */ 37155 return -KEY_vec; } 1209 goto unknown; case 'x': 1209 if (name[1] == 'o' && name[2] == 'r') { /* xor */ 1202 return -KEY_xor; } 504250 goto unknown; default: 504250 goto unknown; } case 4: /* 40 tokens of length 4 */ 504250 switch (name[0]) { case 'C': 45274 if (name[1] == 'O' && name[2] == 'R' && name[3] == 'E') { /* CORE */ 5031 return -KEY_CORE; } 120 goto unknown; case 'I': 120 if (name[1] == 'N' && name[2] == 'I' && name[3] == 'T') { /* INIT */ 15 return KEY_INIT; } 9048 goto unknown; case 'b': 9048 if (name[1] == 'i' && name[2] == 'n' && name[3] == 'd') { /* bind */ 57 return -KEY_bind; } 11777 goto unknown; case 'c': 11777 if (name[1] == 'h' && name[2] == 'o' && name[3] == 'p') { /* chop */ 2248 return -KEY_chop; } 462 goto unknown; case 'd': 462 if (name[1] == 'u' && name[2] == 'm' && name[3] == 'p') { /* dump */ 13 return -KEY_dump; } 128105 goto unknown; case 'e': 128105 switch (name[1]) { case 'a': 2336 if (name[2] == 'c' && name[3] == 'h') { /* each */ 2336 return -KEY_each; } 97864 goto unknown; case 'l': 97864 if (name[2] == 's' && name[3] == 'e') { /* else */ 97852 return KEY_else; } 22830 goto unknown; case 'v': 22830 if (name[2] == 'a' && name[3] == 'l') { /* eval */ 22830 return KEY_eval; } 3886 goto unknown; case 'x': 3886 switch (name[2]) { case 'e': 386 if (name[3] == 'c') { /* exec */ 386 return -KEY_exec; } 3495 goto unknown; case 'i': 3495 if (name[3] == 't') { /* exit */ 3495 return -KEY_exit; } 1317 goto unknown; default: 1317 goto unknown; } default: 1317 goto unknown; } case 'f': 1317 if (name[1] == 'o' && name[2] == 'r' && name[3] == 'k') { /* fork */ 71 return -KEY_fork; } 51895 goto unknown; case 'g': 51895 switch (name[1]) { case 'e': 131 if (name[2] == 't' && name[3] == 'c') { /* getc */ 131 return -KEY_getc; } 499 goto unknown; case 'l': 499 if (name[2] == 'o' && name[3] == 'b') { /* glob */ 499 return KEY_glob; } 38168 goto unknown; case 'o': 38168 if (name[2] == 't' && name[3] == 'o') { /* goto */ 38126 return KEY_goto; } 13097 goto unknown; case 'r': 13097 if (name[2] == 'e' && name[3] == 'p') { /* grep */ 13097 return KEY_grep; } 23518 goto unknown; default: 23518 goto unknown; } case 'j': 23518 if (name[1] == 'o' && name[2] == 'i' && name[3] == 'n') { /* join */ 23517 return -KEY_join; } 22346 goto unknown; case 'k': 22346 switch (name[1]) { case 'e': 22185 if (name[2] == 'y' && name[3] == 's') { /* keys */ 22183 return -KEY_keys; } 161 goto unknown; case 'i': 161 if (name[2] == 'l' && name[3] == 'l') { /* kill */ 101 return -KEY_kill; } 25296 goto unknown; default: 25296 goto unknown; } case 'l': 25296 switch (name[1]) { case 'a': 23014 if (name[2] == 's' && name[3] == 't') { /* last */ 23013 return KEY_last; } 979 goto unknown; case 'i': 979 if (name[2] == 'n' && name[3] == 'k') { /* link */ 42 return -KEY_link; } 1284 goto unknown; case 'o': 1284 if (name[2] == 'c' && name[3] == 'k') { /* lock */ 1250 return -KEY_lock; } 32078 goto unknown; default: 32078 goto unknown; } case 'n': 32078 if (name[1] == 'e' && name[2] == 'x' && name[3] == 't') { /* next */ 29687 return KEY_next; } 10508 goto unknown; case 'o': 10508 if (name[1] == 'p' && name[2] == 'e' && name[3] == 'n') { /* open */ 10470 return -KEY_open; } 57556 goto unknown; case 'p': 57556 switch (name[1]) { case 'a': 2309 if (name[2] == 'c' && name[3] == 'k') { /* pack */ 2210 return -KEY_pack; } 107 goto unknown; case 'i': 107 if (name[2] == 'p' && name[3] == 'e') { /* pipe */ 71 return -KEY_pipe; } 53719 goto unknown; case 'u': 53719 if (name[2] == 's' && name[3] == 'h') { /* push */ 53719 return -KEY_push; } 7306 goto unknown; default: 7306 goto unknown; } case 'r': 7306 switch (name[1]) { case 'a': 176 if (name[2] == 'n' && name[3] == 'd') { /* rand */ 175 return -KEY_rand; } 7073 goto unknown; case 'e': 7073 switch (name[2]) { case 'a': 1866 if (name[3] == 'd') { /* read */ 1866 return -KEY_read; } 34 goto unknown; case 'c': 34 if (name[3] == 'v') { /* recv */ 34 return -KEY_recv; } 2979 goto unknown; case 'd': 2979 if (name[3] == 'o') { /* redo */ 2979 return KEY_redo; } 19351 goto unknown; default: 19351 goto unknown; } default: 19351 goto unknown; } case 's': 19351 switch (name[1]) { case 'e': 611 switch (name[2]) { case 'e': 518 if (name[3] == 'k') { /* seek */ 466 return -KEY_seek; } 60 goto unknown; case 'n': 60 if (name[3] == 'd') { /* send */ 60 return -KEY_send; } 8354 goto unknown; default: 8354 goto unknown; } case 'o': 8354 if (name[2] == 'r' && name[3] == 't') { /* sort */ 8353 return KEY_sort; } 307 goto unknown; case 'q': 307 if (name[2] == 'r' && name[3] == 't') { /* sqrt */ 307 return -KEY_sqrt; } 7084 goto unknown; case 't': 7084 if (name[2] == 'a' && name[3] == 't') { /* stat */ 7073 return -KEY_stat; } 7374 goto unknown; default: 7374 goto unknown; } case 't': 7374 switch (name[1]) { case 'e': 1574 if (name[2] == 'l' && name[3] == 'l') { /* tell */ 435 return -KEY_tell; } 2213 goto unknown; case 'i': 2213 switch (name[2]) { case 'e': 1564 if (name[3] == 'd') { /* tied */ 1533 return KEY_tied; } 646 goto unknown; case 'm': 646 if (name[3] == 'e') { /* time */ 646 return -KEY_time; } 21950 goto unknown; default: 21950 goto unknown; } default: 21950 goto unknown; } case 'w': 21950 if (name[1] == 'a') { 21789 switch (name[2]) { case 'i': 11 if (name[3] == 't') { /* wait */ 11 return -KEY_wait; } 21778 goto unknown; case 'r': 21778 if (name[3] == 'n') { /* warn */ 21778 return -KEY_warn; } 474743 goto unknown; default: 474743 goto unknown; } } 474743 goto unknown; default: 474743 goto unknown; } case 5: /* 36 tokens of length 5 */ 474743 switch (name[0]) { case 'B': 6114 if (name[1] == 'E' && name[2] == 'G' && name[3] == 'I' && name[4] == 'N') { /* BEGIN */ 5424 return KEY_BEGIN; } 278 goto unknown; case 'C': 278 if (name[1] == 'H' && name[2] == 'E' && name[3] == 'C' && name[4] == 'K') { /* CHECK */ 97 return KEY_CHECK; } 542 goto unknown; case 'a': 542 switch (name[1]) { case 'l': 125 if (name[2] == 'a' && name[3] == 'r' && name[4] == 'm') { /* alarm */ 41 return -KEY_alarm; } 201 goto unknown; case 't': 201 if (name[2] == 'a' && name[3] == 'n' && name[4] == '2') { /* atan2 */ 167 return -KEY_atan2; } 7435 goto unknown; default: 7435 goto unknown; } case 'b': 7435 if (name[1] == 'l' && name[2] == 'e' && name[3] == 's' && name[4] == 's') { /* bless */ 5927 return -KEY_bless; } 44974 goto unknown; case 'c': 44974 switch (name[1]) { case 'h': 14645 switch (name[2]) { case 'd': 4376 if (name[3] == 'i' && name[4] == 'r') { /* chdir */ 4376 return -KEY_chdir; } 4538 goto unknown; case 'm': 4538 if (name[3] == 'o' && name[4] == 'd') { /* chmod */ 4538 return -KEY_chmod; } 4592 goto unknown; case 'o': 4592 switch (name[3]) { case 'm': 4586 if (name[4] == 'p') { /* chomp */ 4586 return -KEY_chomp; } 6 goto unknown; case 'w': 6 if (name[4] == 'n') { /* chown */ 6 return -KEY_chown; } 12936 goto unknown; default: 12936 goto unknown; } default: 12936 goto unknown; } case 'l': 12936 if (name[2] == 'o' && name[3] == 's' && name[4] == 'e') { /* close */ 11039 return -KEY_close; } 17180 goto unknown; case 'r': 17180 if (name[2] == 'y' && name[3] == 'p' && name[4] == 't') { /* crypt */ 10 return -KEY_crypt; } 68221 goto unknown; default: 68221 goto unknown; } case 'e': 68221 if (name[1] == 'l' && name[2] == 's' && name[3] == 'i' && name[4] == 'f') { /* elsif */ 67709 return KEY_elsif; } 396 goto unknown; case 'f': 396 switch (name[1]) { case 'c': 120 if (name[2] == 'n' && name[3] == 't' && name[4] == 'l') { /* fcntl */ 120 return -KEY_fcntl; } 199 goto unknown; case 'l': 199 if (name[2] == 'o' && name[3] == 'c' && name[4] == 'k') { /* flock */ 69 return -KEY_flock; } 4763 goto unknown; default: 4763 goto unknown; } case 'i': 4763 switch (name[1]) { case 'n': 4653 if (name[2] == 'd' && name[3] == 'e' && name[4] == 'x') { /* index */ 4527 return -KEY_index; } 106 goto unknown; case 'o': 106 if (name[2] == 'c' && name[3] == 't' && name[4] == 'l') { /* ioctl */ 106 return -KEY_ioctl; } 53913 goto unknown; default: 53913 goto unknown; } case 'l': 53913 switch (name[1]) { case 'o': 51120 if (name[2] == 'c' && name[3] == 'a' && name[4] == 'l') { /* local */ 51080 return KEY_local; } 2651 goto unknown; case 's': 2651 if (name[2] == 't' && name[3] == 'a' && name[4] == 't') { /* lstat */ 2650 return -KEY_lstat; } 5129 goto unknown; default: 5129 goto unknown; } case 'm': 5129 if (name[1] == 'k' && name[2] == 'd' && name[3] == 'i' && name[4] == 'r') { /* mkdir */ 682 return -KEY_mkdir; } 61132 goto unknown; case 'p': 61132 if (name[1] == 'r' && name[2] == 'i' && name[3] == 'n' && name[4] == 't') { /* print */ 60992 return KEY_print; } 2377 goto unknown; case 'r': 2377 switch (name[1]) { case 'e': 1706 if (name[2] == 's' && name[3] == 'e' && name[4] == 't') { /* reset */ 14 return -KEY_reset; } 641 goto unknown; case 'm': 641 if (name[2] == 'd' && name[3] == 'i' && name[4] == 'r') { /* rmdir */ 639 return -KEY_rmdir; } 115757 goto unknown; default: 115757 goto unknown; } case 's': 115757 switch (name[1]) { case 'e': 4 if (name[2] == 'm' && name[3] == 'o' && name[4] == 'p') { /* semop */ 3 return -KEY_semop; } 96725 goto unknown; case 'h': 96725 if (name[2] == 'i' && name[3] == 'f' && name[4] == 't') { /* shift */ 96377 return -KEY_shift; } 134 goto unknown; case 'l': 134 if (name[2] == 'e' && name[3] == 'e' && name[4] == 'p') { /* sleep */ 118 return -KEY_sleep; } 12955 goto unknown; case 'p': 12955 if (name[2] == 'l' && name[3] == 'i' && name[4] == 't') { /* split */ 12955 return KEY_split; } 16 goto unknown; case 'r': 16 if (name[2] == 'a' && name[3] == 'n' && name[4] == 'd') { /* srand */ 16 return -KEY_srand; } 5845 goto unknown; case 't': 5845 if (name[2] == 'u' && name[3] == 'd' && name[4] == 'y') { /* study */ 4589 return KEY_study; } 2510 goto unknown; default: 2510 goto unknown; } case 't': 2510 if (name[1] == 'i' && name[2] == 'm' && name[3] == 'e' && name[4] == 's') { /* times */ 136 return -KEY_times; } 40381 goto unknown; case 'u': 40381 switch (name[1]) { case 'm': 89 if (name[2] == 'a' && name[3] == 's' && name[4] == 'k') { /* umask */ 89 return -KEY_umask; } 38665 goto unknown; case 'n': 38665 switch (name[2]) { case 'd': 37881 if (name[3] == 'e' && name[4] == 'f') { /* undef */ 37881 return KEY_undef; } 394 goto unknown; case 't': 394 if (name[3] == 'i') { 394 switch (name[4]) { case 'e': { /* untie */ 186 return KEY_untie; } case 'l': { /* until */ 208 return KEY_until; } default: 960 goto unknown; } } 960 goto unknown; default: 960 goto unknown; } case 't': 960 if (name[2] == 'i' && name[3] == 'm' && name[4] == 'e') { /* utime */ 960 return -KEY_utime; } 34075 goto unknown; default: 34075 goto unknown; } case 'w': 34075 switch (name[1]) { case 'h': 33632 if (name[2] == 'i' && name[3] == 'l' && name[4] == 'e') { /* while */ 33632 return KEY_while; } 355 goto unknown; case 'r': 355 if (name[2] == 'i' && name[3] == 't' && name[4] == 'e') { /* write */ 352 return -KEY_write; } 559052 goto unknown; default: 559052 goto unknown; } default: 559052 goto unknown; } case 6: /* 33 tokens of length 6 */ 559052 switch (name[0]) { case 'a': 641 if (name[1] == 'c' && name[2] == 'c' && name[3] == 'e' && name[4] == 'p' && name[5] == 't') { /* accept */ 17 return -KEY_accept; } 33808 goto unknown; case 'c': 33808 switch (name[1]) { case 'a': 32311 if (name[2] == 'l' && name[3] == 'l' && name[4] == 'e' && name[5] == 'r') { /* caller */ 32101 return -KEY_caller; } 13 goto unknown; case 'h': 13 if (name[2] == 'r' && name[3] == 'o' && name[4] == 'o' && name[5] == 't') { /* chroot */ 3 return -KEY_chroot; } 11653 goto unknown; default: 11653 goto unknown; } case 'd': 11653 if (name[1] == 'e' && name[2] == 'l' && name[3] == 'e' && name[4] == 't' && name[5] == 'e') { /* delete */ 10835 return KEY_delete; } 27559 goto unknown; case 'e': 27559 switch (name[1]) { case 'l': 2 if (name[2] == 's' && name[3] == 'e' && name[4] == 'i' && name[5] == 'f') { /* elseif */ 2 if(ckWARN_d(WARN_SYNTAX)) 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif"); } 1 goto unknown; case 'x': 27407 if (name[2] == 'i' && name[3] == 's' && name[4] == 't' && name[5] == 's') { /* exists */ 23189 return KEY_exists; } 1294 goto unknown; default: 1294 goto unknown; } case 'f': 1294 switch (name[1]) { case 'i': 856 if (name[2] == 'l' && name[3] == 'e' && name[4] == 'n' && name[5] == 'o') { /* fileno */ 856 return -KEY_fileno; } 125 goto unknown; case 'o': 125 if (name[2] == 'r' && name[3] == 'm' && name[4] == 'a' && name[5] == 't') { /* format */ 108 return KEY_format; } 4126 goto unknown; default: 4126 goto unknown; } case 'g': 4126 if (name[1] == 'm' && name[2] == 't' && name[3] == 'i' && name[4] == 'm' && name[5] == 'e') { /* gmtime */ 224 return -KEY_gmtime; } 24663 goto unknown; case 'l': 24663 switch (name[1]) { case 'e': 22604 if (name[2] == 'n' && name[3] == 'g' && name[4] == 't' && name[5] == 'h') { /* length */ 22586 return -KEY_length; } 1846 goto unknown; case 'i': 1846 if (name[2] == 's' && name[3] == 't' && name[4] == 'e' && name[5] == 'n') { /* listen */ 17 return -KEY_listen; } 5098 goto unknown; default: 5098 goto unknown; } case 'm': 5098 if (name[1] == 's' && name[2] == 'g') { 23 switch (name[3]) { case 'c': 8 if (name[4] == 't' && name[5] == 'l') { /* msgctl */ 8 return -KEY_msgctl; } 5 goto unknown; case 'g': 5 if (name[4] == 'e' && name[5] == 't') { /* msgget */ 5 return -KEY_msgget; } 5 goto unknown; case 'r': 5 if (name[4] == 'c' && name[5] == 'v') { /* msgrcv */ 5 return -KEY_msgrcv; } 5 goto unknown; case 's': 5 if (name[4] == 'n' && name[5] == 'd') { /* msgsnd */ 5 return -KEY_msgsnd; } 1627 goto unknown; default: 1627 goto unknown; } } 1627 goto unknown; case 'p': 1627 if (name[1] == 'r' && name[2] == 'i' && name[3] == 'n' && name[4] == 't' && name[5] == 'f') { /* printf */ 1060 return KEY_printf; } 197570 goto unknown; case 'r': 197570 switch (name[1]) { case 'e': 196050 switch (name[2]) { case 'n': 1212 if (name[3] == 'a' && name[4] == 'm' && name[5] == 'e') { /* rename */ 1203 return -KEY_rename; } 193589 goto unknown; case 't': 193589 if (name[3] == 'u' && name[4] == 'r' && name[5] == 'n') { /* return */ 193589 return KEY_return; } 390 goto unknown; default: 390 goto unknown; } case 'i': 390 if (name[2] == 'n' && name[3] == 'd' && name[4] == 'e' && name[5] == 'x') { /* rindex */ 390 return -KEY_rindex; } 30718 goto unknown; default: 30718 goto unknown; } case 's': 30718 switch (name[1]) { case 'c': 7729 if (name[2] == 'a' && name[3] == 'l' && name[4] == 'a' && name[5] == 'r') { /* scalar */ 7607 return KEY_scalar; } 2152 goto unknown; case 'e': 2152 switch (name[2]) { case 'l': 2125 if (name[3] == 'e' && name[4] == 'c' && name[5] == 't') { /* select */ 2125 return -KEY_select; } 22 goto unknown; case 'm': 22 switch (name[3]) { case 'c': 18 if (name[4] == 't' && name[5] == 'l') { /* semctl */ 18 return -KEY_semctl; } 4 goto unknown; case 'g': 4 if (name[4] == 'e' && name[5] == 't') { /* semget */ 4 return -KEY_semget; } 6 goto unknown; default: 6 goto unknown; } default: 6 goto unknown; } case 'h': 6 if (name[2] == 'm') { 6 switch (name[3]) { case 'c': 3 if (name[4] == 't' && name[5] == 'l') { /* shmctl */ 3 return -KEY_shmctl; } 3 goto unknown; case 'g': 3 if (name[4] == 'e' && name[5] == 't') { /* shmget */ 3 return -KEY_shmget; } 90 goto unknown; default: 90 goto unknown; } } 90 goto unknown; case 'o': 90 if (name[2] == 'c' && name[3] == 'k' && name[4] == 'e' && name[5] == 't') { /* socket */ 81 return -KEY_socket; } 3309 goto unknown; case 'p': 3309 if (name[2] == 'l' && name[3] == 'i' && name[4] == 'c' && name[5] == 'e') { /* splice */ 3309 return -KEY_splice; } 16332 goto unknown; case 'u': 16332 if (name[2] == 'b' && name[3] == 's' && name[4] == 't' && name[5] == 'r') { /* substr */ 16328 return -KEY_substr; } 904 goto unknown; case 'y': 904 if (name[2] == 's' && name[3] == 't' && name[4] == 'e' && name[5] == 'm') { /* system */ 866 return -KEY_system; } 182538 goto unknown; default: 182538 goto unknown; } case 'u': 182538 if (name[1] == 'n') { 182398 switch (name[2]) { case 'l': 179465 switch (name[3]) { case 'e': 174698 if (name[4] == 's' && name[5] == 's') { /* unless */ 174698 return KEY_unless; } 4767 goto unknown; case 'i': 4767 if (name[4] == 'n' && name[5] == 'k') { /* unlink */ 4729 return -KEY_unlink; } 1811 goto unknown; default: 1811 goto unknown; } case 'p': 1811 if (name[3] == 'a' && name[4] == 'c' && name[5] == 'k') { /* unpack */ 1811 return -KEY_unpack; } 1865 goto unknown; default: 1865 goto unknown; } } 1865 goto unknown; case 'v': 1865 if (name[1] == 'a' && name[2] == 'l' && name[3] == 'u' && name[4] == 'e' && name[5] == 's') { /* values */ 1374 return -KEY_values; } 411291 goto unknown; default: 411291 goto unknown; } case 7: /* 28 tokens of length 7 */ 411291 switch (name[0]) { case 'D': 124 if (name[1] == 'E' && name[2] == 'S' && name[3] == 'T' && name[4] == 'R' && name[5] == 'O' && name[6] == 'Y') { /* DESTROY */ 7 return KEY_DESTROY; } 20229 goto unknown; case '_': 20229 if (name[1] == '_' && name[2] == 'E' && name[3] == 'N' && name[4] == 'D' && name[5] == '_' && name[6] == '_') { /* __END__ */ 15387 return KEY___END__; } 2528 goto unknown; case 'b': 2528 if (name[1] == 'i' && name[2] == 'n' && name[3] == 'm' && name[4] == 'o' && name[5] == 'd' && name[6] == 'e') { /* binmode */ 2455 return -KEY_binmode; } 3125 goto unknown; case 'c': 3125 if (name[1] == 'o' && name[2] == 'n' && name[3] == 'n' && name[4] == 'e' && name[5] == 'c' && name[6] == 't') { /* connect */ 85 return -KEY_connect; } 123948 goto unknown; case 'd': 123948 switch (name[1]) { case 'b': 3 if (name[2] == 'm' && name[3] == 'o' && name[4] == 'p' && name[5] == 'e' && name[6] == 'n') { /* dbmopen */ 3 return -KEY_dbmopen; } 122787 goto unknown; case 'e': 122787 if (name[2] == 'f' && name[3] == 'i' && name[4] == 'n' && name[5] == 'e' && name[6] == 'd') { /* defined */ 122622 return KEY_defined; } 62384 goto unknown; default: 62384 goto unknown; } case 'f': 62384 if (name[1] == 'o' && name[2] == 'r' && name[3] == 'e' && name[4] == 'a' && name[5] == 'c' && name[6] == 'h') { /* foreach */ 59933 return KEY_foreach; } 134 goto unknown; case 'g': 134 if (name[1] == 'e' && name[2] == 't' && name[3] == 'p') { 15 switch (name[4]) { case 'g': 6 if (name[5] == 'r' && name[6] == 'p') { /* getpgrp */ 6 return -KEY_getpgrp; } 9 goto unknown; case 'p': 9 if (name[5] == 'i' && name[6] == 'd') { /* getppid */ 9 return -KEY_getppid; } 468 goto unknown; default: 468 goto unknown; } } 468 goto unknown; case 'l': 468 if (name[1] == 'c' && name[2] == 'f' && name[3] == 'i' && name[4] == 'r' && name[5] == 's' && name[6] == 't') { /* lcfirst */ 15 return -KEY_lcfirst; } 1983 goto unknown; case 'o': 1983 if (name[1] == 'p' && name[2] == 'e' && name[3] == 'n' && name[4] == 'd' && name[5] == 'i' && name[6] == 'r') { /* opendir */ 1940 return -KEY_opendir; } 39594 goto unknown; case 'p': 39594 if (name[1] == 'a' && name[2] == 'c' && name[3] == 'k' && name[4] == 'a' && name[5] == 'g' && name[6] == 'e') { /* package */ 39218 return KEY_package; } 89663 goto unknown; case 'r': 89663 if (name[1] == 'e') { 89252 switch (name[2]) { case 'a': 2596 if (name[3] == 'd' && name[4] == 'd' && name[5] == 'i' && name[6] == 'r') { /* readdir */ 2593 return -KEY_readdir; } 84669 goto unknown; case 'q': 84669 if (name[3] == 'u' && name[4] == 'i' && name[5] == 'r' && name[6] == 'e') { /* require */ 84669 return KEY_require; } 1589 goto unknown; case 'v': 1589 if (name[3] == 'e' && name[4] == 'r' && name[5] == 's' && name[6] == 'e') { /* reverse */ 1589 return -KEY_reverse; } 18744 goto unknown; default: 18744 goto unknown; } } 18744 goto unknown; case 's': 18744 switch (name[1]) { case 'e': 27 switch (name[2]) { case 'e': 4 if (name[3] == 'k' && name[4] == 'd' && name[5] == 'i' && name[6] == 'r') { /* seekdir */ 4 return -KEY_seekdir; } 23 goto unknown; case 't': 23 if (name[3] == 'p' && name[4] == 'g' && name[5] == 'r' && name[6] == 'p') { /* setpgrp */ 3 return -KEY_setpgrp; } 36 goto unknown; default: 36 goto unknown; } case 'h': 36 if (name[2] == 'm' && name[3] == 'r' && name[4] == 'e' && name[5] == 'a' && name[6] == 'd') { /* shmread */ 3 return -KEY_shmread; } 15711 goto unknown; case 'p': 15711 if (name[2] == 'r' && name[3] == 'i' && name[4] == 'n' && name[5] == 't' && name[6] == 'f') { /* sprintf */ 15331 return -KEY_sprintf; } 2318 goto unknown; case 'y': 2318 switch (name[2]) { case 'm': 863 if (name[3] == 'l' && name[4] == 'i' && name[5] == 'n' && name[6] == 'k') { /* symlink */ 26 return -KEY_symlink; } 1455 goto unknown; case 's': 1455 switch (name[3]) { case 'c': 513 if (name[4] == 'a' && name[5] == 'l' && name[6] == 'l') { /* syscall */ 19 return -KEY_syscall; } 134 goto unknown; case 'o': 134 if (name[4] == 'p' && name[5] == 'e' && name[6] == 'n') { /* sysopen */ 134 return -KEY_sysopen; } 722 goto unknown; case 'r': 722 if (name[4] == 'e' && name[5] == 'a' && name[6] == 'd') { /* sysread */ 722 return -KEY_sysread; } 80 goto unknown; case 's': 80 if (name[4] == 'e' && name[5] == 'e' && name[6] == 'k') { /* sysseek */ 80 return -KEY_sysseek; } 432 goto unknown; default: 432 goto unknown; } default: 432 goto unknown; } default: 432 goto unknown; } case 't': 432 if (name[1] == 'e' && name[2] == 'l' && name[3] == 'l' && name[4] == 'd' && name[5] == 'i' && name[6] == 'r') { /* telldir */ 6 return -KEY_telldir; } 7763 goto unknown; case 'u': 7763 switch (name[1]) { case 'c': 28 if (name[2] == 'f' && name[3] == 'i' && name[4] == 'r' && name[5] == 's' && name[6] == 't') { /* ucfirst */ 28 return -KEY_ucfirst; } 7647 goto unknown; case 'n': 7647 if (name[2] == 's' && name[3] == 'h' && name[4] == 'i' && name[5] == 'f' && name[6] == 't') { /* unshift */ 7594 return -KEY_unshift; } 405 goto unknown; default: 405 goto unknown; } case 'w': 405 if (name[1] == 'a' && name[2] == 'i' && name[3] == 't' && name[4] == 'p' && name[5] == 'i' && name[6] == 'd') { /* waitpid */ 86 return -KEY_waitpid; } 66538 goto unknown; default: 66538 goto unknown; } case 8: /* 26 tokens of length 8 */ 66538 switch (name[0]) { case 'A': 735 if (name[1] == 'U' && name[2] == 'T' && name[3] == 'O' && name[4] == 'L' && name[5] == 'O' && name[6] == 'A' && name[7] == 'D') { /* AUTOLOAD */ 665 return KEY_AUTOLOAD; } 7403 goto unknown; case '_': 7403 if (name[1] == '_') { 504 switch (name[2]) { case 'D': 128 if (name[3] == 'A' && name[4] == 'T' && name[5] == 'A' && name[6] == '_' && name[7] == '_') { /* __DATA__ */ 128 return KEY___DATA__; } 260 goto unknown; case 'F': 260 if (name[3] == 'I' && name[4] == 'L' && name[5] == 'E' && name[6] == '_' && name[7] == '_') { /* __FILE__ */ 260 return -KEY___FILE__; } 116 goto unknown; case 'L': 116 if (name[3] == 'I' && name[4] == 'N' && name[5] == 'E' && name[6] == '_' && name[7] == '_') { /* __LINE__ */ 116 return -KEY___LINE__; } 4511 goto unknown; default: 4511 goto unknown; } } 4511 goto unknown; case 'c': 4511 switch (name[1]) { case 'l': 2636 if (name[2] == 'o' && name[3] == 's' && name[4] == 'e' && name[5] == 'd' && name[6] == 'i' && name[7] == 'r') { /* closedir */ 2636 return -KEY_closedir; } 1529 goto unknown; case 'o': 1529 if (name[2] == 'n' && name[3] == 't' && name[4] == 'i' && name[5] == 'n' && name[6] == 'u' && name[7] == 'e') { /* continue */ 757 return -KEY_continue; } 1694 goto unknown; default: 1694 goto unknown; } case 'd': 1694 if (name[1] == 'b' && name[2] == 'm' && name[3] == 'c' && name[4] == 'l' && name[5] == 'o' && name[6] == 's' && name[7] == 'e') { /* dbmclose */ 3 return -KEY_dbmclose; } 511 goto unknown; case 'e': 511 if (name[1] == 'n' && name[2] == 'd') { 11 switch (name[3]) { case 'g': 5 if (name[4] == 'r' && name[5] == 'e' && name[6] == 'n' && name[7] == 't') { /* endgrent */ 5 return -KEY_endgrent; } 6 goto unknown; case 'p': 6 if (name[4] == 'w' && name[5] == 'e' && name[6] == 'n' && name[7] == 't') { /* endpwent */ 6 return -KEY_endpwent; } 429 goto unknown; default: 429 goto unknown; } } 429 goto unknown; case 'f': 429 if (name[1] == 'o' && name[2] == 'r' && name[3] == 'm' && name[4] == 'l' && name[5] == 'i' && name[6] == 'n' && name[7] == 'e') { /* formline */ 100 return -KEY_formline; } 660 goto unknown; case 'g': 660 if (name[1] == 'e' && name[2] == 't') { 568 switch (name[3]) { case 'g': 30 if (name[4] == 'r') { 30 switch (name[5]) { case 'e': 5 if (name[6] == 'n' && name[7] == 't') { /* getgrent */ 5 return -KEY_getgrent; } 19 goto unknown; case 'g': 19 if (name[6] == 'i' && name[7] == 'd') { /* getgrgid */ 19 return -KEY_getgrgid; } 6 goto unknown; case 'n': 6 if (name[6] == 'a' && name[7] == 'm') { /* getgrnam */ 6 return -KEY_getgrnam; } 6 goto unknown; default: 6 goto unknown; } } 6 goto unknown; case 'l': 6 if (name[4] == 'o' && name[5] == 'g' && name[6] == 'i' && name[7] == 'n') { /* getlogin */ 6 return -KEY_getlogin; } 244 goto unknown; case 'p': 244 if (name[4] == 'w') { 244 switch (name[5]) { case 'e': 7 if (name[6] == 'n' && name[7] == 't') { /* getpwent */ 7 return -KEY_getpwent; } 104 goto unknown; case 'n': 104 if (name[6] == 'a' && name[7] == 'm') { /* getpwnam */ 104 return -KEY_getpwnam; } 133 goto unknown; case 'u': 133 if (name[6] == 'i' && name[7] == 'd') { /* getpwuid */ 133 return -KEY_getpwuid; } 1686 goto unknown; default: 1686 goto unknown; } } 1686 goto unknown; default: 1686 goto unknown; } } 1686 goto unknown; case 'r': 1686 if (name[1] == 'e' && name[2] == 'a' && name[3] == 'd') { 937 switch (name[4]) { case 'l': 918 if (name[5] == 'i' && name[6] == 'n') { 918 switch (name[7]) { case 'e': { /* readline */ 30 return -KEY_readline; } case 'k': { /* readlink */ 888 return -KEY_readlink; } default: 1 goto unknown; } } 1 goto unknown; case 'p': 1 if (name[5] == 'i' && name[6] == 'p' && name[7] == 'e') { /* readpipe */ 1 return -KEY_readpipe; } 3644 goto unknown; default: 3644 goto unknown; } } 3644 goto unknown; case 's': 3644 switch (name[1]) { case 'e': 2033 if (name[2] == 't') { 1585 switch (name[3]) { case 'g': 5 if (name[4] == 'r' && name[5] == 'e' && name[6] == 'n' && name[7] == 't') { /* setgrent */ 5 return -KEY_setgrent; } 8 goto unknown; case 'p': 8 if (name[4] == 'w' && name[5] == 'e' && name[6] == 'n' && name[7] == 't') { /* setpwent */ 8 return -KEY_setpwent; } 22 goto unknown; default: 22 goto unknown; } } 22 goto unknown; case 'h': 22 switch (name[2]) { case 'm': 3 if (name[3] == 'w' && name[4] == 'r' && name[5] == 'i' && name[6] == 't' && name[7] == 'e') { /* shmwrite */ 3 return -KEY_shmwrite; } 19 goto unknown; case 'u': 19 if (name[3] == 't' && name[4] == 'd' && name[5] == 'o' && name[6] == 'w' && name[7] == 'n') { /* shutdown */ 19 return -KEY_shutdown; } 851 goto unknown; default: 851 goto unknown; } case 'y': 851 if (name[2] == 's' && name[3] == 'w' && name[4] == 'r' && name[5] == 'i' && name[6] == 't' && name[7] == 'e') { /* syswrite */ 844 return -KEY_syswrite; } 638 goto unknown; default: 638 goto unknown; } case 't': 638 if (name[1] == 'r' && name[2] == 'u' && name[3] == 'n' && name[4] == 'c' && name[5] == 'a' && name[6] == 't' && name[7] == 'e') { /* truncate */ 149 return -KEY_truncate; } 40140 goto unknown; default: 40140 goto unknown; } case 9: /* 8 tokens of length 9 */ 40140 switch (name[0]) { case 'e': 232 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 */ 2 return -KEY_endnetent; } 40 goto unknown; case 'g': 40 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 */ 4 return -KEY_getnetent; } 618 goto unknown; case 'l': 618 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 */ 575 return -KEY_localtime; } 471 goto unknown; case 'p': 471 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 */ 189 return KEY_prototype; } 526 goto unknown; case 'q': 526 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 */ 507 return -KEY_quotemeta; } 295 goto unknown; case 'r': 295 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 */ 101 return -KEY_rewinddir; } 4498 goto unknown; case 's': 4498 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 */ 2 return -KEY_setnetent; } 6092 goto unknown; case 'w': 6092 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 */ 5825 return -KEY_wantarray; } 38256 goto unknown; default: 38256 goto unknown; } case 10: /* 9 tokens of length 10 */ 38256 switch (name[0]) { case 'e': 140 if (name[1] == 'n' && name[2] == 'd') { 4 switch (name[3]) { case 'h': 2 if (name[4] == 'o' && name[5] == 's' && name[6] == 't' && name[7] == 'e' && name[8] == 'n' && name[9] == 't') { /* endhostent */ 2 return -KEY_endhostent; } 2 goto unknown; case 's': 2 if (name[4] == 'e' && name[5] == 'r' && name[6] == 'v' && name[7] == 'e' && name[8] == 'n' && name[9] == 't') { /* endservent */ 2 return -KEY_endservent; } 1002 goto unknown; default: 1002 goto unknown; } } 1002 goto unknown; case 'g': 1002 if (name[1] == 'e' && name[2] == 't') { 959 switch (name[3]) { case 'h': 4 if (name[4] == 'o' && name[5] == 's' && name[6] == 't' && name[7] == 'e' && name[8] == 'n' && name[9] == 't') { /* gethostent */ 4 return -KEY_gethostent; } 32 goto unknown; case 's': 32 switch (name[4]) { case 'e': 5 if (name[5] == 'r' && name[6] == 'v' && name[7] == 'e' && name[8] == 'n' && name[9] == 't') { /* getservent */ 5 return -KEY_getservent; } 27 goto unknown; case 'o': 27 if (name[5] == 'c' && name[6] == 'k' && name[7] == 'o' && name[8] == 'p' && name[9] == 't') { /* getsockopt */ 27 return -KEY_getsockopt; } 2182 goto unknown; default: 2182 goto unknown; } default: 2182 goto unknown; } } 2182 goto unknown; case 's': 2182 switch (name[1]) { case 'e': 126 if (name[2] == 't') { 126 switch (name[3]) { case 'h': 2 if (name[4] == 'o' && name[5] == 's' && name[6] == 't' && name[7] == 'e' && name[8] == 'n' && name[9] == 't') { /* sethostent */ 2 return -KEY_sethostent; } 121 goto unknown; case 's': 121 switch (name[4]) { case 'e': 2 if (name[5] == 'r' && name[6] == 'v' && name[7] == 'e' && name[8] == 'n' && name[9] == 't') { /* setservent */ 2 return -KEY_setservent; } 119 goto unknown; case 'o': 119 if (name[5] == 'c' && name[6] == 'k' && name[7] == 'o' && name[8] == 'p' && name[9] == 't') { /* setsockopt */ 119 return -KEY_setsockopt; } 50 goto unknown; default: 50 goto unknown; } default: 50 goto unknown; } } 50 goto unknown; case 'o': 50 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 */ 17 return -KEY_socketpair; } 29361 goto unknown; default: 29361 goto unknown; } default: 29361 goto unknown; } case 11: /* 8 tokens of length 11 */ 29361 switch (name[0]) { case '_': 7736 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__ */ 4984 return -KEY___PACKAGE__; } 55 goto unknown; case 'e': 55 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 */ 2 return -KEY_endprotoent; } 104 goto unknown; case 'g': 104 if (name[1] == 'e' && name[2] == 't') { 104 switch (name[3]) { case 'p': 74 switch (name[4]) { case 'e': 63 if (name[5] == 'e' && name[6] == 'r' && name[7] == 'n' && name[8] == 'a' && name[9] == 'm' && name[10] == 'e') { /* getpeername */ 63 return -KEY_getpeername; } 11 goto unknown; case 'r': 11 switch (name[5]) { case 'i': 6 if (name[6] == 'o' && name[7] == 'r' && name[8] == 'i' && name[9] == 't' && name[10] == 'y') { /* getpriority */ 6 return -KEY_getpriority; } 5 goto unknown; case 'o': 5 if (name[6] == 't' && name[7] == 'o' && name[8] == 'e' && name[9] == 'n' && name[10] == 't') { /* getprotoent */ 5 return -KEY_getprotoent; } 19 goto unknown; default: 19 goto unknown; } default: 19 goto unknown; } case 's': 19 if (name[4] == 'o' && name[5] == 'c' && name[6] == 'k' && name[7] == 'n' && name[8] == 'a' && name[9] == 'm' && name[10] == 'e') { /* getsockname */ 19 return -KEY_getsockname; } 2252 goto unknown; default: 2252 goto unknown; } } 2252 goto unknown; case 's': 2252 if (name[1] == 'e' && name[2] == 't' && name[3] == 'p' && name[4] == 'r') { 5 switch (name[5]) { case 'i': 3 if (name[6] == 'o' && name[7] == 'r' && name[8] == 'i' && name[9] == 't' && name[10] == 'y') { /* setpriority */ 3 return -KEY_setpriority; } 2 goto unknown; case 'o': 2 if (name[6] == 't' && name[7] == 'o' && name[8] == 'e' && name[9] == 'n' && name[10] == 't') { /* setprotoent */ 2 return -KEY_setprotoent; } 16297 goto unknown; default: 16297 goto unknown; } } 16297 goto unknown; default: 16297 goto unknown; } case 12: /* 2 tokens of length 12 */ 16297 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') { 10 switch (name[8]) { case 'a': 4 if (name[9] == 'd' && name[10] == 'd' && name[11] == 'r') { /* getnetbyaddr */ 4 return -KEY_getnetbyaddr; } 6 goto unknown; case 'n': 6 if (name[9] == 'a' && name[10] == 'm' && name[11] == 'e') { /* getnetbyname */ 6 return -KEY_getnetbyname; } 11118 goto unknown; default: 11118 goto unknown; } } 11118 goto unknown; case 13: /* 4 tokens of length 13 */ 11118 if (name[0] == 'g' && name[1] == 'e' && name[2] == 't') { 127 switch (name[3]) { case 'h': 49 if (name[4] == 'o' && name[5] == 's' && name[6] == 't' && name[7] == 'b' && name[8] == 'y') { 49 switch (name[9]) { case 'a': 11 if (name[10] == 'd' && name[11] == 'd' && name[12] == 'r') { /* gethostbyaddr */ 11 return -KEY_gethostbyaddr; } 38 goto unknown; case 'n': 38 if (name[10] == 'a' && name[11] == 'm' && name[12] == 'e') { /* gethostbyname */ 38 return -KEY_gethostbyname; } 76 goto unknown; default: 76 goto unknown; } } 76 goto unknown; case 's': 76 if (name[4] == 'e' && name[5] == 'r' && name[6] == 'v' && name[7] == 'b' && name[8] == 'y') { 76 switch (name[9]) { case 'n': 71 if (name[10] == 'a' && name[11] == 'm' && name[12] == 'e') { /* getservbyname */ 71 return -KEY_getservbyname; } 5 goto unknown; case 'p': 5 if (name[10] == 'o' && name[11] == 'r' && name[12] == 't') { /* getservbyport */ 5 return -KEY_getservbyport; } 16153 goto unknown; default: 16153 goto unknown; } } 16153 goto unknown; default: 16153 goto unknown; } } 16153 goto unknown; case 14: /* 1 tokens of length 14 */ 16153 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 */ 84 return -KEY_getprotobyname; } 8371 goto unknown; case 16: /* 1 tokens of length 16 */ 8371 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 */ 16 return -KEY_getprotobynumber; } 580012 goto unknown; default: 580012 goto unknown; } unknown: 580012 return 0; } STATIC void S_checkcomma(pTHX_ register char *s, const char *name, const char *what) 70400 { 70400 const char *w; 70400 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ 570 if (ckWARN(WARN_SYNTAX)) { 105 int level = 1; 4990 for (w = s+2; *w && level; w++) { 4885 if (*w == '(') 62 ++level; 4823 else if (*w == ')') 167 --level; } 105 if (*w) 108 for (; *w && isSPACE(*w); w++) ; 105 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */ 3 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (...) interpreted as function",name); } } 139884 while (s < PL_bufend && isSPACE(*s)) 69484 s++; 70400 if (*s == '(') 1529 s++; 70445 while (s < PL_bufend && isSPACE(*s)) 45 s++; 70400 if (isIDFIRST_lazy_if(s,UTF)) { 27217 w = s++; 128398 while (isALNUM_lazy_if(s,UTF)) 101181 s++; 51088 while (s < PL_bufend && isSPACE(*s)) 23871 s++; 27217 if (*s == ',') { ###### int kw; ###### *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */ ###### kw = keyword(w, s - w) || get_cv(w, FALSE) != 0; ###### *s = ','; ###### if (kw) ###### return; ###### Perl_croak(aTHX_ "No comma allowed after %s", what); } } } /* Either returns sv, or mortalizes sv and returns a new SV*. Best used as sv=new_constant(..., sv, ...). If s, pv are NULL, calls subroutine with one argument, and type is used with error messages only. */ STATIC SV * S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv, const char *type) 309 { 309 dVAR; dSP; 309 HV *table = GvHV(PL_hintgv); /* ^H */ 309 SV *res; 309 SV **cvp; 309 SV *cv, *typesv; 309 const char *why1 = "", *why2 = "", *why3 = ""; 309 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { ###### SV *msg; ###### why2 = strEQ(key,"charnames") ? "(possibly a missing \"use charnames ...\")" : ""; ###### msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s", (type ? type: "undef"), why2); /* This is convoluted and evil ("goto considered harmful") * but I do not understand the intricacies of all the different * failure modes of %^H in here. The goal here is to make * the most probable error message user-friendly. --jhi */ ###### goto msgdone; report: ###### msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s", (type ? type: "undef"), why1, why2, why3); msgdone: ###### yyerror(SvPVX_const(msg)); ###### SvREFCNT_dec(msg); ###### return sv; } 309 cvp = hv_fetch(table, key, strlen(key), FALSE); 309 if (!cvp || !SvOK(*cvp)) { ###### why1 = "$^H{"; ###### why2 = key; ###### why3 = "} is not defined"; ###### goto report; } 309 sv_2mortal(sv); /* Parent created it permanently */ 309 cv = *cvp; 309 if (!pv && s) 146 pv = sv_2mortal(newSVpvn(s, len)); 309 if (type && pv) 21 typesv = sv_2mortal(newSVpv(type, 0)); else 288 typesv = &PL_sv_undef; 309 PUSHSTACKi(PERLSI_OVERLOAD); 309 ENTER ; 309 SAVETMPS; 309 PUSHMARK(SP) ; 309 EXTEND(sp, 3); 309 if (pv) 154 PUSHs(pv); 309 PUSHs(sv); 309 if (pv) 154 PUSHs(typesv); 309 PUTBACK; 309 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL)); 307 SPAGAIN ; /* Check the eval first */ 307 if (!PL_in_eval && SvTRUE(ERRSV)) { ###### sv_catpv(ERRSV, "Propagated"); ###### yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */ ###### (void)POPs; ###### res = SvREFCNT_inc(sv); } else { 307 res = POPs; 307 (void)SvREFCNT_inc(res); } 307 PUTBACK ; 307 FREETMPS ; 307 LEAVE ; 307 POPSTACK; 307 if (!SvOK(res)) { ###### why1 = "Call to &{$^H{"; ###### why2 = key; ###### why3 = "}} did not return a defined value"; ###### sv = res; ###### goto report; } 307 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) 6211533 { 6211533 register char *d = dest; 6211533 register char *e = d + destlen - 3; /* two-character token, ending NUL */ 43221443 for (;;) { 37009910 if (d >= e) ###### Perl_croak(aTHX_ ident_too_long); 37009910 if (isALNUM(*s)) /* UTF handled below */ 30596301 *d++ = *s++; 6413609 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) { 101 *d++ = ':'; 101 *d++ = ':'; 101 s++; } 6413508 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') { 201935 *d++ = *s++; 201935 *d++ = *s++; } 6211573 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { 40 char *t = s + UTF8SKIP(s); 40 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t)) ###### t += UTF8SKIP(t); 40 if (d + (t - s) > e) ###### Perl_croak(aTHX_ ident_too_long); 40 Copy(s, d, t - s, char); 40 d += t - s; 40 s = t; } else { 6211533 *d = '\0'; 6211533 *slp = d - dest; 6211533 return s; } } } STATIC char * S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni) 5428205 { 5428205 register char *d; 5428205 register char *e; 5428205 char *bracket = 0; 5428205 char funny = *s++; 5428205 if (isSPACE(*s)) 2373 s = skipspace(s); 5428205 d = dest; 5428205 e = d + destlen - 3; /* two-character token, ending NUL */ 5428205 if (isDIGIT(*s)) { 110613 while (isDIGIT(*s)) { 55317 if (d >= e) ###### Perl_croak(aTHX_ ident_too_long); 55317 *d++ = *s++; } } else { 35074533 for (;;) { 29646328 if (d >= e) ###### Perl_croak(aTHX_ ident_too_long); 29646328 if (isALNUM(*s)) /* UTF handled below */ 24161709 *d++ = *s++; 5484619 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) { 365 *d++ = ':'; 365 *d++ = ':'; 365 s++; } 5484254 else if (*s == ':' && s[1] == ':') { 111327 *d++ = *s++; 111327 *d++ = *s++; } 5372927 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { 18 char *t = s + UTF8SKIP(s); 18 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t)) ###### t += UTF8SKIP(t); 18 if (d + (t - s) > e) ###### Perl_croak(aTHX_ ident_too_long); 18 Copy(s, d, t - s, char); 18 d += t - s; 18 s = t; } else 5428205 break; } } 5428205 *d = '\0'; 5428205 d = dest; 5428205 if (*d) { 5031092 if (PL_lex_state != LEX_NORMAL) 393134 PL_lex_state = LEX_INTERPENDMAYBE; 5031092 return s; } 397113 if (*s == '$' && s[1] && (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) ) { 111413 return s; } 285700 if (*s == '{') { 137765 bracket = s; 137765 s++; } 147935 else if (ck_uni) 86 check_uni(); 285700 if (s < send) 285699 *d = *s++; 285700 d[1] = '\0'; 285700 if (*d == '^' && *s && isCONTROLVAR(*s)) { 76621 *d = toCTRL(*s); 76621 s++; } 285700 if (bracket) { 137765 if (isSPACE(s[-1])) { 7113 while (s < send) { 7113 const char ch = *s++; 7113 if (!SPACE_OR_TAB(ch)) { 7106 *d = ch; break; } } } 137765 if (isIDFIRST_lazy_if(d,UTF)) { 39294 d++; 39294 if (UTF) { 3 e = s; 30 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') { 27 e += UTF8SKIP(e); 27 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e)) ###### e += UTF8SKIP(e); } 3 Copy(s, d, e - s, char); 3 d += e - s; 3 s = e; } else { 202077 while ((isALNUM(*s) || *s == ':') && d < e) 162786 *d++ = *s++; 39291 if (d >= e) ###### Perl_croak(aTHX_ ident_too_long); } 39294 *d = '\0'; 39878 while (s < send && SPACE_OR_TAB(*s)) s++; 39294 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { 5 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) { 2 const char *brack = *s == '[' ? "[...]" : "{...}"; 2 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of %c{%s%s} resolved to %c%s%s", funny, dest, brack, funny, dest, brack); } 5 bracket++; 5 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK); 5 return s; } } /* Handle extended ${^Foo} variables * 1999-02-27 mjd-perl-patch@plover.com */ 98471 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */ && isALNUM(*s)) { 13030 d++; 163293 while (isALNUM(*s) && d < e) { 150263 *d++ = *s++; } 13030 if (d >= e) ###### Perl_croak(aTHX_ ident_too_long); 13030 *d = '\0'; } 137760 if (*s == '}') { 43112 s++; 43112 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) { 28519 PL_lex_state = LEX_INTERPEND; 28519 PL_expect = XREF; } 43112 if (funny == '#') ###### funny = '@'; 43112 if (PL_lex_state == LEX_NORMAL) { 14593 if (ckWARN(WARN_AMBIGUOUS) && (keyword(dest, d - dest) || get_cv(dest, FALSE))) { 2 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of %c{%s} resolved to %c%s", funny, dest, funny, dest); } } } else { 94648 s = bracket; /* let the parser handle it */ 94648 *dest = '\0'; } } 147935 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s)) 29385 PL_lex_state = LEX_INTERPEND; 285695 return s; } void Perl_pmflag(pTHX_ U32* pmfl, int ch) 146185 { 146185 if (ch == 'i') 34767 *pmfl |= PMf_FOLD; 111418 else if (ch == 'g') 29143 *pmfl |= PMf_GLOBAL; 82275 else if (ch == 'c') 1031 *pmfl |= PMf_CONTINUE; 81244 else if (ch == 'o') 1894 *pmfl |= PMf_KEEP; 79350 else if (ch == 'm') 18572 *pmfl |= PMf_MULTILINE; 60778 else if (ch == 's') 42685 *pmfl |= PMf_SINGLELINE; 18093 else if (ch == 'x') 18093 *pmfl |= PMf_EXTENDED; } STATIC char * S_scan_pat(pTHX_ char *start, I32 type) 143463 { 143463 PMOP *pm; 143463 char *s = scan_str(start,FALSE,FALSE); 143463 if (!s) { 15 char *delimiter = skipspace(start); 15 Perl_croak(aTHX_ *delimiter == '?' ? "Search pattern not terminated or ternary operator parsed as search pattern" : "Search pattern not terminated" ); } 143448 pm = (PMOP*)newPMOP(type, 0); 143446 if (PL_multi_open == '?') 4 pm->op_pmflags |= PMf_ONCE; 143446 if(type == OP_QR) { 13640 while (*s && strchr("iomsx", *s)) 3988 pmflag(&pm->op_pmflags,*s++); } else { 174781 while (*s && strchr("iogcmsx", *s)) 40987 pmflag(&pm->op_pmflags,*s++); } /* issue a warning if /c is specified,but /g is not */ 143446 if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)) { 1 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g); } 143446 pm->op_pmpermflags = pm->op_pmflags; 143446 PL_lex_op = (OP*)pm; 143446 yylval.ival = OP_MATCH; 143446 return s; } STATIC char * S_scan_subst(pTHX_ char *start) 77195 { dVAR; 77195 register char *s; 77195 register PMOP *pm; 77195 I32 first_start; 77195 I32 es = 0; 77195 yylval.ival = OP_NULL; 77195 s = scan_str(start,FALSE,FALSE); 77195 if (!s) 1 Perl_croak(aTHX_ "Substitution pattern not terminated"); 77194 if (s[-1] == PL_multi_open) 73432 s--; 77194 first_start = PL_multi_start; 77194 s = scan_str(s,FALSE,FALSE); 77194 if (!s) { 4 if (PL_lex_stuff) { 4 SvREFCNT_dec(PL_lex_stuff); 4 PL_lex_stuff = Nullsv; } 4 Perl_croak(aTHX_ "Substitution replacement not terminated"); } 77190 PL_multi_start = first_start; /* so whole substitution is taken together */ 77190 pm = (PMOP*)newPMOP(OP_SUBST, 0); 125103 while (*s) { 125103 if (*s == 'e') { 4836 s++; 4836 es++; } 120267 else if (strchr("iogcmsx", *s)) 43078 pmflag(&pm->op_pmflags,*s++); else 77189 break; } /* /c is not meaningful with s/// */ 77189 if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE)) { 2 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst); } 77189 if (es) { 4461 SV *repl; 4461 PL_sublex_info.super_bufptr = s; 4461 PL_sublex_info.super_bufend = PL_bufend; 4461 PL_multi_end = 0; 4461 pm->op_pmflags |= PMf_EVAL; 4461 repl = newSVpvn("",0); 9297 while (es-- > 0) 4836 sv_catpv(repl, es ? "eval " : "do "); 4461 sv_catpvn(repl, "{ ", 2); 4461 sv_catsv(repl, PL_lex_repl); 4461 sv_catpvn(repl, " };", 2); 4461 SvEVALED_on(repl); 4461 SvREFCNT_dec(PL_lex_repl); 4461 PL_lex_repl = repl; } 77189 pm->op_pmpermflags = pm->op_pmflags; 77189 PL_lex_op = (OP*)pm; 77189 yylval.ival = OP_SUBST; 77189 return s; } STATIC char * S_scan_trans(pTHX_ char *start) 6453 { 6453 register char* s; 6453 OP *o; 6453 short *tbl; 6453 I32 squash; 6453 I32 del; 6453 I32 complement; 6453 yylval.ival = OP_NULL; 6453 s = scan_str(start,FALSE,FALSE); 6453 if (!s) 2 Perl_croak(aTHX_ "Transliteration pattern not terminated"); 6451 if (s[-1] == PL_multi_open) 6393 s--; 6451 s = scan_str(s,FALSE,FALSE); 6451 if (!s) { 8 if (PL_lex_stuff) { 8 SvREFCNT_dec(PL_lex_stuff); 8 PL_lex_stuff = Nullsv; } 8 Perl_croak(aTHX_ "Transliteration replacement not terminated"); } 6443 complement = del = squash = 0; 7813 while (1) { 7813 switch (*s) { case 'c': 192 complement = OPpTRANS_COMPLEMENT; 192 break; case 'd': 642 del = OPpTRANS_DELETE; 642 break; case 's': 536 squash = OPpTRANS_SQUASH; break; default: 1370 goto no_more; } 1370 s++; } no_more: 6443 New(803, tbl, complement&&!del?258:256, short); 6443 o = newPVOP(OP_TRANS, 0, (char*)tbl); 6442 o->op_private &= ~OPpTRANS_ALL; 6442 o->op_private |= del|squash|complement| (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)| (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0); 6442 PL_lex_op = o; 6442 yylval.ival = OP_TRANS; 6442 return s; } STATIC char * S_scan_heredoc(pTHX_ register char *s) 26511 { 26511 SV *herewas; 26511 I32 op_type = OP_SCALAR; 26511 I32 len; 26511 SV *tmpstr; 26511 char term; 26511 const char newline[] = "\n"; 26511 const char *found_newline; 26511 register char *d; 26511 register char *e; 26511 char *peek; 26511 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR)); 26511 s += 2; 26511 d = PL_tokenbuf; 26511 e = PL_tokenbuf + sizeof PL_tokenbuf - 1; 26511 if (!outer) 911 *d++ = '\n'; 26511 for (peek = s; SPACE_OR_TAB(*peek); peek++) ; 26511 if (*peek == '`' || *peek == '\'' || *peek =='"') { 19611 s = peek; 19611 term = *s++; 19611 s = delimcpy(d, e, s, PL_bufend, term, &len); 19611 d += len; 19611 if (s < PL_bufend) 19611 s++; } else { 6900 if (*s == '\\') 2 s++, term = '\''; else 6898 term = '"'; 6900 if (!isALNUM_lazy_if(s,UTF)) 3 deprecate_old("bare << to mean <<\"\""); 86392 for (; isALNUM_lazy_if(s,UTF); s++) { 39746 if (d < e) 39746 *d++ = *s; } } 26511 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1) ###### Perl_croak(aTHX_ "Delimiter for here document is too long"); 26511 *d++ = '\n'; 26511 *d = '\0'; 26511 len = d - PL_tokenbuf; #ifndef PERL_STRICT_CR 26511 d = strchr(s, '\r'); 26511 if (d) { ###### char * const olds = s; ###### s = d; ###### while (s < PL_bufend) { ###### if (*s == '\r') { ###### *d++ = '\n'; ###### if (*++s == '\n') ###### s++; } ###### else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */ ###### *d++ = *s++; ###### s++; } else ###### *d++ = *s++; } ###### *d = '\0'; ###### PL_bufend = d; ###### SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr)); ###### s = olds; } #endif 26511 if ( outer || !(found_newline = ninstr(s,PL_bufend,newline,newline+1)) ) { 25601 herewas = newSVpvn(s,PL_bufend-s); } else { 910 s--; 910 herewas = newSVpvn(s,found_newline-s); } 26511 s += SvCUR(herewas); 26511 tmpstr = NEWSV(87,79); 26511 sv_upgrade(tmpstr, SVt_PVIV); 26511 if (term == '\'') { 15481 op_type = OP_CONST; 15481 SvIV_set(tmpstr, -1); } 11030 else if (term == '`') { 1 op_type = OP_BACKTICK; 1 SvIV_set(tmpstr, '\\'); } 26511 CLINE; 26511 PL_multi_start = CopLINE(PL_curcop); 26511 PL_multi_open = PL_multi_close = '<'; 26511 term = *PL_tokenbuf; 26511 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) { 1 char *bufptr = PL_sublex_info.super_bufptr; 1 char *bufend = PL_sublex_info.super_bufend; 1 char * const olds = s - SvCUR(herewas); 1 s = strchr(bufptr, '\n'); 1 if (!s) ###### s = bufend; 1 d = s; 17 while (s < bufend && (*s != term || memNE(s,PL_tokenbuf,len)) ) { 16 if (*s++ == '\n') 1 CopLINE_inc(PL_curcop); } 1 if (s >= bufend) { ###### CopLINE_set(PL_curcop, (line_t)PL_multi_start); ###### missingterm(PL_tokenbuf); } 1 sv_setpvn(herewas,bufptr,d-bufptr+1); 1 sv_setpvn(tmpstr,d+1,s-d); 1 s += len - 1; 1 sv_catpvn(herewas,s,bufend-s); 1 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char); 1 s = olds; 1 goto retval; } 26510 else if (!outer) { 910 d = s; 370509 while (s < PL_bufend && (*s != term || memNE(s,PL_tokenbuf,len)) ) { 369599 if (*s++ == '\n') 11261 CopLINE_inc(PL_curcop); } 910 if (s >= PL_bufend) { ###### CopLINE_set(PL_curcop, (line_t)PL_multi_start); ###### missingterm(PL_tokenbuf); } 910 sv_setpvn(tmpstr,d+1,s-d); 910 s += len - 1; 910 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */ 910 sv_catpvn(herewas,s,PL_bufend-s); 910 sv_setsv(PL_linestr,herewas); 910 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr); 910 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 910 PL_last_lop = PL_last_uni = Nullch; } else 25600 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */ 1461602 while (s >= PL_bufend) { /* multiple line string? */ 1435092 if (!outer || !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) { ###### CopLINE_set(PL_curcop, (line_t)PL_multi_start); ###### missingterm(PL_tokenbuf); } 1435092 CopLINE_inc(PL_curcop); 1435092 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 1435092 PL_last_lop = PL_last_uni = Nullch; #ifndef PERL_STRICT_CR 1435092 if (PL_bufend - PL_linestart >= 2) { 1416891 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') || (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r')) { ###### PL_bufend[-2] = '\n'; ###### PL_bufend--; ###### SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr)); } 1416891 else if (PL_bufend[-1] == '\r') ###### PL_bufend[-1] = '\n'; } 18201 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r') ###### PL_bufend[-1] = '\n'; #endif 1435092 if (PERLDB_LINE && PL_curstash != PL_debstash) { ###### SV *sv = NEWSV(88,0); ###### sv_upgrade(sv, SVt_PVMG); ###### sv_setsv(sv,PL_linestr); ###### (void)SvIOK_on(sv); ###### SvIV_set(sv, 0); ###### av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv); } 1435092 if (*s == term && memEQ(s,PL_tokenbuf,len)) { 25600 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr); 25600 *(SvPVX(PL_linestr) + off ) = ' '; 25600 sv_catsv(PL_linestr,herewas); 25600 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 25600 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */ } else { 1409492 s = PL_bufend; 1409492 sv_catsv(tmpstr,PL_linestr); } } 26510 s++; retval: 26511 PL_multi_end = CopLINE(PL_curcop); 26511 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) { 12526 SvPV_shrink_to_cur(tmpstr); } 26511 SvREFCNT_dec(herewas); 26511 if (!IN_BYTES) { 26509 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr))) 5 SvUTF8_on(tmpstr); 26504 else if (PL_encoding) ###### sv_recode_to_utf8(tmpstr, PL_encoding); } 26511 PL_lex_stuff = tmpstr; 26511 yylval.ival = op_type; 26511 return s; } /* scan_inputsymbol takes: current position in input buffer returns: new position in input buffer side-effects: yylval and lex_op are set. This code handles: <> read from ARGV read from filehandle read from package qualified filehandle read from package qualified filehandle <$fh> read from filehandle in $fh <*.h> filename glob */ STATIC char * S_scan_inputsymbol(pTHX_ char *start) 6800 { 6800 register char *s = start; /* current position in buffer */ 6800 register char *d; 6800 const char *e; 6800 char *end; 6800 I32 len; 6800 d = PL_tokenbuf; /* start of temp holding space */ 6800 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */ 6800 end = strchr(s, '\n'); 6800 if (!end) 2 end = PL_bufend; 6800 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */ /* die if we didn't have space for the contents of the <>, or if it didn't end, or if we see a newline */ 6800 if (len >= sizeof PL_tokenbuf) ###### Perl_croak(aTHX_ "Excessively long <> operator"); 6800 if (s >= end) 2 Perl_croak(aTHX_ "Unterminated <> operator"); 6798 s++; /* check for <$fh> Remember, only scalar variables are interpreted as filehandles by this code. Anything more complex (e.g., <$fh{$num}>) will be treated as a glob() call. This code makes use of the fact that except for the $ at the front, a scalar variable and a filehandle look the same. */ 6798 if (*d == '$' && d[1]) d++; /* allow or */ 29737 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':')) 22939 d++; /* If we've tried to read what we allow filehandles to look like, and there's still text left, then it must be a glob() and not a getline. Use scan_str to pull out the stuff between the <> and treat it as nothing more than a string. */ 6798 if (d - PL_tokenbuf != len) { 129 yylval.ival = OP_GLOB; 129 set_csh(); 129 s = scan_str(start,FALSE,FALSE); 129 if (!s) ###### Perl_croak(aTHX_ "Glob not terminated"); 129 return s; } else { 6669 bool readline_overriden = FALSE; 6669 GV *gv_readline = Nullgv; 6669 GV **gvp; /* we're in a filehandle read situation */ 6669 d = PL_tokenbuf; /* turn <> into */ 6669 if (!len) 469 Copy("ARGV",d,5,char); /* Check whether readline() is overriden */ 6669 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV)) && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)) || ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE)) && (gv_readline = *gvp) != (GV*)&PL_sv_undef && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))) 6 readline_overriden = TRUE; /* if <$fh>, create the ops to turn the variable into a filehandle */ 6669 if (*d == '$') { 1693 I32 tmp; /* try to find it in the pad for this block, otherwise find add symbol table ops */ 1693 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) { 1272 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) { 2 HV *stash = PAD_COMPNAME_OURSTASH(tmp); 2 HEK *stashname = HvNAME_HEK(stash); 2 SV *sym = sv_2mortal(newSVhek(stashname)); 2 sv_catpvn(sym, "::", 2); 2 sv_catpv(sym, d+1); 2 d = SvPVX(sym); 2 goto intro_sym; } else { 1270 OP *o = newOP(OP_PADSV, 0); 1270 o->op_targ = tmp; 1270 PL_lex_op = readline_overriden ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, o, newCVREF(0, newGVOP(OP_GV,0,gv_readline)))) : (OP*)newUNOP(OP_READLINE, 0, o); } } else { 421 GV *gv; 421 ++d; intro_sym: 423 gv = gv_fetchpv(d, (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADDMULTI), SVt_PV); 423 PL_lex_op = readline_overriden ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)), newCVREF(0, newGVOP(OP_GV, 0, gv_readline)))) : (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv))); } 1693 if (!readline_overriden) 1689 PL_lex_op->op_flags |= OPf_SPECIAL; /* we created the ops in PL_lex_op, so make yylval.ival a null op */ 1693 yylval.ival = OP_NULL; } /* If it's none of the above, it must be a literal filehandle ( or ) so build a simple readline OP */ else { 4976 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO); 4976 PL_lex_op = readline_overriden ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, newGVOP(OP_GV, 0, gv), newCVREF(0, newGVOP(OP_GV, 0, gv_readline)))) : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv)); 4975 yylval.ival = OP_NULL; } } 6668 return s; } /* scan_str takes: start position in buffer keep_quoted preserve \ on the embedded delimiter(s) keep_delims preserve the delimiters around the string returns: position to continue reading from buffer side-effects: multi_start, multi_close, lex_repl or lex_stuff, and updates the read buffer. This subroutine pulls a string out of the input. It is called for: q single quotes q(literal text) ' single quotes 'literal text' qq double quotes qq(interpolate $here please) " double quotes "interpolate $here please" qx backticks qx(/bin/ls -l) ` backticks `/bin/ls -l` qw quote words @EXPORT_OK = qw( func() $spam ) m// regexp match m/this/ s/// regexp substitute s/this/that/ tr/// string transliterate tr/this/that/ y/// string transliterate y/this/that/ ($*@) sub prototypes sub foo ($) (stuff) sub attr parameters sub foo : attr(stuff) <> readline or globs , <>, <$fh>, or <*.c> In most of these cases (all but <>, patterns and transliterate) yylex() calls scan_str(). m// makes yylex() call scan_pat() which calls scan_str(). s/// makes yylex() call scan_subst() which calls scan_str(). tr/// and y/// make yylex() call scan_trans() which calls scan_str(). It skips whitespace before the string starts, and treats the first character as the delimiter. If the delimiter is one of ([{< then the corresponding "close" character )]}> is used as the closing delimiter. It allows quoting of delimiters, and if the string has balanced delimiters ([{<>}]) it allows nesting. On success, the SV with the resulting string is put into lex_stuff or, if that is already non-NULL, into lex_repl. The second case occurs only when parsing the RHS of the special constructs s/// and tr/// (y///). For convenience, the terminating delimiter character is stuffed into SvIVX of the SV. */ STATIC char * S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) 2167113 { 2167113 SV *sv; /* scalar value: string */ 2167113 char *tmps; /* temp string, used for delimiter matching */ 2167113 register char *s = start; /* current position in the buffer */ 2167113 register char term; /* terminating character */ 2167113 register char *to; /* current position in the sv's data */ 2167113 I32 brackets = 1; /* bracket nesting level */ 2167113 bool has_utf8 = FALSE; /* is there any utf8 content? */ 2167113 I32 termcode; /* terminating char. code */ 2167113 U8 termstr[UTF8_MAXBYTES]; /* terminating string */ 2167113 STRLEN termlen; /* length of terminating string */ 2167113 char *last = NULL; /* last position for nesting bracket */ /* skip space before the delimiter */ 2167113 if (isSPACE(*s)) 2860 s = skipspace(s); /* mark where we are, in case we need to report errors */ 2167113 CLINE; /* after skipping whitespace, the next character is the terminator */ 2167113 term = *s; 2167113 if (!UTF) { 2166010 termcode = termstr[0] = term; 2166010 termlen = 1; } else { 1103 termcode = utf8_to_uvchr((U8*)s, &termlen); 1103 Copy(s, termstr, termlen, U8); 1103 if (!UTF8_IS_INVARIANT(term)) 2 has_utf8 = TRUE; } /* mark where we are */ 2167113 PL_multi_start = CopLINE(PL_curcop); 2167113 PL_multi_open = term; /* find corresponding closing delimiter */ 2167113 if (term && (tmps = strchr("([{< )]}> )]}>",term))) 112496 termcode = termstr[0] = term = tmps[5]; 2167113 PL_multi_close = term; /* create a new SV to hold the contents. 87 is leak category, I'm assuming. 79 is the SV's initial length. What a random number. */ 2167113 sv = NEWSV(87,79); 2167113 sv_upgrade(sv, SVt_PVIV); 2167113 SvIV_set(sv, termcode); 2167113 (void)SvPOK_only(sv); /* validate pointer */ /* move past delimiter and try to read a complete string */ 2167113 if (keep_delims) 60 sv_catpvn(sv, s, termlen); 2167113 s += termlen; 2501763 for (;;) { 2334438 if (PL_encoding && !UTF) { 298 bool cont = TRUE; 596 while (cont) { 298 int offset = s - SvPVX_const(PL_linestr); 298 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr, 298 &offset, (char*)termstr, termlen); 298 const char *ns = SvPVX_const(PL_linestr) + offset; 298 char *svlast = SvEND(sv) - 1; 7686 for (; s < ns; s++) { 3694 if (*s == '\n' && !PL_rsfp) ###### CopLINE_inc(PL_curcop); } 298 if (!found) ###### goto read_more_line; else { /* handle quoted delimiters */ 298 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') { ###### const char *t; ###### for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';) ###### t--; ###### if ((svlast-1 - t) % 2) { ###### if (!keep_quoted) { ###### *(svlast-1) = term; ###### *svlast = '\0'; ###### SvCUR_set(sv, SvCUR(sv) - 1); } ###### continue; } } 298 if (PL_multi_open == PL_multi_close) { 276 cont = FALSE; } else { 22 const char *t; 22 char *w; 22 if (!last) 22 last = SvPVX(sv); 433 for (t = w = last; t < svlast; w++, t++) { /* At here, all closes are "was quoted" one, so we don't check PL_multi_close. */ 411 if (*t == '\\') { 10 if (!keep_quoted && *(t+1) == PL_multi_open) ###### t++; else 10 *w++ = *t++; } 401 else if (*t == PL_multi_open) ###### brackets++; 411 *w = *t; } 22 if (w < t) { ###### *w++ = term; ###### *w = '\0'; ###### SvCUR_set(sv, w - SvPVX_const(sv)); } 22 last = w; 22 if (--brackets <= 0) 22 cont = FALSE; } } } 298 if (!keep_delims) { 298 SvCUR_set(sv, SvCUR(sv) - 1); 298 *SvEND(sv) = '\0'; } 298 break; } /* extend sv if need be */ 2334140 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1); /* set 'to' to the next character in the sv's string */ 2334140 to = SvPVX(sv)+SvCUR(sv); /* if open delimiter is the close delimiter read unbridle */ 2334140 if (PL_multi_open == PL_multi_close) { 53664990 for (; s < PL_bufend; s++,to++) { /* embedded newlines increment the current line number */ 27846375 if (*s == '\n' && !PL_rsfp) 1862 CopLINE_inc(PL_curcop); /* handle quoted delimiters */ 27846375 if (*s == '\\' && s+1 < PL_bufend && term != '\\') { 3020524 if (!keep_quoted && s[1] == term) 25557 s++; /* any other quotes are simply copied straight through */ else 2994967 *to++ = *s++; } /* terminate when run out of buffer (the for() condition), or have found the terminator */ 24825851 else if (*s == term) { 2054307 if (termlen == 1) 2054305 break; 2 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen)) 2 break; } 22771544 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) 70 has_utf8 = TRUE; 25792068 *to = *s; } } /* if the terminator isn't the same as the start character (e.g., matched brackets), we have to allow more in the quoting, and be prepared for nested brackets. */ else { /* read until we run out of string, or we find the terminator */ 10119518 for (; s < PL_bufend; s++,to++) { /* embedded newlines increment the line count */ 5045586 if (*s == '\n' && !PL_rsfp) 23 CopLINE_inc(PL_curcop); /* backslashes can escape the open or closing characters */ 5045586 if (*s == '\\' && s+1 < PL_bufend) { 42892 if (!keep_quoted && ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))) 74 s++; else 42818 *to++ = *s++; } /* allow nested opens and closes */ 5002694 else if (*s == PL_multi_close && --brackets <= 0) 112470 break; 4890224 else if (*s == PL_multi_open) 5742 brackets++; 4884482 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) 1 has_utf8 = TRUE; 4933116 *to = *s; } } /* terminate the copied string and update the sv's end-of-string */ 2334140 *to = '\0'; 2334140 SvCUR_set(sv, to - SvPVX_const(sv)); /* * this next chunk reads more into the buffer if we're not done yet */ 2334140 if (s < PL_bufend) 2166777 break; /* handle case where we are done yet :-) */ #ifndef PERL_STRICT_CR 167363 if (to - SvPVX_const(sv) >= 2) { 156200 if ((to[-2] == '\r' && to[-1] == '\n') || (to[-2] == '\n' && to[-1] == '\r')) { ###### to[-2] = '\n'; ###### to--; ###### SvCUR_set(sv, to - SvPVX_const(sv)); } 156200 else if (to[-1] == '\r') ###### to[-1] = '\n'; } 11163 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r') ###### to[-1] = '\n'; #endif read_more_line: /* if we're out of file, or a read fails, bail and reset the current line marker so we can report where the unterminated string began */ 167363 if (!PL_rsfp || !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) { 38 sv_free(sv); 38 CopLINE_set(PL_curcop, (line_t)PL_multi_start); 38 return Nullch; } /* we read a line, so increment our line counter */ 167325 CopLINE_inc(PL_curcop); /* update debugger info */ 167325 if (PERLDB_LINE && PL_curstash != PL_debstash) { ###### SV *sv = NEWSV(88,0); ###### sv_upgrade(sv, SVt_PVMG); ###### sv_setsv(sv,PL_linestr); ###### (void)SvIOK_on(sv); ###### SvIV_set(sv, 0); ###### av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv); } /* having changed the buffer, we must update PL_bufend */ 167325 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 167325 PL_last_lop = PL_last_uni = Nullch; } /* at this point, we have successfully read the delimited string */ 2167075 if (!PL_encoding || UTF) { 2166777 if (keep_delims) 56 sv_catpvn(sv, s, termlen); 2166777 s += termlen; } 2167075 if (has_utf8 || PL_encoding) 371 SvUTF8_on(sv); 2167075 PL_multi_end = CopLINE(PL_curcop); /* if we allocated too much space, give some back */ 2167075 if (SvCUR(sv) + 5 < SvLEN(sv)) { 2160721 SvLEN_set(sv, SvCUR(sv) + 1); 2160721 SvPV_renew(sv, SvLEN(sv)); } /* decide whether this is the first or second quoted string we've read for this op */ 2167075 if (PL_lex_stuff) 83637 PL_lex_repl = sv; else 2083438 PL_lex_stuff = sv; 2167075 return s; } /* scan_num takes: pointer to position in buffer returns: pointer to new position in buffer side-effects: builds ops for the constant in yylval.op Read a number in any of the formats that Perl accepts: \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12. \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34 0b[01](_?[01])* 0[0-7](_?[0-7])* 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the thing it reads. If it reads a number without a decimal point or an exponent, it will try converting the number to an integer and see if it can do so without loss of precision. */ char * Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) 874111 { 874111 register const char *s = start; /* current position in buffer */ 874111 register char *d; /* destination in temp buffer */ 874111 register char *e; /* end of temp buffer */ 874111 NV nv; /* number read, as a double */ 874111 SV *sv = Nullsv; /* place to put the converted number */ 874111 bool floatit; /* boolean: int or float? */ 874111 const char *lastub = 0; /* position of last underbar */ 874111 static char const number_too_long[] = "Number too long"; /* We use the first character to decide what type of number this is */ 874111 switch (*s) { default: ###### Perl_croak(aTHX_ "panic: scan_num"); /* if it starts with a 0, it could be an octal number, a decimal in 0.13 disguise, or a hexadecimal number, or a binary number. */ case '0': { /* variables: u holds the "number so far" shift the power of 2 of the base (hex == 4, octal == 3, binary == 1) overflowed was the number more than we can hold? Shift is used when we add a digit. It also serves as an "are we in octal/hex/binary?" indicator to disallow hex characters when in octal mode. */ 312993 NV n = 0.0; 312993 UV u = 0; 312993 I32 shift; 312993 bool overflowed = FALSE; 312993 bool just_zero = TRUE; /* just plain 0 or binary number? */ 312993 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 }; static const char* const bases[5] = 312993 { "", "binary", "", "octal", "hexadecimal" }; static const char* const Bases[5] = 312993 { "", "Binary", "", "Octal", "Hexadecimal" }; static const char* const maxima[5] = { "", "0b11111111111111111111111111111111", "", "037777777777", 312993 "0xffffffff" }; 312993 const char *base, *Base, *max; /* check for hex */ 312993 if (s[1] == 'x') { 15084 shift = 4; 15084 s += 2; 15084 just_zero = FALSE; 297909 } else if (s[1] == 'b') { 28 shift = 1; 28 s += 2; 28 just_zero = FALSE; } /* check for a decimal in disguise */ 297881 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E') 291975 goto decimal; /* so it must be octal */ else { 291975 shift = 3; 291975 s++; } 307087 if (*s == '_') { 4 if (ckWARN(WARN_SYNTAX)) ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); 4 lastub = s++; } 307087 base = bases[shift]; 307087 Base = Bases[shift]; 307087 max = maxima[shift]; /* read the rest of the number */ 418122 for (;;) { /* x is used in the overflow test, b is the digit we're adding on. */ 418010 UV x, b; 418010 switch (*s) { /* if we don't mention it, we're done */ default: 12 goto out; /* _ are ignored -- but warned about if consecutive */ case '_': 12 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); 12 lastub = s++; 12 break; /* 8 and 9 are not octal */ case '8': case '9': 1290 if (shift == 3) ###### yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s)); /* FALL THROUGH */ /* octal digits */ case '2': case '3': case '4': case '5': case '6': case '7': 25568 if (shift == 1) 1 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s)); /* FALL THROUGH */ case '0': case '1': 105670 b = *s++ & 15; /* ASCII digit -> value of digit */ 105670 goto digit; /* hex digits */ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': /* make sure they said 0x */ 5241 if (shift != 4) ###### goto out; 5241 b = (*s++ & 7) + 9; /* Prepare to put the digit we have onto the end of the number so far. We check for overflows. */ digit: 110911 just_zero = FALSE; 110911 if (!overflowed) { 110811 x = u << shift; /* make room for the digit */ 110811 if ((x >> shift) != u && !(PL_hints & HINT_NEW_BINARY)) { 12 overflowed = TRUE; 12 n = (NV) u; 12 if (ckWARN_d(WARN_OVERFLOW)) 3 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), "Integer overflow in %s number", base); } else 110799 u = x | b; /* add the digit to the end */ } 110911 if (overflowed) { 112 n *= nvshift[shift]; /* If an NV has not enough bits in its * mantissa to represent an UV this summing of * small low-order numbers is a waste of time * (because the NV cannot preserve the * low-order bits anyway): we could just * remember when did we overflow and in the * end just multiply n by the right * amount. */ 112 n += (NV) b; } 112 break; } } /* if we get here, we had success: make a scalar value from the number. */ out: /* final misplaced underbar check */ 307086 if (s[-1] == '_') { ###### if (ckWARN(WARN_SYNTAX)) ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); } 307086 sv = NEWSV(92,0); 307086 if (overflowed) { 12 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0) 3 Perl_warner(aTHX_ packWARN(WARN_PORTABLE), "%s number > %s non-portable", Base, max); 12 sv_setnv(sv, n); } else { #if UVSIZE > 4 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff) Perl_warner(aTHX_ packWARN(WARN_PORTABLE), "%s number > %s non-portable", Base, max); #endif 307074 sv_setuv(sv, u); } 307086 if (just_zero && (PL_hints & HINT_NEW_INTEGER)) 1 sv = new_constant(start, s - start, "integer", sv, Nullsv, NULL); 307085 else if (PL_hints & HINT_NEW_BINARY) 2 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL); } 2 break; /* handle decimal numbers. we're also sent here when we read a 0 as the first digit */ case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '.': decimal: 565414 d = PL_tokenbuf; 565414 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */ 565414 floatit = FALSE; /* read next group of digits and _ and copy into d */ 1321479 while (isDIGIT(*s) || *s == '_') { /* skip underscores, checking for misplaced ones if -w is on */ 756065 if (*s == '_') { 292 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); 292 lastub = s++; } else { /* check for end of fixed-length buffer */ 755773 if (d >= e) ###### Perl_croak(aTHX_ number_too_long); /* if we're ok, copy the character */ 755773 *d++ = *s++; } } /* final misplaced underbar check */ 565414 if (lastub && s == lastub + 1) { 6 if (ckWARN(WARN_SYNTAX)) 3 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); } /* read a decimal portion if there is one. avoid 3..5 being interpreted as the number 3. followed by .5 */ 565414 if (*s == '.' && s[1] != '.') { 20396 floatit = TRUE; 20396 *d++ = *s++; 20396 if (*s == '_') { 6 if (ckWARN(WARN_SYNTAX)) 3 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); 6 lastub = s; } /* copy, ignoring underbars, until we run out of digits. */ 154842 for (; isDIGIT(*s) || *s == '_'; s++) { /* fixed length buffer check */ 67223 if (d >= e) ###### Perl_croak(aTHX_ number_too_long); 67223 if (*s == '_') { 1712 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); 1712 lastub = s; } else 65511 *d++ = *s; } /* fractional part ending in underbar? */ 20396 if (s[-1] == '_') { 6 if (ckWARN(WARN_SYNTAX)) 3 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); } 20396 if (*s == '.' && isDIGIT(s[1])) { /* oops, it's really a v-string, but without the "v" */ 80 s = start; 80 goto vstring; } } /* read exponent part, if present */ 565334 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) { 746 floatit = TRUE; 746 s++; /* regardless of whether user said 3E5 or 3e5, use lower 'e' */ 746 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */ /* stray preinitial _ */ 746 if (*s == '_') { 6 if (ckWARN(WARN_SYNTAX)) 3 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); 6 lastub = s++; } /* allow positive or negative exponent */ 746 if (*s == '+' || *s == '-') 628 *d++ = *s++; /* stray initial _ */ 746 if (*s == '_') { 4 if (ckWARN(WARN_SYNTAX)) 2 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); 4 lastub = s++; } /* read digits of exponent */ 2183 while (isDIGIT(*s) || *s == '_') { 1437 if (isDIGIT(*s)) { 1421 if (d >= e) ###### Perl_croak(aTHX_ number_too_long); 1421 *d++ = *s++; } else { 16 if (ckWARN(WARN_SYNTAX) && ((lastub && s == lastub + 1) || (!isDIGIT(s[1]) && s[1] != '_'))) 4 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); 16 lastub = s++; } } } /* make an sv from the string */ 565334 sv = NEWSV(92,0); /* We try to do an integer conversion first if no characters indicating "float" have been found. */ 565334 if (!floatit) { 544307 UV uv; 544307 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv); 544307 if (flags == IS_NUMBER_IN_UV) { 544205 if (uv <= IV_MAX) 544012 sv_setiv(sv, uv); /* Prefer IVs over UVs. */ else 193 sv_setuv(sv, uv); 102 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) { ###### if (uv <= (UV) IV_MIN) ###### sv_setiv(sv, -(IV)uv); else ###### floatit = TRUE; } else 102 floatit = TRUE; } 565334 if (floatit) { /* terminate the string */ 21129 *d = '\0'; 21129 nv = Atof(PL_tokenbuf); 21129 sv_setnv(sv, nv); } 565334 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) 130 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf, (floatit ? "float" : "integer"), sv, Nullsv, NULL); 130 break; /* if it starts with a v, it could be a v-string */ case 'v': vstring: 1690 sv = NEWSV(92,5); /* preallocate storage space */ 1690 s = scan_vstring(s,sv); 874110 break; } /* make the op for the constant and return */ 874110 if (sv) 874110 lvalp->opval = newSVOP(OP_CONST, 0, sv); else ###### lvalp->opval = Nullop; 874109 return (char *)s; } STATIC char * S_scan_formline(pTHX_ register char *s) 265 { 265 register char *eol; 265 register char *t; 265 SV *stuff = newSVpvn("",0); 265 bool needargs = FALSE; 265 bool eofmt = FALSE; 450 while (!needargs) { 308 if (*s == '.') { #ifdef PERL_STRICT_CR for (t = s+1;SPACE_OR_TAB(*t); t++) ; #else 120 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ; #endif 120 if (*t == '\n' || t == PL_bufend) { 120 eofmt = TRUE; 120 break; } } 188 if (PL_in_eval && !PL_rsfp) { 55 eol = (char *) memchr(s,'\n',PL_bufend-s); 55 if (!eol++) 3 eol = PL_bufend; } else 133 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 188 if (*s != '#') { 6217 for (t = s; t < eol; t++) { 6030 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) { 1 needargs = FALSE; 1 goto enough; /* ~~ must be first line in formline */ } 6029 if (*t == '@' || *t == '^') 314 needargs = TRUE; } 187 if (eol > s) { 185 sv_catpvn(stuff, s, eol-s); #ifndef PERL_STRICT_CR 185 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') { ###### char *end = SvPVX(stuff) + SvCUR(stuff); ###### end[-2] = '\n'; ###### end[-1] = '\0'; ###### SvCUR_set(stuff, SvCUR(stuff) - 1); } #endif } else 185 break; } 185 s = (char*)eol; 185 if (PL_rsfp) { 133 s = filter_gets(PL_linestr, PL_rsfp, 0); 133 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); 133 PL_bufend = PL_bufptr + SvCUR(PL_linestr); 133 PL_last_lop = PL_last_uni = Nullch; 133 if (!s) { ###### s = PL_bufptr; ###### break; } } 185 incline(s); } enough: 265 if (SvCUR(stuff)) { 176 PL_expect = XTERM; 176 if (needargs) { 142 PL_lex_state = LEX_NORMAL; 142 PL_nextval[PL_nexttoke].ival = 0; 142 force_next(','); } else 34 PL_lex_state = LEX_FORMLINE; 176 if (!IN_BYTES) { 176 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff))) 6 SvUTF8_on(stuff); 170 else if (PL_encoding) ###### sv_recode_to_utf8(stuff, PL_encoding); } 176 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff); 176 force_next(THING); 176 PL_nextval[PL_nexttoke].ival = OP_FORMLINE; 176 force_next(LSTOP); } else { 89 SvREFCNT_dec(stuff); 89 if (eofmt) 88 PL_lex_formbrack = 0; 89 PL_bufptr = s; } 265 return s; } STATIC void S_set_csh(pTHX) 4081 { #ifdef CSH 4081 if (!PL_cshlen) 1008 PL_cshlen = strlen(PL_cshname); #endif } I32 Perl_start_subparse(pTHX_ I32 is_format, U32 flags) 405652 { 405652 const I32 oldsavestack_ix = PL_savestack_ix; 405652 CV* outsidecv = PL_compcv; 405652 if (PL_compcv) { 405478 assert(SvTYPE(PL_compcv) == SVt_PVCV); } 405652 SAVEI32(PL_subline); 405652 save_item(PL_subname); 405652 SAVESPTR(PL_compcv); 405652 PL_compcv = (CV*)NEWSV(1104,0); 405652 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV); 405652 CvFLAGS(PL_compcv) |= flags; 405652 PL_subline = CopLINE(PL_curcop); 405652 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB); 405652 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv); 405652 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax; 405652 return oldsavestack_ix; } #ifdef __SC__ #pragma segment Perl_yylex #endif int Perl_yywarn(pTHX_ const char *s) 15 { 15 PL_in_eval |= EVAL_WARNONLY; 15 yyerror(s); 15 PL_in_eval &= ~EVAL_WARNONLY; 15 return 0; } int Perl_yyerror(pTHX_ const char *s) 193 { 193 const char *where = NULL; 193 const char *context = NULL; 193 int contlen = -1; 193 SV *msg; 193 if (!yychar || (yychar == ';' && !PL_rsfp)) 60 where = "at EOF"; 133 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 when the script has error such as not having the closing quotes like: if ($var eq "value) Checking of white spaces is anyway done in NetWare code. */ #ifndef NETWARE 126 while (isSPACE(*PL_oldoldbufptr)) 10 PL_oldoldbufptr++; #endif 116 context = PL_oldoldbufptr; 116 contlen = PL_bufptr - PL_oldoldbufptr; } 17 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 when the script has error such as not having the closing quotes like: if ($var eq "value) Checking of white spaces is anyway done in NetWare code. */ #ifndef NETWARE 2 while (isSPACE(*PL_oldbufptr)) 1 PL_oldbufptr++; #endif 1 context = PL_oldbufptr; 1 contlen = PL_bufptr - PL_oldbufptr; } 16 else if (yychar > 255) 1 where = "next token ???"; 15 else if (yychar == -2) { /* YYEMPTY */ 14 if (PL_lex_state == LEX_NORMAL || (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL)) 11 where = "at end of line"; 3 else if (PL_lex_inpat) ###### where = "within pattern"; else 3 where = "within string"; } else { 1 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10)); 1 if (yychar < 32) ###### Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar)); 1 else if (isPRINT_LC(yychar)) 1 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar); else ###### Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255); 1 where = SvPVX_const(where_sv); } 193 msg = sv_2mortal(newSVpv(s, 0)); 193 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ", OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 193 if (context) 117 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context); else 76 Perl_sv_catpvf(aTHX_ msg, "%s\n", where); 193 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) { ###### Perl_sv_catpvf(aTHX_ msg, " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n", (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start); ###### PL_multi_end = 0; } 193 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX)) 14 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg); else 179 qerror(msg); 193 if (PL_error_count >= 10) { 1 if (PL_in_eval && SvCUR(ERRSV)) 1 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n", ERRSV, OutCopFILE(PL_curcop)); else ###### Perl_croak(aTHX_ "%s has too many errors.\n", OutCopFILE(PL_curcop)); } 192 PL_in_my = 0; 192 PL_in_my_stash = Nullhv; 192 return 0; } #ifdef __SC__ #pragma segment Main #endif STATIC char* S_swallow_bom(pTHX_ U8 *s) 1685 { 1685 const STRLEN slen = SvCUR(PL_linestr); 1685 switch (s[0]) { case 0xFF: 4 if (s[1] == 0xFE) { /* UTF-16 little-endian? (or UTF32-LE?) */ 4 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */ ###### Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE"); #ifndef PERL_NO_UTF16_FILTER 4 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n"); 4 s += 2; utf16le: 7 if (PL_bufend > (char*)s) { 7 U8 *news; 7 I32 newlen; 7 filter_add(utf16rev_textfilter, NULL); 7 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); 7 utf16_to_utf8_reversed(s, news, PL_bufend - (char*)s - 1, &newlen); 7 sv_setpvn(PL_linestr, (const char*)news, newlen); 7 Safefree(news); 7 SvUTF8_on(PL_linestr); 7 s = (U8*)SvPVX(PL_linestr); 7 PL_bufend = SvPVX(PL_linestr) + newlen; } #else Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE"); #endif } 7 break; case 0xFE: 4 if (s[1] == 0xFF) { /* UTF-16 big-endian? */ #ifndef PERL_NO_UTF16_FILTER 4 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n"); 4 s += 2; utf16be: 7 if (PL_bufend > (char *)s) { 7 U8 *news; 7 I32 newlen; 7 filter_add(utf16_textfilter, NULL); 7 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); 7 utf16_to_utf8(s, news, PL_bufend - (char*)s, &newlen); 7 sv_setpvn(PL_linestr, (const char*)news, newlen); 7 Safefree(news); 7 SvUTF8_on(PL_linestr); 7 s = (U8*)SvPVX(PL_linestr); 7 PL_bufend = SvPVX(PL_linestr) + newlen; } #else Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE"); #endif } 7 break; case 0xEF: 4 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) { 4 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n"); 4 s += 3; /* UTF-8 */ } 4 break; case 0: 3 if (slen > 3) { 3 if (s[1] == 0) { ###### if (s[2] == 0xFE && s[3] == 0xFF) { /* UTF-32 big-endian */ ###### Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE"); } } 3 else if (s[2] == 0 && s[3] != 0) { /* Leading bytes * 00 xx 00 xx * are a good indicator of UTF-16BE. */ 3 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n"); ###### goto utf16be; } } default: 1670 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. */ 3 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n"); ###### goto utf16le; } } 1685 return (char*)s; } /* * restore_rsfp * Restore a source filter. */ static void restore_rsfp(pTHX_ void *f) 106270 { 106270 PerlIO *fp = (PerlIO*)f; 106270 if (PL_rsfp == PerlIO_stdin()) ###### PerlIO_clearerr(PL_rsfp); 106270 else if (PL_rsfp && (PL_rsfp != fp)) 90 PerlIO_close(PL_rsfp); 106270 PL_rsfp = fp; } #ifndef PERL_NO_UTF16_FILTER static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) 7 { 7 const STRLEN old = SvCUR(sv); 7 const I32 count = FILTER_READ(idx+1, sv, maxlen); DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter(%p): %d %d (%d)\n", 7 utf16_textfilter, idx, maxlen, (int) count)); 7 if (count) { ###### U8* tmps; ###### I32 newlen; ###### New(898, 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); } 7 DEBUG_P({sv_dump(sv);}); 7 return SvCUR(sv); } static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen) 14 { 14 const STRLEN old = SvCUR(sv); 14 const I32 count = FILTER_READ(idx+1, sv, maxlen); DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16rev_textfilter(%p): %d %d (%d)\n", 14 utf16rev_textfilter, idx, maxlen, (int) count)); 14 if (count) { 7 U8* tmps; 7 I32 newlen; 7 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); 7 Copy(SvPVX_const(sv), tmps, old, char); 7 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old, SvCUR(sv) - old, &newlen); 7 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old); } 14 DEBUG_P({ sv_dump(sv); }); 14 return count; } #endif /* Returns a pointer to the next character after the parsed vstring, as well as updating the passed in sv. Function must be called like sv = NEWSV(92,5); s = scan_vstring(s,sv); The sv should already be large enough to store the vstring passed in, for performance reasons. */ char * Perl_scan_vstring(pTHX_ const char *s, SV *sv) 1690 { 1690 const char *pos = s; 1690 const char *start = s; 1690 if (*pos == 'v') pos++; /* get past 'v' */ 3796 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_')) 2106 pos++; 1690 if ( *pos != '.') { /* this may not be a v-string if followed by => */ 29 const char *next = pos; 38 while (next < PL_bufend && isSPACE(*next)) 9 ++next; 29 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) { /* return string not v-string */ 1 sv_setpvn(sv,(char *)s,pos-s); 1 return (char *)pos; } } 1689 if (!isALPHA(*pos)) { 1689 UV rev; 1689 U8 tmpbuf[UTF8_MAXBYTES+1]; 1689 U8 *tmpend; 1689 if (*s == 'v') s++; /* get past 'v' */ 1689 sv_setpvn(sv, "", 0); 6980 for (;;) { 5291 rev = 0; { /* this is atoi() that tolerates underscores */ 5291 const char *end = pos; 5291 UV mult = 1; 12594 while (--end >= s) { 7303 UV orev; 7303 if (*end == '_') 1 continue; 7302 orev = rev; 7302 rev += (*end - '0') * mult; 7302 mult *= 10; 7302 if (orev > rev && ckWARN_d(WARN_OVERFLOW)) ###### Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), "Integer overflow in decimal number"); } } #ifdef EBCDIC if (rev > 0x7FFFFFFF) Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647"); #endif /* Append native character for the rev point */ 5291 tmpend = uvchr_to_utf8(tmpbuf, rev); 5291 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); 5291 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev))) 648 SvUTF8_on(sv); 5291 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1])) 3602 s = ++pos; else { 1689 s = pos; 1689 break; } 8801 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_')) 5199 pos++; } 1689 SvPOK_on(sv); 1689 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start); 1689 SvRMAGICAL_on(sv); } 1689 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: */