/* 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