1 /* toke.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 /* 12 * "It all comes from here, the stench and the peril." --Frodo 13 */ 14 15 /* 16 * This file is the lexer for Perl. It's closely linked to the 17 * parser, perly.y. 18 * 19 * The main routine is yylex(), which returns the next token. 20 */ 21 22 #include "EXTERN.h" 23 #define PERL_IN_TOKE_C 24 #include "perl.h" 25 26 #define yychar (*PL_yycharp) 27 #define yylval (*PL_yylvalp) 28 29 static const char ident_too_long[] = 30 "Identifier too long"; 31 static const char c_without_g[] = 32 "Use of /c modifier is meaningless without /g"; 33 static const char c_in_subst[] = 34 "Use of /c modifier is meaningless in s///"; 35 36 static void restore_rsfp(pTHX_ void *f); 37 #ifndef PERL_NO_UTF16_FILTER 38 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen); 39 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen); 40 #endif 41 42 #define XFAKEBRACK 128 43 #define XENUMMASK 127 44 45 #ifdef USE_UTF8_SCRIPTS 46 # define UTF (!IN_BYTES) 47 #else 48 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8)) 49 #endif 50 51 /* In variables named $^X, these are the legal values for X. 52 * 1999-02-27 mjd-perl-patch@plover.com */ 53 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x))) 54 55 /* On MacOS, respect nonbreaking spaces */ 56 #ifdef MACOS_TRADITIONAL 57 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t') 58 #else 59 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t') 60 #endif 61 62 /* LEX_* are values for PL_lex_state, the state of the lexer. 63 * They are arranged oddly so that the guard on the switch statement 64 * can get by with a single comparison (if the compiler is smart enough). 65 */ 66 67 /* #define LEX_NOTPARSING 11 is done in perl.h. */ 68 69 #define LEX_NORMAL 10 70 #define LEX_INTERPNORMAL 9 71 #define LEX_INTERPCASEMOD 8 72 #define LEX_INTERPPUSH 7 73 #define LEX_INTERPSTART 6 74 #define LEX_INTERPEND 5 75 #define LEX_INTERPENDMAYBE 4 76 #define LEX_INTERPCONCAT 3 77 #define LEX_INTERPCONST 2 78 #define LEX_FORMLINE 1 79 #define LEX_KNOWNEXT 0 80 81 #ifdef DEBUGGING 82 static const char* const lex_state_names[] = { 83 "KNOWNEXT", 84 "FORMLINE", 85 "INTERPCONST", 86 "INTERPCONCAT", 87 "INTERPENDMAYBE", 88 "INTERPEND", 89 "INTERPSTART", 90 "INTERPPUSH", 91 "INTERPCASEMOD", 92 "INTERPNORMAL", 93 "NORMAL" 94 }; 95 #endif 96 97 #ifdef ff_next 98 #undef ff_next 99 #endif 100 101 #include "keywords.h" 102 103 /* CLINE is a macro that ensures PL_copline has a sane value */ 104 105 #ifdef CLINE 106 #undef CLINE 107 #endif 108 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline)) 109 110 /* 111 * Convenience functions to return different tokens and prime the 112 * lexer for the next token. They all take an argument. 113 * 114 * TOKEN : generic token (used for '(', DOLSHARP, etc) 115 * OPERATOR : generic operator 116 * AOPERATOR : assignment operator 117 * PREBLOCK : beginning the block after an if, while, foreach, ... 118 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref) 119 * PREREF : *EXPR where EXPR is not a simple identifier 120 * TERM : expression term 121 * LOOPX : loop exiting command (goto, last, dump, etc) 122 * FTST : file test operator 123 * FUN0 : zero-argument function 124 * FUN1 : not used, except for not, which isn't a UNIOP 125 * BOop : bitwise or or xor 126 * BAop : bitwise and 127 * SHop : shift operator 128 * PWop : power operator 129 * PMop : pattern-matching operator 130 * Aop : addition-level operator 131 * Mop : multiplication-level operator 132 * Eop : equality-testing operator 133 * Rop : relational operator <= != gt 134 * 135 * Also see LOP and lop() below. 136 */ 137 138 #ifdef DEBUGGING /* Serve -DT. */ 139 # define REPORT(retval) tokereport(s,(int)retval) 140 #else 141 # define REPORT(retval) (retval) 142 #endif 143 144 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval)) 145 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval)) 146 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval))) 147 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval)) 148 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval)) 149 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval)) 150 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval)) 151 #define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX)) 152 #define FTST(f) return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP)) 153 #define FUN0(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0)) 154 #define FUN1(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1)) 155 #define BOop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP))) 156 #define BAop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP))) 157 #define SHop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP))) 158 #define PWop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP))) 159 #define PMop(f) return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP)) 160 #define Aop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP))) 161 #define Mop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP))) 162 #define Eop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP)) 163 #define Rop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP)) 164 165 /* This bit of chicanery makes a unary function followed by 166 * a parenthesis into a function with one argument, highest precedence. 167 * The UNIDOR macro is for unary functions that can be followed by the // 168 * operator (such as C). 169 */ 170 #define UNI2(f,x) { \ 171 yylval.ival = f; \ 172 PL_expect = x; \ 173 PL_bufptr = s; \ 174 PL_last_uni = PL_oldbufptr; \ 175 PL_last_lop_op = f; \ 176 if (*s == '(') \ 177 return REPORT( (int)FUNC1 ); \ 178 s = skipspace(s); \ 179 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \ 180 } 181 #define UNI(f) UNI2(f,XTERM) 182 #define UNIDOR(f) UNI2(f,XTERMORDORDOR) 183 184 #define UNIBRACK(f) { \ 185 yylval.ival = f; \ 186 PL_bufptr = s; \ 187 PL_last_uni = PL_oldbufptr; \ 188 if (*s == '(') \ 189 return REPORT( (int)FUNC1 ); \ 190 s = skipspace(s); \ 191 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \ 192 } 193 194 /* grandfather return to old style */ 195 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP) 196 197 #ifdef DEBUGGING 198 199 /* how to interpret the yylval associated with the token */ 200 enum token_type { 201 TOKENTYPE_NONE, 202 TOKENTYPE_IVAL, 203 TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */ 204 TOKENTYPE_PVAL, 205 TOKENTYPE_OPVAL, 206 TOKENTYPE_GVVAL 207 }; 208 209 static struct debug_tokens { const int token, type; const char *name; } 210 const debug_tokens[] = 211 { 212 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" }, 213 { ANDAND, TOKENTYPE_NONE, "ANDAND" }, 214 { ANDOP, TOKENTYPE_NONE, "ANDOP" }, 215 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" }, 216 { ARROW, TOKENTYPE_NONE, "ARROW" }, 217 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" }, 218 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" }, 219 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" }, 220 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" }, 221 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" }, 222 { DO, TOKENTYPE_NONE, "DO" }, 223 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" }, 224 { DORDOR, TOKENTYPE_NONE, "DORDOR" }, 225 { DOROP, TOKENTYPE_OPNUM, "DOROP" }, 226 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" }, 227 { ELSE, TOKENTYPE_NONE, "ELSE" }, 228 { ELSIF, TOKENTYPE_IVAL, "ELSIF" }, 229 { EQOP, TOKENTYPE_OPNUM, "EQOP" }, 230 { FOR, TOKENTYPE_IVAL, "FOR" }, 231 { FORMAT, TOKENTYPE_NONE, "FORMAT" }, 232 { FUNC, TOKENTYPE_OPNUM, "FUNC" }, 233 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" }, 234 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" }, 235 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" }, 236 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" }, 237 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" }, 238 { IF, TOKENTYPE_IVAL, "IF" }, 239 { LABEL, TOKENTYPE_PVAL, "LABEL" }, 240 { LOCAL, TOKENTYPE_IVAL, "LOCAL" }, 241 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" }, 242 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" }, 243 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" }, 244 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" }, 245 { METHOD, TOKENTYPE_OPVAL, "METHOD" }, 246 { MULOP, TOKENTYPE_OPNUM, "MULOP" }, 247 { MY, TOKENTYPE_IVAL, "MY" }, 248 { MYSUB, TOKENTYPE_NONE, "MYSUB" }, 249 { NOAMP, TOKENTYPE_NONE, "NOAMP" }, 250 { NOTOP, TOKENTYPE_NONE, "NOTOP" }, 251 { OROP, TOKENTYPE_IVAL, "OROP" }, 252 { OROR, TOKENTYPE_NONE, "OROR" }, 253 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" }, 254 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" }, 255 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" }, 256 { POSTINC, TOKENTYPE_NONE, "POSTINC" }, 257 { POWOP, TOKENTYPE_OPNUM, "POWOP" }, 258 { PREDEC, TOKENTYPE_NONE, "PREDEC" }, 259 { PREINC, TOKENTYPE_NONE, "PREINC" }, 260 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" }, 261 { REFGEN, TOKENTYPE_NONE, "REFGEN" }, 262 { RELOP, TOKENTYPE_OPNUM, "RELOP" }, 263 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" }, 264 { SUB, TOKENTYPE_NONE, "SUB" }, 265 { THING, TOKENTYPE_OPVAL, "THING" }, 266 { UMINUS, TOKENTYPE_NONE, "UMINUS" }, 267 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" }, 268 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" }, 269 { UNLESS, TOKENTYPE_IVAL, "UNLESS" }, 270 { UNTIL, TOKENTYPE_IVAL, "UNTIL" }, 271 { USE, TOKENTYPE_IVAL, "USE" }, 272 { WHILE, TOKENTYPE_IVAL, "WHILE" }, 273 { WORD, TOKENTYPE_OPVAL, "WORD" }, 274 { 0, TOKENTYPE_NONE, 0 } 275 }; 276 277 /* dump the returned token in rv, plus any optional arg in yylval */ 278 279 STATIC int 280 S_tokereport(pTHX_ const char* s, I32 rv) 281 38799749 { 282 38799749 if (DEBUG_T_TEST) { 283 ###### const char *name = Nullch; 284 ###### enum token_type type = TOKENTYPE_NONE; 285 ###### const struct debug_tokens *p; 286 ###### SV* const report = newSVpvn("<== ", 4); 287 288 ###### for (p = debug_tokens; p->token; p++) { 289 ###### if (p->token == (int)rv) { 290 ###### name = p->name; 291 ###### type = p->type; 292 ###### break; 293 } 294 } 295 ###### if (name) 296 ###### Perl_sv_catpv(aTHX_ report, name); 297 ###### else if ((char)rv > ' ' && (char)rv < '~') 298 ###### Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv); 299 ###### else if (!rv) 300 ###### Perl_sv_catpv(aTHX_ report, "EOF"); 301 else 302 ###### Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv); 303 ###### switch (type) { 304 case TOKENTYPE_NONE: 305 case TOKENTYPE_GVVAL: /* doesn't appear to be used */ 306 ###### break; 307 case TOKENTYPE_IVAL: 308 ###### Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival); 309 ###### break; 310 case TOKENTYPE_OPNUM: 311 ###### Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)", 312 PL_op_name[yylval.ival]); 313 ###### break; 314 case TOKENTYPE_PVAL: 315 ###### Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval); 316 ###### break; 317 case TOKENTYPE_OPVAL: 318 ###### if (yylval.opval) 319 ###### Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)", 320 PL_op_name[yylval.opval->op_type]); 321 else 322 ###### Perl_sv_catpv(aTHX_ report, "(opval=null)"); 323 break; 324 } 325 ###### Perl_sv_catpvf(aTHX_ report, " at line %"IVdf" [", (IV)CopLINE(PL_curcop)); 326 ###### if (s - PL_bufptr > 0) 327 ###### sv_catpvn(report, PL_bufptr, s - PL_bufptr); 328 else { 329 ###### if (PL_oldbufptr && *PL_oldbufptr) 330 ###### sv_catpv(report, PL_tokenbuf); 331 } 332 ###### PerlIO_printf(Perl_debug_log, "### %s]\n", SvPV_nolen_const(report)); 333 }; 334 38799749 return (int)rv; 335 } 336 337 #endif 338 339 /* 340 * S_ao 341 * 342 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR 343 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN 344 */ 345 346 STATIC int 347 S_ao(pTHX_ int toketype) 348 1092246 { 349 1092246 if (*PL_bufptr == '=') { 350 119912 PL_bufptr++; 351 119912 if (toketype == ANDAND) 352 21 yylval.ival = OP_ANDASSIGN; 353 119891 else if (toketype == OROR) 354 25020 yylval.ival = OP_ORASSIGN; 355 94871 else if (toketype == DORDOR) 356 6 yylval.ival = OP_DORASSIGN; 357 119912 toketype = ASSIGNOP; 358 } 359 1092246 return toketype; 360 } 361 362 /* 363 * S_no_op 364 * When Perl expects an operator and finds something else, no_op 365 * prints the warning. It always prints " found where 366 * operator expected. It prints "Missing semicolon on previous line?" 367 * if the surprise occurs at the start of the line. "do you need to 368 * predeclare ..." is printed out for code like "sub bar; foo bar $x" 369 * where the compiler doesn't know if foo is a method call or a function. 370 * It prints "Missing operator before end of line" if there's nothing 371 * after the missing operator, or "... before <...>" if there is something 372 * after the missing operator. 373 */ 374 375 STATIC void 376 S_no_op(pTHX_ const char *what, char *s) 377 15 { 378 15 char * const oldbp = PL_bufptr; 379 15 const bool is_first = (PL_oldbufptr == PL_linestart); 380 381 15 if (!s) 382 ###### s = oldbp; 383 else 384 15 PL_bufptr = s; 385 15 yywarn(Perl_form(aTHX_ "%s found where operator expected", what)); 386 15 if (ckWARN_d(WARN_SYNTAX)) { 387 14 if (is_first) 388 ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 389 "\t(Missing semicolon on previous line?)\n"); 390 14 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) { 391 13 const char *t; 392 13 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ; 393 13 if (t < PL_bufptr && isSPACE(*t)) 394 3 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 395 "\t(Do you need to predeclare %.*s?)\n", 396 t - PL_oldoldbufptr, PL_oldoldbufptr); 397 } 398 else { 399 1 assert(s >= oldbp); 400 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 401 "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp); 402 } 403 } 404 15 PL_bufptr = oldbp; 405 } 406 407 /* 408 * S_missingterm 409 * Complain about missing quote/regexp/heredoc terminator. 410 * If it's called with (char *)NULL then it cauterizes the line buffer. 411 * If we're in a delimited string and the delimiter is a control 412 * character, it's reformatted into a two-char sequence like ^C. 413 * This is fatal. 414 */ 415 416 STATIC void 417 S_missingterm(pTHX_ char *s) 418 4 { 419 4 char tmpbuf[3]; 420 4 char q; 421 4 if (s) { 422 ###### char * const nl = strrchr(s,'\n'); 423 ###### if (nl) 424 ###### *nl = '\0'; 425 } 426 4 else if ( 427 #ifdef EBCDIC 428 iscntrl(PL_multi_close) 429 #else 430 PL_multi_close < 32 || PL_multi_close == 127 431 #endif 432 ) { 433 ###### *tmpbuf = '^'; 434 ###### tmpbuf[1] = toCTRL(PL_multi_close); 435 ###### tmpbuf[2] = '\0'; 436 ###### s = tmpbuf; 437 } 438 else { 439 4 *tmpbuf = (char)PL_multi_close; 440 4 tmpbuf[1] = '\0'; 441 4 s = tmpbuf; 442 } 443 4 q = strchr(s,'"') ? '\'' : '"'; 444 4 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q); 445 } 446 447 /* 448 * Perl_deprecate 449 */ 450 451 void 452 Perl_deprecate(pTHX_ const char *s) 453 40 { 454 40 if (ckWARN(WARN_DEPRECATED)) 455 9 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s); 456 } 457 458 void 459 Perl_deprecate_old(pTHX_ const char *s) 460 25 { 461 /* This function should NOT be called for any new deprecated warnings */ 462 /* Use Perl_deprecate instead */ 463 /* */ 464 /* It is here to maintain backward compatibility with the pre-5.8 */ 465 /* warnings category hierarchy. The "deprecated" category used to */ 466 /* live under the "syntax" category. It is now a top-level category */ 467 /* in its own right. */ 468 469 25 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) 470 6 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 471 "Use of %s is deprecated", s); 472 } 473 474 /* 475 * depcom 476 * Deprecate a comma-less variable list. 477 */ 478 479 STATIC void 480 S_depcom(pTHX) 481 6 { 482 6 deprecate_old("comma-less variable list"); 483 } 484 485 /* 486 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and 487 * utf16-to-utf8-reversed. 488 */ 489 490 #ifdef PERL_CR_FILTER 491 static void 492 strip_return(SV *sv) 493 { 494 register const char *s = SvPVX_const(sv); 495 register const char * const e = s + SvCUR(sv); 496 /* outer loop optimized to do nothing if there are no CR-LFs */ 497 while (s < e) { 498 if (*s++ == '\r' && *s == '\n') { 499 /* hit a CR-LF, need to copy the rest */ 500 register char *d = s - 1; 501 *d++ = *s++; 502 while (s < e) { 503 if (*s == '\r' && s[1] == '\n') 504 s++; 505 *d++ = *s++; 506 } 507 SvCUR(sv) -= s - d; 508 return; 509 } 510 } 511 } 512 513 STATIC I32 514 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) 515 { 516 const I32 count = FILTER_READ(idx+1, sv, maxlen); 517 if (count > 0 && !maxlen) 518 strip_return(sv); 519 return count; 520 } 521 #endif 522 523 /* 524 * Perl_lex_start 525 * Initialize variables. Uses the Perl save_stack to save its state (for 526 * recursive calls to the parser). 527 */ 528 529 void 530 Perl_lex_start(pTHX_ SV *line) 531 106267 { 532 106267 const char *s; 533 106267 STRLEN len; 534 535 106267 SAVEI32(PL_lex_dojoin); 536 106267 SAVEI32(PL_lex_brackets); 537 106267 SAVEI32(PL_lex_casemods); 538 106267 SAVEI32(PL_lex_starts); 539 106267 SAVEI32(PL_lex_state); 540 106267 SAVEVPTR(PL_lex_inpat); 541 106267 SAVEI32(PL_lex_inwhat); 542 106267 if (PL_lex_state == LEX_KNOWNEXT) { 543 23 I32 toke = PL_nexttoke; 544 46 while (--toke >= 0) { 545 23 SAVEI32(PL_nexttype[toke]); 546 23 SAVEVPTR(PL_nextval[toke]); 547 } 548 23 SAVEI32(PL_nexttoke); 549 } 550 106267 SAVECOPLINE(PL_curcop); 551 106267 SAVEPPTR(PL_bufptr); 552 106267 SAVEPPTR(PL_bufend); 553 106267 SAVEPPTR(PL_oldbufptr); 554 106267 SAVEPPTR(PL_oldoldbufptr); 555 106267 SAVEPPTR(PL_last_lop); 556 106267 SAVEPPTR(PL_last_uni); 557 106267 SAVEPPTR(PL_linestart); 558 106267 SAVESPTR(PL_linestr); 559 106267 SAVEGENERICPV(PL_lex_brackstack); 560 106267 SAVEGENERICPV(PL_lex_casestack); 561 106267 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp); 562 106267 SAVESPTR(PL_lex_stuff); 563 106267 SAVEI32(PL_lex_defer); 564 106267 SAVEI32(PL_sublex_info.sub_inwhat); 565 106267 SAVESPTR(PL_lex_repl); 566 106267 SAVEINT(PL_expect); 567 106267 SAVEINT(PL_lex_expect); 568 569 106267 PL_lex_state = LEX_NORMAL; 570 106267 PL_lex_defer = 0; 571 106267 PL_expect = XSTATE; 572 106267 PL_lex_brackets = 0; 573 106267 New(899, PL_lex_brackstack, 120, char); 574 106267 New(899, PL_lex_casestack, 12, char); 575 106267 PL_lex_casemods = 0; 576 106267 *PL_lex_casestack = '\0'; 577 106267 PL_lex_dojoin = 0; 578 106267 PL_lex_starts = 0; 579 106267 PL_lex_stuff = Nullsv; 580 106267 PL_lex_repl = Nullsv; 581 106267 PL_lex_inpat = 0; 582 106267 PL_nexttoke = 0; 583 106267 PL_lex_inwhat = 0; 584 106267 PL_sublex_info.sub_inwhat = 0; 585 106267 PL_linestr = line; 586 106267 if (SvREADONLY(PL_linestr)) 587 1753 PL_linestr = sv_2mortal(newSVsv(PL_linestr)); 588 106267 s = SvPV_const(PL_linestr, len); 589 106267 if (!len || s[len-1] != ';') { 590 82525 if (!(SvFLAGS(PL_linestr) & SVs_TEMP)) 591 45556 PL_linestr = sv_2mortal(newSVsv(PL_linestr)); 592 82525 sv_catpvn(PL_linestr, "\n;", 2); 593 } 594 106267 SvTEMP_off(PL_linestr); 595 106267 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); 596 106267 PL_bufend = PL_bufptr + SvCUR(PL_linestr); 597 106267 PL_last_lop = PL_last_uni = Nullch; 598 106267 PL_rsfp = 0; 599 } 600 601 /* 602 * Perl_lex_end 603 * Finalizer for lexing operations. Must be called when the parser is 604 * done with the lexer. 605 */ 606 607 void 608 Perl_lex_end(pTHX) 609 100659 { 610 100659 PL_doextract = FALSE; 611 } 612 613 /* 614 * S_incline 615 * This subroutine has nothing to do with tilting, whether at windmills 616 * or pinball tables. Its name is short for "increment line". It 617 * increments the current line number in CopLINE(PL_curcop) and checks 618 * to see whether the line starts with a comment of the form 619 * # line 500 "foo.pm" 620 * If so, it sets the current line number and file to the values in the comment. 621 */ 622 623 STATIC void 624 S_incline(pTHX_ char *s) 625 8682471 { 626 8682471 char *t; 627 8682471 char *n; 628 8682471 char *e; 629 8682471 char ch; 630 631 8682471 CopLINE_inc(PL_curcop); 632 8682471 if (*s++ != '#') 633 8346618 return; 634 750322 while (SPACE_OR_TAB(*s)) s++; 635 335853 if (strnEQ(s, "line", 4)) 636 819 s += 4; 637 else 638 819 return; 639 819 if (SPACE_OR_TAB(*s)) 640 806 s++; 641 else 642 806 return; 643 806 while (SPACE_OR_TAB(*s)) s++; 644 806 if (!isDIGIT(*s)) 645 806 return; 646 806 n = s; 647 2049 while (isDIGIT(*s)) 648 1243 s++; 649 1006 while (SPACE_OR_TAB(*s)) 650 200 s++; 651 806 if (*s == '"' && (t = strchr(s+1, '"'))) { 652 200 s++; 653 200 e = t + 1; 654 } 655 else { 656 606 for (t = s; !isSPACE(*t); t++) ; 657 606 e = t; 658 } 659 806 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f') 660 ###### e++; 661 806 if (*e != '\n' && *e != '\0') 662 ###### return; /* false alarm */ 663 664 806 ch = *t; 665 806 *t = '\0'; 666 806 if (t - s > 0) { 667 200 CopFILE_free(PL_curcop); 668 200 CopFILE_set(PL_curcop, s); 669 } 670 806 *t = ch; 671 806 CopLINE_set(PL_curcop, atoi(n)-1); 672 } 673 674 /* 675 * S_skipspace 676 * Called to gobble the appropriate amount and type of whitespace. 677 * Skips comments as well. 678 */ 679 680 STATIC char * 681 S_skipspace(pTHX_ register char *s) 682 12968792 { 683 12968792 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { 684 556 while (s < PL_bufend && SPACE_OR_TAB(*s)) 685 63 s++; 686 493 return s; 687 } 688 13174635 for (;;) { 689 13174634 STRLEN prevlen; 690 13174634 SSize_t oldprevlen, oldoldprevlen; 691 13174634 SSize_t oldloplen = 0, oldunilen = 0; 692 19417590 while (s < PL_bufend && isSPACE(*s)) { 693 6242956 if (*s++ == '\n' && PL_in_eval && !PL_rsfp) 694 31760 incline(s); 695 } 696 697 /* comment */ 698 13174634 if (s < PL_bufend && *s == '#') { 699 687852 while (s < PL_bufend && *s != '\n') 700 671612 s++; 701 16240 if (s < PL_bufend) { 702 16240 s++; 703 16240 if (PL_in_eval && !PL_rsfp) { 704 178 incline(s); 705 178 continue; 706 } 707 } 708 } 709 710 /* only continue to recharge the buffer if we're at the end 711 * of the buffer, we're not reading from a source filter, and 712 * we're in normal lexing mode 713 */ 714 13174456 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat || 715 PL_lex_state == LEX_FORMLINE) 716 12966516 return s; 717 718 /* try to recharge the buffer */ 719 207940 if ((s = filter_gets(PL_linestr, PL_rsfp, 720 (prevlen = SvCUR(PL_linestr)))) == Nullch) 721 { 722 /* end of file. Add on the -p or -n magic */ 723 1783 if (PL_minus_p) { 724 ###### sv_setpv(PL_linestr, 725 ";}continue{print or die qq(-p destination: $!\\n);}"); 726 ###### PL_minus_n = PL_minus_p = 0; 727 } 728 1783 else if (PL_minus_n) { 729 4 sv_setpvn(PL_linestr, ";}", 2); 730 4 PL_minus_n = 0; 731 } 732 else 733 1779 sv_setpvn(PL_linestr,";", 1); 734 735 /* reset variables for next time we lex */ 736 1783 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart 737 = SvPVX(PL_linestr); 738 1783 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 739 1783 PL_last_lop = PL_last_uni = Nullch; 740 741 /* Close the filehandle. Could be from -P preprocessor, 742 * STDIN, or a regular file. If we were reading code from 743 * STDIN (because the commandline held no -e or filename) 744 * then we don't close it, we reset it so the code can 745 * read from STDIN too. 746 */ 747 748 1783 if (PL_preprocess && !PL_in_eval) 749 ###### (void)PerlProc_pclose(PL_rsfp); 750 1783 else if ((PerlIO*)PL_rsfp == PerlIO_stdin()) 751 ###### PerlIO_clearerr(PL_rsfp); 752 else 753 1783 (void)PerlIO_close(PL_rsfp); 754 1783 PL_rsfp = Nullfp; 755 1783 return s; 756 } 757 758 /* not at end of file, so we only read another line */ 759 /* make corresponding updates to old pointers, for yyerror() */ 760 206157 oldprevlen = PL_oldbufptr - PL_bufend; 761 206157 oldoldprevlen = PL_oldoldbufptr - PL_bufend; 762 206157 if (PL_last_uni) 763 23524 oldunilen = PL_last_uni - PL_bufend; 764 206157 if (PL_last_lop) 765 18980 oldloplen = PL_last_lop - PL_bufend; 766 206157 PL_linestart = PL_bufptr = s + prevlen; 767 206157 PL_bufend = s + SvCUR(PL_linestr); 768 206157 s = PL_bufptr; 769 206157 PL_oldbufptr = s + oldprevlen; 770 206157 PL_oldoldbufptr = s + oldoldprevlen; 771 206157 if (PL_last_uni) 772 23524 PL_last_uni = s + oldunilen; 773 206157 if (PL_last_lop) 774 18980 PL_last_lop = s + oldloplen; 775 206157 incline(s); 776 777 /* debugger active and we're not compiling the debugger code, 778 * so store the line into the debugger's array of lines 779 */ 780 206157 if (PERLDB_LINE && PL_curstash != PL_debstash) { 781 1 SV * const sv = NEWSV(85,0); 782 783 1 sv_upgrade(sv, SVt_PVMG); 784 1 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr); 785 1 (void)SvIOK_on(sv); 786 1 SvIV_set(sv, 0); 787 1 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); 788 } 789 } 790 } 791 792 /* 793 * S_check_uni 794 * Check the unary operators to ensure there's no ambiguity in how they're 795 * used. An ambiguous piece of code would be: 796 * rand + 5 797 * This doesn't mean rand() + 5. Because rand() is a unary operator, 798 * the +5 is its argument. 799 */ 800 801 STATIC void 802 S_check_uni(pTHX) 803 14098 { 804 14098 char *s; 805 14098 char *t; 806 807 14098 if (PL_oldoldbufptr != PL_last_uni) 808 14059 return; 809 50 while (isSPACE(*PL_last_uni)) 810 11 PL_last_uni++; 811 39 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ; 812 39 if ((t = strchr(s, '(')) && t < PL_bufptr) 813 33 return; 814 6 if (ckWARN_d(WARN_AMBIGUOUS)){ 815 5 const char ch = *s; 816 5 *s = '\0'; 817 5 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), 818 "Warning: Use of \"%s\" without parentheses is ambiguous", 819 PL_last_uni); 820 5 *s = ch; 821 } 822 } 823 824 /* 825 * LOP : macro to build a list operator. Its behaviour has been replaced 826 * with a subroutine, S_lop() for which LOP is just another name. 827 */ 828 829 #define LOP(f,x) return lop(f,x,s) 830 831 /* 832 * S_lop 833 * Build a list operator (or something that might be one). The rules: 834 * - if we have a next token, then it's a list operator [why?] 835 * - if the next thing is an opening paren, then it's a function 836 * - else it's a list operator 837 */ 838 839 STATIC I32 840 S_lop(pTHX_ I32 f, int x, char *s) 841 379099 { 842 379099 yylval.ival = f; 843 379099 CLINE; 844 379099 PL_expect = x; 845 379099 PL_bufptr = s; 846 379099 PL_last_lop = PL_oldbufptr; 847 379099 PL_last_lop_op = (OPCODE)f; 848 379099 if (PL_nexttoke) 849 224 return REPORT(LSTOP); 850 378875 if (*s == '(') 851 144139 return REPORT(FUNC); 852 234736 s = skipspace(s); 853 234736 if (*s == '(') 854 8428 return REPORT(FUNC); 855 else 856 226308 return REPORT(LSTOP); 857 } 858 859 /* 860 * S_force_next 861 * When the lexer realizes it knows the next token (for instance, 862 * it is reordering tokens for the parser) then it can call S_force_next 863 * to know what token to return the next time the lexer is called. Caller 864 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer 865 * handles the token correctly. 866 */ 867 868 STATIC void 869 S_force_next(pTHX_ I32 type) 870 4267093 { 871 4267093 PL_nexttype[PL_nexttoke] = type; 872 4267093 PL_nexttoke++; 873 4267093 if (PL_lex_state != LEX_KNOWNEXT) { 874 4056399 PL_lex_defer = PL_lex_state; 875 4056399 PL_lex_expect = PL_expect; 876 4056399 PL_lex_state = LEX_KNOWNEXT; 877 } 878 } 879 880 STATIC SV * 881 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len) 882 1121105 { 883 1121105 SV * const sv = newSVpvn(start,len); 884 1121105 if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len)) 885 117 SvUTF8_on(sv); 886 1121105 return sv; 887 } 888 889 /* 890 * S_force_word 891 * When the lexer knows the next thing is a word (for instance, it has 892 * just seen -> and it knows that the next char is a word char, then 893 * it calls S_force_word to stick the next word into the PL_next lookahead. 894 * 895 * Arguments: 896 * char *start : buffer position (must be within PL_linestr) 897 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD) 898 * int check_keyword : if true, Perl checks to make sure the word isn't 899 * a keyword (do this if the word is a label, e.g. goto FOO) 900 * int allow_pack : if true, : characters will also be allowed (require, 901 * use, etc. do this) 902 * int allow_initial_tick : used by the "sub" lexer only. 903 */ 904 905 STATIC char * 906 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick) 907 1085496 { 908 1085496 register char *s; 909 1085496 STRLEN len; 910 911 1085496 start = skipspace(start); 912 1085496 s = start; 913 1085496 if (isIDFIRST_lazy_if(s,UTF) || 914 (allow_pack && *s == ':') || 915 (allow_initial_tick && *s == '\'') ) 916 { 917 1027203 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len); 918 1027203 if (check_keyword && keyword(PL_tokenbuf, len)) 919 35085 return start; 920 992118 if (token == METHOD) { 921 239230 s = skipspace(s); 922 239230 if (*s == '(') 923 192290 PL_expect = XTERM; 924 else { 925 46940 PL_expect = XOPERATOR; 926 } 927 } 928 992118 PL_nextval[PL_nexttoke].opval 929 = (OP*)newSVOP(OP_CONST,0, 930 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len)); 931 992118 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE; 932 992118 force_next(token); 933 } 934 1050411 return s; 935 } 936 937 /* 938 * S_force_ident 939 * Called when the lexer wants $foo *foo &foo etc, but the program 940 * text only contains the "foo" portion. The first argument is a pointer 941 * to the "foo", and the second argument is the type symbol to prefix. 942 * Forces the next token to be a "WORD". 943 * Creates the symbol if it didn't already exist (via gv_fetchpv()). 944 */ 945 946 STATIC void 947 S_force_ident(pTHX_ register const char *s, int kind) 948 133573 { 949 133573 if (s && *s) { 950 107587 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0)); 951 107587 PL_nextval[PL_nexttoke].opval = o; 952 107587 force_next(WORD); 953 107587 if (kind) { 954 107587 o->op_private = OPpCONST_ENTERED; 955 /* XXX see note in pp_entereval() for why we forgo typo 956 warnings if the symbol must be introduced in an eval. 957 GSAR 96-10-12 */ 958 107587 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE, 959 kind == '$' ? SVt_PV : 960 kind == '@' ? SVt_PVAV : 961 kind == '%' ? SVt_PVHV : 962 SVt_PVGV 963 ); 964 } 965 } 966 } 967 968 NV 969 Perl_str_to_version(pTHX_ SV *sv) 970 26 { 971 26 NV retval = 0.0; 972 26 NV nshift = 1.0; 973 26 STRLEN len; 974 26 const char *start = SvPV_const(sv,len); 975 26 const char * const end = start + len; 976 26 const bool utf = SvUTF8(sv) ? TRUE : FALSE; 977 97 while (start < end) { 978 71 STRLEN skip; 979 71 UV n; 980 71 if (utf) 981 18 n = utf8n_to_uvchr((U8*)start, len, &skip, 0); 982 else { 983 53 n = *(U8*)start; 984 53 skip = 1; 985 } 986 71 retval += ((NV)n)/nshift; 987 71 start += skip; 988 71 nshift *= 1000; 989 } 990 26 return retval; 991 } 992 993 /* 994 * S_force_version 995 * Forces the next token to be a version number. 996 * If the next token appears to be an invalid version number, (e.g. "v2b"), 997 * and if "guessing" is TRUE, then no new token is created (and the caller 998 * must use an alternative parsing method). 999 */ 1000 1001 STATIC char * 1002 S_force_version(pTHX_ char *s, int guessing) 1003 75705 { 1004 75705 OP *version = Nullop; 1005 75705 char *d; 1006 1007 75705 s = skipspace(s); 1008 1009 75705 d = s; 1010 75705 if (*d == 'v') 1011 14 d++; 1012 75705 if (isDIGIT(*d)) { 1013 71102 while (isDIGIT(*d) || *d == '_' || *d == '.') 1014 60316 d++; 1015 10786 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) { 1016 10776 SV *ver; 1017 10776 s = scan_num(s, &yylval); 1018 10776 version = yylval.opval; 1019 10776 ver = cSVOPx(version)->op_sv; 1020 10776 if (SvPOK(ver) && !SvNIOK(ver)) { 1021 26 SvUPGRADE(ver, SVt_PVNV); 1022 26 SvNV_set(ver, str_to_version(ver)); 1023 26 SvNOK_on(ver); /* hint that it is a version */ 1024 } 1025 } 1026 10 else if (guessing) 1027 ###### return s; 1028 } 1029 1030 /* NOTE: The parser sees the package name and the VERSION swapped */ 1031 75705 PL_nextval[PL_nexttoke].opval = version; 1032 75705 force_next(WORD); 1033 1034 75705 return s; 1035 } 1036 1037 /* 1038 * S_tokeq 1039 * Tokenize a quoted string passed in as an SV. It finds the next 1040 * chunk, up to end of string or a backslash. It may make a new 1041 * SV containing that chunk (if HINT_NEW_STRING is on). It also 1042 * turns \\ into \. 1043 */ 1044 1045 STATIC SV * 1046 S_tokeq(pTHX_ SV *sv) 1047 1594633 { 1048 1594633 register char *s; 1049 1594633 register char *send; 1050 1594633 register char *d; 1051 1594633 STRLEN len = 0; 1052 1594633 SV *pv = sv; 1053 1054 1594633 if (!SvLEN(sv)) 1055 ###### goto finish; 1056 1057 1594633 s = SvPV_force(sv, len); 1058 1594633 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) 1059 15481 goto finish; 1060 1579152 send = s + len; 1061 13635448 while (s < send && *s != '\\') 1062 12056296 s++; 1063 1579152 if (s == send) 1064 1569368 goto finish; 1065 9784 d = s; 1066 9784 if ( PL_hints & HINT_NEW_STRING ) { 1067 2 pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len)); 1068 2 if (SvUTF8(sv)) 1069 ###### SvUTF8_on(pv); 1070 } 1071 382219 while (s < send) { 1072 372435 if (*s == '\\') { 1073 20282 if (s + 1 < send && (s[1] == '\\')) 1074 5107 s++; /* all that, just for this */ 1075 } 1076 372435 *d++ = *s++; 1077 } 1078 9784 *d = '\0'; 1079 9784 SvCUR_set(sv, d - SvPVX_const(sv)); 1080 finish: 1081 1594633 if ( PL_hints & HINT_NEW_STRING ) 1082 6 return new_constant(NULL, 0, "q", sv, pv, "q"); 1083 1594627 return sv; 1084 } 1085 1086 /* 1087 * Now come three functions related to double-quote context, 1088 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when 1089 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They 1090 * interact with PL_lex_state, and create fake ( ... ) argument lists 1091 * to handle functions and concatenation. 1092 * They assume that whoever calls them will be setting up a fake 1093 * join call, because each subthing puts a ',' after it. This lets 1094 * "lower \luPpEr" 1095 * become 1096 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,) 1097 * 1098 * (I'm not sure whether the spurious commas at the end of lcfirst's 1099 * arguments and join's arguments are created or not). 1100 */ 1101 1102 /* 1103 * S_sublex_start 1104 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST). 1105 * 1106 * Pattern matching will set PL_lex_op to the pattern-matching op to 1107 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise). 1108 * 1109 * OP_CONST and OP_READLINE are easy--just make the new op and return. 1110 * 1111 * Everything else becomes a FUNC. 1112 * 1113 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we 1114 * had an OP_CONST or OP_READLINE). This just sets us up for a 1115 * call to S_sublex_push(). 1116 */ 1117 1118 STATIC I32 1119 S_sublex_start(pTHX) 1120 2033243 { 1121 2033243 const register I32 op_type = yylval.ival; 1122 1123 2033243 if (op_type == OP_NULL) { 1124 6668 yylval.opval = PL_lex_op; 1125 6668 PL_lex_op = Nullop; 1126 6668 return THING; 1127 } 1128 2026575 if (op_type == OP_CONST || op_type == OP_READLINE) { 1129 1230534 SV *sv = tokeq(PL_lex_stuff); 1130 1131 1230534 if (SvTYPE(sv) == SVt_PVIV) { 1132 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */ 1133 1230531 STRLEN len; 1134 1230531 const char *p = SvPV_const(sv, len); 1135 1230531 SV * const nsv = newSVpvn(p, len); 1136 1230531 if (SvUTF8(sv)) 1137 139 SvUTF8_on(nsv); 1138 1230531 SvREFCNT_dec(sv); 1139 1230531 sv = nsv; 1140 } 1141 1230534 yylval.opval = (OP*)newSVOP(op_type, 0, sv); 1142 1230534 PL_lex_stuff = Nullsv; 1143 /* Allow // "foo" */ 1144 1230534 if (op_type == OP_READLINE) 1145 ###### PL_expect = XTERMORDORDOR; 1146 1230534 return THING; 1147 } 1148 1149 796041 PL_sublex_info.super_state = PL_lex_state; 1150 796041 PL_sublex_info.sub_inwhat = op_type; 1151 796041 PL_sublex_info.sub_op = PL_lex_op; 1152 796041 PL_lex_state = LEX_INTERPPUSH; 1153 1154 796041 PL_expect = XTERM; 1155 796041 if (PL_lex_op) { 1156 227077 yylval.opval = PL_lex_op; 1157 227077 PL_lex_op = Nullop; 1158 227077 return PMFUNC; 1159 } 1160 else 1161 568964 return FUNC; 1162 } 1163 1164 /* 1165 * S_sublex_push 1166 * Create a new scope to save the lexing state. The scope will be 1167 * ended in S_sublex_done. Returns a '(', starting the function arguments 1168 * to the uc, lc, etc. found before. 1169 * Sets PL_lex_state to LEX_INTERPCONCAT. 1170 */ 1171 1172 STATIC I32 1173 S_sublex_push(pTHX) 1174 796041 { 1175 dVAR; 1176 796041 ENTER; 1177 1178 796041 PL_lex_state = PL_sublex_info.super_state; 1179 796041 SAVEI32(PL_lex_dojoin); 1180 796041 SAVEI32(PL_lex_brackets); 1181 796041 SAVEI32(PL_lex_casemods); 1182 796041 SAVEI32(PL_lex_starts); 1183 796041 SAVEI32(PL_lex_state); 1184 796041 SAVEVPTR(PL_lex_inpat); 1185 796041 SAVEI32(PL_lex_inwhat); 1186 796041 SAVECOPLINE(PL_curcop); 1187 796041 SAVEPPTR(PL_bufptr); 1188 796041 SAVEPPTR(PL_bufend); 1189 796041 SAVEPPTR(PL_oldbufptr); 1190 796041 SAVEPPTR(PL_oldoldbufptr); 1191 796041 SAVEPPTR(PL_last_lop); 1192 796041 SAVEPPTR(PL_last_uni); 1193 796041 SAVEPPTR(PL_linestart); 1194 796041 SAVESPTR(PL_linestr); 1195 796041 SAVEGENERICPV(PL_lex_brackstack); 1196 796041 SAVEGENERICPV(PL_lex_casestack); 1197 1198 796041 PL_linestr = PL_lex_stuff; 1199 796041 PL_lex_stuff = Nullsv; 1200 1201 796041 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart 1202 = SvPVX(PL_linestr); 1203 796041 PL_bufend += SvCUR(PL_linestr); 1204 796041 PL_last_lop = PL_last_uni = Nullch; 1205 796041 SAVEFREESV(PL_linestr); 1206 1207 796041 PL_lex_dojoin = FALSE; 1208 796041 PL_lex_brackets = 0; 1209 796041 New(899, PL_lex_brackstack, 120, char); 1210 796041 New(899, PL_lex_casestack, 12, char); 1211 796041 PL_lex_casemods = 0; 1212 796041 *PL_lex_casestack = '\0'; 1213 796041 PL_lex_starts = 0; 1214 796041 PL_lex_state = LEX_INTERPCONCAT; 1215 796041 CopLINE_set(PL_curcop, (line_t)PL_multi_start); 1216 1217 796041 PL_lex_inwhat = PL_sublex_info.sub_inwhat; 1218 796041 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST) 1219 220635 PL_lex_inpat = PL_sublex_info.sub_op; 1220 else 1221 575406 PL_lex_inpat = Nullop; 1222 1223 796041 return '('; 1224 } 1225 1226 /* 1227 * S_sublex_done 1228 * Restores lexer state after a S_sublex_push. 1229 */ 1230 1231 STATIC I32 1232 S_sublex_done(pTHX) 1233 916316 { 1234 dVAR; 1235 916316 if (!PL_lex_starts++) { 1236 36076 SV * const sv = newSVpvn("",0); 1237 36076 if (SvUTF8(PL_linestr)) 1238 1 SvUTF8_on(sv); 1239 36076 PL_expect = XOPERATOR; 1240 36076 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); 1241 36076 return THING; 1242 } 1243 1244 880240 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */ 1245 576 PL_lex_state = LEX_INTERPCASEMOD; 1246 576 return yylex(); 1247 } 1248 1249 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */ 1250 879664 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) { 1251 83629 PL_linestr = PL_lex_repl; 1252 83629 PL_lex_inpat = 0; 1253 83629 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); 1254 83629 PL_bufend += SvCUR(PL_linestr); 1255 83629 PL_last_lop = PL_last_uni = Nullch; 1256 83629 SAVEFREESV(PL_linestr); 1257 83629 PL_lex_dojoin = FALSE; 1258 83629 PL_lex_brackets = 0; 1259 83629 PL_lex_casemods = 0; 1260 83629 *PL_lex_casestack = '\0'; 1261 83629 PL_lex_starts = 0; 1262 83629 if (SvEVALED(PL_lex_repl)) { 1263 4461 PL_lex_state = LEX_INTERPNORMAL; 1264 4461 PL_lex_starts++; 1265 /* we don't clear PL_lex_repl here, so that we can check later 1266 whether this is an evalled subst; that means we rely on the 1267 logic to ensure sublex_done() is called again only via the 1268 branch (in yylex()) that clears PL_lex_repl, else we'll loop */ 1269 } 1270 else { 1271 79168 PL_lex_state = LEX_INTERPCONCAT; 1272 79168 PL_lex_repl = Nullsv; 1273 } 1274 83629 return ','; 1275 } 1276 else { 1277 796035 LEAVE; 1278 796035 PL_bufend = SvPVX(PL_linestr); 1279 796035 PL_bufend += SvCUR(PL_linestr); 1280 796035 PL_expect = XOPERATOR; 1281 796035 PL_sublex_info.sub_inwhat = 0; 1282 796035 return ')'; 1283 } 1284 } 1285 1286 /* 1287 scan_const 1288 1289 Extracts a pattern, double-quoted string, or transliteration. This 1290 is terrifying code. 1291 1292 It looks at lex_inwhat and PL_lex_inpat to find out whether it's 1293 processing a pattern (PL_lex_inpat is true), a transliteration 1294 (lex_inwhat & OP_TRANS is true), or a double-quoted string. 1295 1296 Returns a pointer to the character scanned up to. Iff this is 1297 advanced from the start pointer supplied (ie if anything was 1298 successfully parsed), will leave an OP for the substring scanned 1299 in yylval. Caller must intuit reason for not parsing further 1300 by looking at the next characters herself. 1301 1302 In patterns: 1303 backslashes: 1304 double-quoted style: \r and \n 1305 regexp special ones: \D \s 1306 constants: \x3 1307 backrefs: \1 (deprecated in substitution replacements) 1308 case and quoting: \U \Q \E 1309 stops on @ and $, but not for $ as tail anchor 1310 1311 In transliterations: 1312 characters are VERY literal, except for - not at the start or end 1313 of the string, which indicates a range. scan_const expands the 1314 range to the full set of intermediate characters. 1315 1316 In double-quoted strings: 1317 backslashes: 1318 double-quoted style: \r and \n 1319 constants: \x3 1320 backrefs: \1 (deprecated) 1321 case and quoting: \U \Q \E 1322 stops on @ and $ 1323 1324 scan_const does *not* construct ops to handle interpolated strings. 1325 It stops processing as soon as it finds an embedded $ or @ variable 1326 and leaves it to the caller to work out what's going on. 1327 1328 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo. 1329 1330 $ in pattern could be $foo or could be tail anchor. Assumption: 1331 it's a tail anchor if $ is the last thing in the string, or if it's 1332 followed by one of ")| \n\t" 1333 1334 \1 (backreferences) are turned into $1 1335 1336 The structure of the code is 1337 while (there's a character to process) { 1338 handle transliteration ranges 1339 skip regexp comments 1340 skip # initiated comments in //x patterns 1341 check for embedded @foo 1342 check for embedded scalars 1343 if (backslash) { 1344 leave intact backslashes from leave (below) 1345 deprecate \1 in strings and sub replacements 1346 handle string-changing backslashes \l \U \Q \E, etc. 1347 switch (what was escaped) { 1348 handle - in a transliteration (becomes a literal -) 1349 handle \132 octal characters 1350 handle 0x15 hex characters 1351 handle \cV (control V) 1352 handle printf backslashes (\f, \r, \n, etc) 1353 } (end switch) 1354 } (end if backslash) 1355 } (end while character to read) 1356 1357 */ 1358 1359 STATIC char * 1360 S_scan_const(pTHX_ char *start) 1361 1154591 { 1362 1154591 register char *send = PL_bufend; /* end of the constant */ 1363 1154591 SV *sv = NEWSV(93, send - start); /* sv for the constant */ 1364 1154591 register char *s = start; /* start of the constant */ 1365 1154591 register char *d = SvPVX(sv); /* destination for copies */ 1366 1154591 bool dorange = FALSE; /* are we in a translit range? */ 1367 1154591 bool didrange = FALSE; /* did we just finish a range? */ 1368 1154591 I32 has_utf8 = FALSE; /* Output constant is UTF8 */ 1369 1154591 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */ 1370 1154591 UV uv; 1371 1372 1154591 const char *leaveit = /* set of acceptably-backslashed characters */ 1373 PL_lex_inpat 1374 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#" 1375 1154591 : ""; 1376 1377 1154591 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { 1378 /* If we are doing a trans and we know we want UTF8 set expectation */ 1379 9810 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF); 1380 9810 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF); 1381 } 1382 1383 1384 11676816 while (s < send || dorange) { 1385 /* get transliterations out of the way (they're most literal) */ 1386 10965678 if (PL_lex_inwhat == OP_TRANS) { 1387 /* expand a range A-Z to the full set of characters. AIE! */ 1388 28761 if (dorange) { 1389 4946 I32 i; /* current expanded character */ 1390 4946 I32 min; /* first character in range */ 1391 4946 I32 max; /* last character in range */ 1392 1393 4946 if (has_utf8) { 1394 3 char * const c = (char*)utf8_hop((U8*)d, -1); 1395 3 char *e = d++; 1396 9 while (e-- > c) 1397 6 *(e + 1) = *e; 1398 3 *c = (char)UTF_TO_NATIVE(0xff); 1399 /* mark the range as done, and continue */ 1400 3 dorange = FALSE; 1401 3 didrange = TRUE; 1402 3 continue; 1403 } 1404 1405 4943 i = d - SvPVX_const(sv); /* remember current offset */ 1406 4943 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */ 1407 4943 d = SvPVX(sv) + i; /* refresh d after realloc */ 1408 4943 d -= 2; /* eat the first char and the - */ 1409 1410 4943 min = (U8)*d; /* first char in range */ 1411 4943 max = (U8)d[1]; /* last char in range */ 1412 1413 4943 if (min > max) { 1414 1 Perl_croak(aTHX_ 1415 "Invalid range \"%c-%c\" in transliteration operator", 1416 (char)min, (char)max); 1417 } 1418 1419 #ifdef EBCDIC 1420 if ((isLOWER(min) && isLOWER(max)) || 1421 (isUPPER(min) && isUPPER(max))) { 1422 if (isLOWER(min)) { 1423 for (i = min; i <= max; i++) 1424 if (isLOWER(i)) 1425 *d++ = NATIVE_TO_NEED(has_utf8,i); 1426 } else { 1427 for (i = min; i <= max; i++) 1428 if (isUPPER(i)) 1429 *d++ = NATIVE_TO_NEED(has_utf8,i); 1430 } 1431 } 1432 else 1433 #endif 1434 158217 for (i = min; i <= max; i++) 1435 153275 *d++ = (char)i; 1436 1437 /* mark the range as done, and continue */ 1438 4942 dorange = FALSE; 1439 4942 didrange = TRUE; 1440 4942 continue; 1441 } 1442 1443 /* range begins (ignore - as first or last char) */ 1444 23815 else if (*s == '-' && s+1 < send && s != start) { 1445 4988 if (didrange) { 1446 1 Perl_croak(aTHX_ "Ambiguous range in transliteration operator"); 1447 } 1448 4987 if (has_utf8) { 1449 41 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */ 1450 41 s++; 1451 41 continue; 1452 } 1453 4946 dorange = TRUE; 1454 4946 s++; 1455 } 1456 else { 1457 18827 didrange = FALSE; 1458 } 1459 } 1460 1461 /* if we get here, we're not doing a transliteration */ 1462 1463 /* skip for regexp comments /(?#comment)/ and code /(?{code})/, 1464 except for the last char, which will be done separately. */ 1465 10936917 else if (*s == '(' && PL_lex_inpat && s[1] == '?') { 1466 18789 if (s[2] == '#') { 1467 15 while (s+1 < send && *s != ')') 1468 10 *d++ = NATIVE_TO_NEED(has_utf8,*s++); 1469 } 1470 18784 else if (s[2] == '{' /* This should match regcomp.c */ 1471 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{')) 1472 { 1473 662 I32 count = 1; 1474 662 char *regparse = s + (s[2] == '{' ? 3 : 4); 1475 7200 char c; 1476 1477 7200 while (count && (c = *regparse)) { 1478 6538 if (c == '\\' && regparse[1]) 1479 1 regparse++; 1480 6537 else if (c == '{') 1481 3 count++; 1482 6534 else if (c == '}') 1483 663 count--; 1484 6538 regparse++; 1485 } 1486 662 if (*regparse != ')') 1487 2 regparse--; /* Leave one char for continuation. */ 1488 9755 while (s < regparse) 1489 9093 *d++ = NATIVE_TO_NEED(has_utf8,*s++); 1490 } 1491 } 1492 1493 /* likewise skip #-initiated comments in //x patterns */ 1494 10918128 else if (*s == '#' && PL_lex_inpat && 1495 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) { 1496 42705 while (s+1 < send && *s != '\n') 1497 40939 *d++ = NATIVE_TO_NEED(has_utf8,*s++); 1498 } 1499 1500 /* check for embedded arrays 1501 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-) 1502 */ 1503 10916362 else if (*s == '@' && s[1] 1504 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1]))) 1505 10903538 break; 1506 1507 /* check for embedded scalars. only stop if we're sure it's a 1508 variable. 1509 */ 1510 10903538 else if (*s == '$') { 1511 471072 if (!PL_lex_inpat) /* not a regexp, so $ must be var */ 1512 403487 break; 1513 67585 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) 1514 20956 break; /* in regexp, $ might be tail anchor */ 1515 } 1516 1517 /* End of else if chain - OP_TRANS rejoin rest */ 1518 1519 /* backslashes */ 1520 10523423 if (*s == '\\' && s+1 < send) { 1521 3016662 s++; 1522 1523 /* some backslashes we leave behind */ 1524 3016662 if (*leaveit && *s && strchr(leaveit, *s)) { 1525 188617 *d++ = NATIVE_TO_NEED(has_utf8,'\\'); 1526 188617 *d++ = NATIVE_TO_NEED(has_utf8,*s++); 1527 188617 continue; 1528 } 1529 1530 /* deprecate \1 in strings and substitution replacements */ 1531 2828045 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat && 1532 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) 1533 { 1534 2 if (ckWARN(WARN_SYNTAX)) 1535 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s); 1536 2 *--s = '$'; 1537 2 break; 1538 } 1539 1540 /* string-change backslash escapes */ 1541 2828043 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) { 1542 6180 --s; 1543 6180 break; 1544 } 1545 1546 /* if we get here, it's either a quoted -, or a digit */ 1547 2821863 switch (*s) { 1548 1549 /* quoted - in transliterations */ 1550 case '-': 1551 431 if (PL_lex_inwhat == OP_TRANS) { 1552 130 *d++ = *s++; 1553 130 continue; 1554 } 1555 /* FALL THROUGH */ 1556 default: 1557 { 1558 83044 if (ckWARN(WARN_MISC) && 1559 isALNUM(*s) && 1560 *s != '_') 1561 2 Perl_warner(aTHX_ packWARN(WARN_MISC), 1562 "Unrecognized escape \\%c passed through", 1563 *s); 1564 /* default action is to copy the quoted character */ 1565 2 goto default_action; 1566 } 1567 1568 /* \132 indicates an octal constant */ 1569 case '0': case '1': case '2': case '3': 1570 case '4': case '5': case '6': case '7': 1571 { 1572 30645 I32 flags = 0; 1573 30645 STRLEN len = 3; 1574 30645 uv = grok_oct(s, &len, &flags, NULL); 1575 30645 s += len; 1576 } 1577 30645 goto NUM_ESCAPE_INSERT; 1578 1579 /* \x24 indicates a hex constant */ 1580 case 'x': 1581 2577790 ++s; 1582 2577790 if (*s == '{') { 1583 6113 char* const e = strchr(s, '}'); 1584 6113 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES | 1585 6113 PERL_SCAN_DISALLOW_PREFIX; 1586 6113 STRLEN len; 1587 1588 6113 ++s; 1589 6113 if (!e) { 1590 1 yyerror("Missing right brace on \\x{}"); 1591 1 continue; 1592 } 1593 6112 len = e - s; 1594 6112 uv = grok_hex(s, &len, &flags, NULL); 1595 6112 s = e + 1; 1596 } 1597 else { 1598 { 1599 2571677 STRLEN len = 2; 1600 2571677 I32 flags = PERL_SCAN_DISALLOW_PREFIX; 1601 2571677 uv = grok_hex(s, &len, &flags, NULL); 1602 2571677 s += len; 1603 } 1604 } 1605 1606 NUM_ESCAPE_INSERT: 1607 /* Insert oct or hex escaped character. 1608 * There will always enough room in sv since such 1609 * escapes will be longer than any UTF-8 sequence 1610 * they can end up as. */ 1611 1612 /* We need to map to chars to ASCII before doing the tests 1613 to cover EBCDIC 1614 */ 1615 2608435 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) { 1616 76594 if (!has_utf8 && uv > 255) { 1617 /* Might need to recode whatever we have 1618 * accumulated so far if it contains any 1619 * hibit chars. 1620 * 1621 * (Can't we keep track of that and avoid 1622 * this rescan? --jhi) 1623 */ 1624 3248 int hicount = 0; 1625 3248 U8 *c; 1626 6116 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) { 1627 2868 if (!NATIVE_IS_INVARIANT(*c)) { 1628 325 hicount++; 1629 } 1630 } 1631 3248 if (hicount) { 1632 46 const STRLEN offset = d - SvPVX_const(sv); 1633 46 U8 *src, *dst; 1634 46 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset; 1635 46 src = (U8 *)d - 1; 1636 46 dst = src+hicount; 1637 46 d += hicount; 1638 651 while (src >= (const U8 *)SvPVX_const(sv)) { 1639 605 if (!NATIVE_IS_INVARIANT(*src)) { 1640 325 const U8 ch = NATIVE_TO_ASCII(*src); 1641 325 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch); 1642 325 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch); 1643 } 1644 else { 1645 280 *dst-- = *src; 1646 } 1647 605 src--; 1648 } 1649 } 1650 } 1651 1652 76594 if (has_utf8 || uv > 255) { 1653 5557 d = (char*)uvchr_to_utf8((U8*)d, uv); 1654 5557 has_utf8 = TRUE; 1655 5557 if (PL_lex_inwhat == OP_TRANS && 1656 PL_sublex_info.sub_op) { 1657 53 PL_sublex_info.sub_op->op_private |= 1658 (PL_lex_repl ? OPpTRANS_FROM_UTF 1659 : OPpTRANS_TO_UTF); 1660 } 1661 } 1662 else { 1663 71037 *d++ = (char)uv; 1664 } 1665 } 1666 else { 1667 2531841 *d++ = (char) uv; 1668 } 1669 2531841 continue; 1670 1671 /* \N{LATIN SMALL LETTER A} is a named character */ 1672 case 'N': 1673 156 ++s; 1674 156 if (*s == '{') { 1675 156 char* e = strchr(s, '}'); 1676 156 SV *res; 1677 156 STRLEN len; 1678 156 const char *str; 1679 1680 156 if (!e) { 1681 ###### yyerror("Missing right brace on \\N{}"); 1682 ###### e = s - 1; 1683 ###### goto cont_scan; 1684 } 1685 156 if (e > s + 2 && s[1] == 'U' && s[2] == '+') { 1686 /* \N{U+...} */ 1687 1 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES | 1688 1 PERL_SCAN_DISALLOW_PREFIX; 1689 1 s += 3; 1690 1 len = e - s; 1691 1 uv = grok_hex(s, &len, &flags, NULL); 1692 1 s = e + 1; 1693 1 goto NUM_ESCAPE_INSERT; 1694 } 1695 155 res = newSVpvn(s + 1, e - s - 1); 1696 155 res = new_constant( Nullch, 0, "charnames", 1697 res, Nullsv, "\\N{...}" ); 1698 153 if (has_utf8) 1699 21 sv_utf8_upgrade(res); 1700 153 str = SvPV_const(res,len); 1701 #ifdef EBCDIC_NEVER_MIND 1702 /* charnames uses pack U and that has been 1703 * recently changed to do the below uni->native 1704 * mapping, so this would be redundant (and wrong, 1705 * the code point would be doubly converted). 1706 * But leave this in just in case the pack U change 1707 * gets revoked, but the semantics is still 1708 * desireable for charnames. --jhi */ 1709 { 1710 UV uv = utf8_to_uvchr((const U8*)str, 0); 1711 1712 if (uv < 0x100) { 1713 U8 tmpbuf[UTF8_MAXBYTES+1], *d; 1714 1715 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv)); 1716 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf); 1717 str = SvPV_const(res, len); 1718 } 1719 } 1720 #endif 1721 153 if (!has_utf8 && SvUTF8(res)) { 1722 132 const char * const ostart = SvPVX_const(sv); 1723 132 SvCUR_set(sv, d - ostart); 1724 132 SvPOK_on(sv); 1725 132 *d = '\0'; 1726 132 sv_utf8_upgrade(sv); 1727 /* this just broke our allocation above... */ 1728 132 SvGROW(sv, (STRLEN)(send - start)); 1729 132 d = SvPVX(sv) + SvCUR(sv); 1730 132 has_utf8 = TRUE; 1731 } 1732 153 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */ 1733 ###### const char * const odest = SvPVX_const(sv); 1734 1735 ###### SvGROW(sv, (SvLEN(sv) + len - (e - s + 4))); 1736 ###### d = SvPVX(sv) + (d - odest); 1737 } 1738 153 Copy(str, d, len, char); 1739 153 d += len; 1740 153 SvREFCNT_dec(res); 1741 cont_scan: 1742 153 s = e + 1; 1743 } 1744 else 1745 ###### yyerror("Missing braces on \\N{}"); 1746 ###### continue; 1747 1748 /* \c is a control character */ 1749 case 'c': 1750 3663 s++; 1751 3663 if (s < send) { 1752 3662 U8 c = *s++; 1753 #ifdef EBCDIC 1754 if (isLOWER(c)) 1755 c = toUPPER(c); 1756 #endif 1757 3662 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c)); 1758 } 1759 else { 1760 1 yyerror("Missing control char name in \\c"); 1761 } 1762 1 continue; 1763 1764 /* printf-style backslashes, formfeeds, newlines, etc */ 1765 case 'b': 1766 121 *d++ = NATIVE_TO_NEED(has_utf8,'\b'); 1767 121 break; 1768 case 'n': 1769 112999 *d++ = NATIVE_TO_NEED(has_utf8,'\n'); 1770 112999 break; 1771 case 'r': 1772 490 *d++ = NATIVE_TO_NEED(has_utf8,'\r'); 1773 490 break; 1774 case 'f': 1775 219 *d++ = NATIVE_TO_NEED(has_utf8,'\f'); 1776 219 break; 1777 case 't': 1778 11444 *d++ = NATIVE_TO_NEED(has_utf8,'\t'); 1779 11444 break; 1780 case 'e': 1781 316 *d++ = ASCII_TO_NEED(has_utf8,'\033'); 1782 316 break; 1783 case 'a': 1784 846 *d++ = ASCII_TO_NEED(has_utf8,'\007'); 1785 126435 break; 1786 } /* end switch */ 1787 1788 126435 s++; 1789 126435 continue; 1790 } /* end if (backslash) */ 1791 1792 default_action: 1793 /* If we started with encoded form, or already know we want it 1794 and then encode the next character */ 1795 7589805 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) { 1796 298 STRLEN len = 1; 1797 298 const UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s); 1798 298 const STRLEN need = UNISKIP(NATIVE_TO_UNI(uv)); 1799 298 s += len; 1800 298 if (need > len) { 1801 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */ 1802 2 const STRLEN off = d - SvPVX_const(sv); 1803 2 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off; 1804 } 1805 298 d = (char*)uvchr_to_utf8((U8*)d, uv); 1806 298 has_utf8 = TRUE; 1807 } 1808 else { 1809 7589507 *d++ = NATIVE_TO_NEED(has_utf8,*s++); 1810 } 1811 } /* while loop to process each character */ 1812 1813 /* terminate the string and set up the sv */ 1814 1154587 *d = '\0'; 1815 1154587 SvCUR_set(sv, d - SvPVX_const(sv)); 1816 1154587 if (SvCUR(sv) >= SvLEN(sv)) 1817 ###### Perl_croak(aTHX_ "panic: constant overflowed allocated space"); 1818 1819 1154587 SvPOK_on(sv); 1820 1154587 if (PL_encoding && !has_utf8) { 1821 136 sv_recode_to_utf8(sv, PL_encoding); 1822 136 if (SvUTF8(sv)) 1823 136 has_utf8 = TRUE; 1824 } 1825 1154587 if (has_utf8) { 1826 3657 SvUTF8_on(sv); 1827 3657 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { 1828 85 PL_sublex_info.sub_op->op_private |= 1829 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF); 1830 } 1831 } 1832 1833 /* shrink the sv if we allocated more than we used */ 1834 1154587 if (SvCUR(sv) + 5 < SvLEN(sv)) { 1835 641927 SvPV_shrink_to_cur(sv); 1836 } 1837 1838 /* return the substring (via yylval) only if we parsed anything */ 1839 1154587 if (s > PL_bufptr) { 1840 1022593 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) 1841 13 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"), 1842 sv, Nullsv, 1843 ( PL_lex_inwhat == OP_TRANS 1844 ? "tr" 1845 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) 1846 ? "s" 1847 : "qq"))); 1848 1022593 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); 1849 } else 1850 131994 SvREFCNT_dec(sv); 1851 1154587 return s; 1852 } 1853 1854 /* S_intuit_more 1855 * Returns TRUE if there's more to the expression (e.g., a subscript), 1856 * FALSE otherwise. 1857 * 1858 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/ 1859 * 1860 * ->[ and ->{ return TRUE 1861 * { and [ outside a pattern are always subscripts, so return TRUE 1862 * if we're outside a pattern and it's not { or [, then return FALSE 1863 * if we're in a pattern and the first char is a { 1864 * {4,5} (any digits around the comma) returns FALSE 1865 * if we're in a pattern and the first char is a [ 1866 * [] returns FALSE 1867 * [SOMETHING] has a funky algorithm to decide whether it's a 1868 * character class or not. It has to deal with things like 1869 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/ 1870 * anything else returns TRUE 1871 */ 1872 1873 /* This is the one truly awful dwimmer necessary to conflate C and sed. */ 1874 1875 STATIC int 1876 S_intuit_more(pTHX_ register char *s) 1877 5339601 { 1878 5339601 if (PL_lex_brackets) 1879 4128734 return TRUE; 1880 1210867 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{')) 1881 25100 return TRUE; 1882 1185767 if (*s != '{' && *s != '[') 1883 1118904 return FALSE; 1884 66863 if (!PL_lex_inpat) 1885 65371 return TRUE; 1886 1887 /* In a pattern, so maybe we have {n,m}. */ 1888 1492 if (*s == '{') { 1889 1144 s++; 1890 1144 if (!isDIGIT(*s)) 1891 1144 return TRUE; 1892 ###### while (isDIGIT(*s)) 1893 ###### s++; 1894 ###### if (*s == ',') 1895 ###### s++; 1896 ###### while (isDIGIT(*s)) 1897 ###### s++; 1898 ###### if (*s == '}') 1899 ###### return FALSE; 1900 ###### return TRUE; 1901 1902 } 1903 1904 /* On the other hand, maybe we have a character class */ 1905 1906 348 s++; 1907 348 if (*s == ']' || *s == '^') 1908 32 return FALSE; 1909 else { 1910 /* this is terrifying, and it works */ 1911 316 int weight = 2; /* let's weigh the evidence */ 1912 316 char seen[256]; 1913 316 unsigned char un_char = 255, last_un_char; 1914 316 const char * const send = strchr(s,']'); 1915 316 char tmpbuf[sizeof PL_tokenbuf * 4]; 1916 1917 316 if (!send) /* has to be an expression */ 1918 ###### return TRUE; 1919 1920 316 Zero(seen,256,char); 1921 316 if (*s == '$') 1922 4 weight -= 3; 1923 312 else if (isDIGIT(*s)) { 1924 304 if (s[1] != ']') { 1925 ###### if (isDIGIT(s[1]) && s[2] == ']') 1926 ###### weight -= 10; 1927 } 1928 else 1929 304 weight -= 100; 1930 } 1931 984 for (; s < send; s++) { 1932 334 last_un_char = un_char; 1933 334 un_char = (unsigned char)*s; 1934 334 switch (*s) { 1935 case '@': 1936 case '&': 1937 case '$': 1938 4 weight -= seen[un_char] * 10; 1939 4 if (isALNUM_lazy_if(s+1,UTF)) { 1940 4 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE); 1941 4 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV)) 1942 ###### weight -= 100; 1943 else 1944 4 weight -= 10; 1945 } 1946 ###### else if (*s == '$' && s[1] && 1947 strchr("[#!%*<>()-=",s[1])) { 1948 ###### if (/*{*/ strchr("])} =",s[2])) 1949 ###### weight -= 10; 1950 else 1951 ###### weight -= 1; 1952 } 1953 ###### break; 1954 case '\\': 1955 2 un_char = 254; 1956 2 if (s[1]) { 1957 2 if (strchr("wds]",s[1])) 1958 2 weight += 100; 1959 ###### else if (seen['\''] || seen['"']) 1960 ###### weight += 1; 1961 ###### else if (strchr("rnftbxcav",s[1])) 1962 ###### weight += 40; 1963 ###### else if (isDIGIT(s[1])) { 1964 ###### weight += 40; 1965 ###### while (s[1] && isDIGIT(s[1])) 1966 ###### s++; 1967 } 1968 } 1969 else 1970 ###### weight += 100; 1971 ###### break; 1972 case '-': 1973 6 if (s[1] == '\\') 1974 ###### weight += 50; 1975 6 if (strchr("aA01! ",last_un_char)) 1976 2 weight += 30; 1977 6 if (strchr("zZ79~",s[1])) 1978 2 weight += 30; 1979 6 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$')) 1980 4 weight -= 5; /* cope with negative subscript */ 1981 4 break; 1982 default: 1983 322 if (!isALNUM(last_un_char) 1984 && !(last_un_char == '$' || last_un_char == '@' 1985 || last_un_char == '&') 1986 && isALPHA(*s) && s[1] && isALPHA(s[1])) { 1987 ###### char *d = tmpbuf; 1988 ###### while (isALPHA(*s)) 1989 ###### *d++ = *s++; 1990 ###### *d = '\0'; 1991 ###### if (keyword(tmpbuf, d - tmpbuf)) 1992 ###### weight -= 150; 1993 } 1994 322 if (un_char == last_un_char + 1) 1995 ###### weight += 5; 1996 322 weight -= seen[un_char]; 1997 334 break; 1998 } 1999 334 seen[un_char]++; 2000 } 2001 316 if (weight >= 0) /* probably a character class */ 2002 6 return FALSE; 2003 } 2004 2005 310 return TRUE; 2006 } 2007 2008 /* 2009 * S_intuit_method 2010 * 2011 * Does all the checking to disambiguate 2012 * foo bar 2013 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise 2014 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args). 2015 * 2016 * First argument is the stuff after the first token, e.g. "bar". 2017 * 2018 * Not a method if bar is a filehandle. 2019 * Not a method if foo is a subroutine prototyped to take a filehandle. 2020 * Not a method if it's really "Foo $bar" 2021 * Method if it's "foo $bar" 2022 * Not a method if it's really "print foo $bar" 2023 * Method if it's really "foo package::" (interpreted as package->foo) 2024 * Not a method if bar is known to be a subroutine ("sub bar; foo bar") 2025 * Not a method if bar is a filehandle or package, but is quoted with 2026 * => 2027 */ 2028 2029 STATIC int 2030 S_intuit_method(pTHX_ char *start, GV *gv) 2031 24016 { 2032 24016 char *s = start + (*start == '$'); 2033 24016 char tmpbuf[sizeof PL_tokenbuf]; 2034 24016 STRLEN len; 2035 24016 GV* indirgv; 2036 2037 24016 if (gv) { 2038 19523 CV *cv; 2039 19523 if (GvIO(gv)) 2040 2526 return 0; 2041 16997 if ((cv = GvCVu(gv))) { 2042 16798 const char *proto = SvPVX_const(cv); 2043 16798 if (proto) { 2044 2377 if (*proto == ';') 2045 6 proto++; 2046 2377 if (*proto == '*') 2047 5 return 0; 2048 } 2049 } else 2050 199 gv = 0; 2051 } 2052 21485 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); 2053 /* start is the beginning of the possible filehandle/object, 2054 * and s is the end of it 2055 * tmpbuf is a copy of it 2056 */ 2057 2058 21485 if (*start == '$') { 2059 10318 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf)) 2060 10318 return 0; 2061 ###### s = skipspace(s); 2062 ###### PL_bufptr = start; 2063 ###### PL_expect = XREF; 2064 ###### return *s == '(' ? FUNCMETH : METHOD; 2065 } 2066 11167 if (!keyword(tmpbuf, len)) { 2067 7977 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') { 2068 2 len -= 2; 2069 2 tmpbuf[len] = '\0'; 2070 2 goto bare_package; 2071 } 2072 7975 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV); 2073 7975 if (indirgv && GvCVu(indirgv)) 2074 251 return 0; 2075 /* filehandle or package name makes it a method */ 2076 7724 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) { 2077 5388 s = skipspace(s); 2078 5388 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>') 2079 ###### return 0; /* no assumptions -- "=>" quotes bearword */ 2080 bare_package: 2081 5390 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, 2082 newSVpvn(tmpbuf,len)); 2083 5390 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE; 2084 5390 PL_expect = XTERM; 2085 5390 force_next(WORD); 2086 5390 PL_bufptr = s; 2087 5390 return *s == '(' ? FUNCMETH : METHOD; 2088 } 2089 } 2090 5526 return 0; 2091 } 2092 2093 /* 2094 * S_incl_perldb 2095 * Return a string of Perl code to load the debugger. If PERL5DB 2096 * is set, it will return the contents of that, otherwise a 2097 * compile-time require of perl5db.pl. 2098 */ 2099 2100 STATIC const char* 2101 S_incl_perldb(pTHX) 2102 4506 { 2103 4506 if (PL_perldb) { 2104 9 const char * const pdb = PerlEnv_getenv("PERL5DB"); 2105 2106 9 if (pdb) 2107 9 return pdb; 2108 ###### SETERRNO(0,SS_NORMAL); 2109 ###### return "BEGIN { require 'perl5db.pl' }"; 2110 } 2111 4497 return ""; 2112 } 2113 2114 2115 /* Encoded script support. filter_add() effectively inserts a 2116 * 'pre-processing' function into the current source input stream. 2117 * Note that the filter function only applies to the current source file 2118 * (e.g., it will not affect files 'require'd or 'use'd by this one). 2119 * 2120 * The datasv parameter (which may be NULL) can be used to pass 2121 * private data to this instance of the filter. The filter function 2122 * can recover the SV using the FILTER_DATA macro and use it to 2123 * store private buffers and state information. 2124 * 2125 * The supplied datasv parameter is upgraded to a PVIO type 2126 * and the IoDIRP/IoANY field is used to store the function pointer, 2127 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such. 2128 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for 2129 * private use must be set using malloc'd pointers. 2130 */ 2131 2132 SV * 2133 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) 2134 2094 { 2135 2094 if (!funcp) 2136 ###### return Nullsv; 2137 2138 2094 if (!PL_rsfp_filters) 2139 2090 PL_rsfp_filters = newAV(); 2140 2094 if (!datasv) 2141 2048 datasv = NEWSV(255,0); 2142 2094 SvUPGRADE(datasv, SVt_PVIO); 2143 2094 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */ 2144 2094 IoFLAGS(datasv) |= IOf_FAKE_DIRP; 2145 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n", 2146 2094 IoANY(datasv), SvPV_nolen(datasv))); 2147 2094 av_unshift(PL_rsfp_filters, 1); 2148 2094 av_store(PL_rsfp_filters, 0, datasv) ; 2149 2094 return(datasv); 2150 } 2151 2152 2153 /* Delete most recently added instance of this filter function. */ 2154 void 2155 Perl_filter_del(pTHX_ filter_t funcp) 2156 2073 { 2157 2073 SV *datasv; 2158 2159 #ifdef DEBUGGING 2160 2073 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp))); 2161 #endif 2162 2073 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0) 2163 2073 return; 2164 /* if filter is on top of stack (usual case) just pop it off */ 2165 2073 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters)); 2166 2073 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) { 2167 2073 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP; 2168 2073 IoANY(datasv) = (void *)NULL; 2169 2073 sv_free(av_pop(PL_rsfp_filters)); 2170 2171 2073 return; 2172 } 2173 /* we need to search for the correct entry and clear it */ 2174 ###### Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)"); 2175 } 2176 2177 2178 /* Invoke the idxth filter function for the current rsfp. */ 2179 /* maxlen 0 = read one text line */ 2180 I32 2181 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) 2182 5145 { 2183 5145 filter_t funcp; 2184 5145 SV *datasv = NULL; 2185 2186 5145 if (!PL_rsfp_filters) 2187 ###### return -1; 2188 5145 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */ 2189 /* Provide a default input filter to make life easy. */ 2190 /* Note that we append to the line. This is handy. */ 2191 DEBUG_P(PerlIO_printf(Perl_debug_log, 2192 229 "filter_read %d: from rsfp\n", idx)); 2193 229 if (maxlen) { 2194 /* Want a block */ 2195 39 int len ; 2196 39 const int old_len = SvCUR(buf_sv); 2197 2198 /* ensure buf_sv is large enough */ 2199 39 SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ; 2200 39 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){ 2201 6 if (PerlIO_error(PL_rsfp)) 2202 ###### return -1; /* error */ 2203 else 2204 6 return 0 ; /* end of file */ 2205 } 2206 33 SvCUR_set(buf_sv, old_len + len) ; 2207 } else { 2208 /* Want a line */ 2209 190 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) { 2210 31 if (PerlIO_error(PL_rsfp)) 2211 ###### return -1; /* error */ 2212 else 2213 31 return 0 ; /* end of file */ 2214 } 2215 } 2216 192 return SvCUR(buf_sv); 2217 } 2218 /* Skip this filter slot if filter has been deleted */ 2219 4916 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) { 2220 DEBUG_P(PerlIO_printf(Perl_debug_log, 2221 "filter_read %d: skipped (filter deleted)\n", 2222 ###### idx)); 2223 ###### return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */ 2224 } 2225 /* Get function pointer hidden within datasv */ 2226 4916 funcp = DPTR2FPTR(filter_t, IoANY(datasv)); 2227 DEBUG_P(PerlIO_printf(Perl_debug_log, 2228 "filter_read %d: via function %p (%s)\n", 2229 4916 idx, datasv, SvPV_nolen_const(datasv))); 2230 /* Call function. The function is expected to */ 2231 /* call "FILTER_READ(idx+1, buf_sv)" first. */ 2232 /* Return: <0:error, =0:eof, >0:not eof */ 2233 4916 return (*funcp)(aTHX_ idx, buf_sv, maxlen); 2234 } 2235 2236 STATIC char * 2237 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) 2238 10229110 { 2239 #ifdef PERL_CR_FILTER 2240 if (!PL_rsfp_filters) { 2241 filter_add(S_cr_textfilter,NULL); 2242 } 2243 #endif 2244 10229110 if (PL_rsfp_filters) { 2245 4891 if (!append) 2246 3169 SvCUR_set(sv, 0); /* start with empty line */ 2247 4891 if (FILTER_READ(0, sv, 0) > 0) 2248 2806 return ( SvPVX(sv) ) ; 2249 else 2250 2084 return Nullch ; 2251 } 2252 else 2253 10224219 return (sv_gets(sv, fp, append)); 2254 } 2255 2256 STATIC HV * 2257 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) 2258 30 { 2259 30 GV *gv; 2260 2261 30 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__")) 2262 1 return PL_curstash; 2263 2264 29 if (len > 2 && 2265 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') && 2266 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV))) 2267 { 2268 1 return GvHV(gv); /* Foo:: */ 2269 } 2270 2271 /* use constant CLASS => 'MyClass' */ 2272 28 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) { 2273 2 SV *sv; 2274 2 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) { 2275 2 pkgname = SvPV_nolen_const(sv); 2276 } 2277 } 2278 2279 28 return gv_stashpv(pkgname, FALSE); 2280 } 2281 2282 #ifdef DEBUGGING 2283 static const char* const exp_name[] = 2284 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK", 2285 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR" 2286 }; 2287 #endif 2288 2289 /* 2290 yylex 2291 2292 Works out what to call the token just pulled out of the input 2293 stream. The yacc parser takes care of taking the ops we return and 2294 stitching them into a tree. 2295 2296 Returns: 2297 PRIVATEREF 2298 2299 Structure: 2300 if read an identifier 2301 if we're in a my declaration 2302 croak if they tried to say my($foo::bar) 2303 build the ops for a my() declaration 2304 if it's an access to a my() variable 2305 are we in a sort block? 2306 croak if my($a); $a <=> $b 2307 build ops for access to a my() variable 2308 if in a dq string, and they've said @foo and we can't find @foo 2309 croak 2310 build ops for a bareword 2311 if we already built the token before, use it. 2312 */ 2313 2314 2315 #ifdef __SC__ 2316 #pragma segment Perl_yylex 2317 #endif 2318 int 2319 Perl_yylex(pTHX) 2320 39968763 { 2321 39968763 register char *s = PL_bufptr; 2322 39968763 register char *d; 2323 39968763 register I32 tmp; 2324 39968763 STRLEN len; 2325 39968763 GV *gv = Nullgv; 2326 39968763 GV **gvp = 0; 2327 39968763 bool bof = FALSE; 2328 39968763 I32 orig_keyword = 0; 2329 2330 DEBUG_T( { 2331 PerlIO_printf(Perl_debug_log, "### LEX_%s\n", 2332 lex_state_names[PL_lex_state]); 2333 39968763 } ); 2334 /* check if there's an identifier for us to look at */ 2335 39968763 if (PL_pending_ident) 2336 5127241 return REPORT(S_pending_ident(aTHX)); 2337 2338 /* no identifier pending identification */ 2339 2340 34841522 switch (PL_lex_state) { 2341 #ifdef COMMENTARY 2342 case LEX_NORMAL: /* Some compilers will produce faster */ 2343 case LEX_INTERPNORMAL: /* code if we comment these out. */ 2344 break; 2345 #endif 2346 2347 /* when we've already built the next token, just pull it out of the queue */ 2348 case LEX_KNOWNEXT: 2349 4267092 PL_nexttoke--; 2350 4267092 yylval = PL_nextval[PL_nexttoke]; 2351 4267092 if (!PL_nexttoke) { 2352 4056398 PL_lex_state = PL_lex_defer; 2353 4056398 PL_expect = PL_lex_expect; 2354 4056398 PL_lex_defer = LEX_NORMAL; 2355 } 2356 DEBUG_T({ PerlIO_printf(Perl_debug_log, 2357 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr, 2358 4267092 (IV)PL_nexttype[PL_nexttoke]); }); 2359 2360 4267092 return REPORT(PL_nexttype[PL_nexttoke]); 2361 2362 /* interpolated case modifiers like \L \U, including \Q and \E. 2363 when we get here, PL_bufptr is at the \ 2364 */ 2365 case LEX_INTERPCASEMOD: 2366 #ifdef DEBUGGING 2367 7413 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\') 2368 ###### Perl_croak(aTHX_ "panic: INTERPCASEMOD"); 2369 #endif 2370 /* handle \E or end of string */ 2371 7413 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') { 2372 /* if at a \E */ 2373 3993 if (PL_lex_casemods) { 2374 3411 const char oldmod = PL_lex_casestack[--PL_lex_casemods]; 2375 3411 PL_lex_casestack[PL_lex_casemods] = '\0'; 2376 2377 3411 if (PL_bufptr != PL_bufend 2378 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) { 2379 2756 PL_bufptr += 2; 2380 2756 PL_lex_state = LEX_INTERPCONCAT; 2381 } 2382 3411 return REPORT(')'); 2383 } 2384 582 if (PL_bufptr != PL_bufend) 2385 6 PL_bufptr += 2; 2386 582 PL_lex_state = LEX_INTERPCONCAT; 2387 582 return yylex(); 2388 } 2389 else { 2390 DEBUG_T({ PerlIO_printf(Perl_debug_log, 2391 3420 "### Saw case modifier at '%s'\n", PL_bufptr); }); 2392 3420 s = PL_bufptr + 1; 2393 3420 if (s[1] == '\\' && s[2] == 'E') { 2394 5 PL_bufptr = s + 3; 2395 5 PL_lex_state = LEX_INTERPCONCAT; 2396 5 return yylex(); 2397 } 2398 else { 2399 3415 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) 2400 5 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */ 2401 3415 if ((*s == 'L' || *s == 'U') && 2402 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) { 2403 2 PL_lex_casestack[--PL_lex_casemods] = '\0'; 2404 2 return REPORT(')'); 2405 } 2406 3413 if (PL_lex_casemods > 10) 2407 2 Renew(PL_lex_casestack, PL_lex_casemods + 2, char); 2408 3413 PL_lex_casestack[PL_lex_casemods++] = *s; 2409 3413 PL_lex_casestack[PL_lex_casemods] = '\0'; 2410 3413 PL_lex_state = LEX_INTERPCONCAT; 2411 3413 PL_nextval[PL_nexttoke].ival = 0; 2412 3413 force_next('('); 2413 3413 if (*s == 'l') 2414 15 PL_nextval[PL_nexttoke].ival = OP_LCFIRST; 2415 3398 else if (*s == 'u') 2416 82 PL_nextval[PL_nexttoke].ival = OP_UCFIRST; 2417 3316 else if (*s == 'L') 2418 273 PL_nextval[PL_nexttoke].ival = OP_LC; 2419 3043 else if (*s == 'U') 2420 232 PL_nextval[PL_nexttoke].ival = OP_UC; 2421 2811 else if (*s == 'Q') 2422 2811 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA; 2423 else 2424 ###### Perl_croak(aTHX_ "panic: yylex"); 2425 3413 PL_bufptr = s + 1; 2426 } 2427 3413 force_next(FUNC); 2428 3413 if (PL_lex_starts) { 2429 1565 s = PL_bufptr; 2430 1565 PL_lex_starts = 0; 2431 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ 2432 1565 if (PL_lex_casemods == 1 && PL_lex_inpat) 2433 1157 OPERATOR(','); 2434 else 2435 408 Aop(OP_CONCAT); 2436 } 2437 else 2438 1848 return yylex(); 2439 } 2440 2441 case LEX_INTERPPUSH: 2442 796041 return REPORT(sublex_push()); 2443 2444 case LEX_INTERPSTART: 2445 1148407 if (PL_bufptr == PL_bufend) 2446 711138 return REPORT(sublex_done()); 2447 DEBUG_T({ PerlIO_printf(Perl_debug_log, 2448 437269 "### Interpolated variable at '%s'\n", PL_bufptr); }); 2449 437269 PL_expect = XTERM; 2450 437269 PL_lex_dojoin = (*PL_bufptr == '@'); 2451 437269 PL_lex_state = LEX_INTERPNORMAL; 2452 437269 if (PL_lex_dojoin) { 2453 12824 PL_nextval[PL_nexttoke].ival = 0; 2454 12824 force_next(','); 2455 12824 force_ident("\"", '$'); 2456 12824 PL_nextval[PL_nexttoke].ival = 0; 2457 12824 force_next('$'); 2458 12824 PL_nextval[PL_nexttoke].ival = 0; 2459 12824 force_next('('); 2460 12824 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */ 2461 12824 force_next(FUNC); 2462 } 2463 437269 if (PL_lex_starts++) { 2464 324436 s = PL_bufptr; 2465 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ 2466 324436 if (!PL_lex_casemods && PL_lex_inpat) 2467 12811 OPERATOR(','); 2468 else 2469 311625 Aop(OP_CONCAT); 2470 } 2471 112833 return yylex(); 2472 2473 case LEX_INTERPENDMAYBE: 2474 393225 if (intuit_more(PL_bufptr)) { 2475 46561 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */ 2476 46561 break; 2477 } 2478 /* FALL THROUGH */ 2479 2480 case LEX_INTERPEND: 2481 441730 if (PL_lex_dojoin) { 2482 12824 PL_lex_dojoin = FALSE; 2483 12824 PL_lex_state = LEX_INTERPCONCAT; 2484 12824 return REPORT(')'); 2485 } 2486 428906 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl 2487 && SvEVALED(PL_lex_repl)) 2488 { 2489 4385 if (PL_bufptr != PL_bufend) 2490 2 Perl_croak(aTHX_ "Bad evalled substitution pattern"); 2491 4383 PL_lex_repl = Nullsv; 2492 } 2493 /* FALLTHROUGH */ 2494 case LEX_INTERPCONCAT: 2495 #ifdef DEBUGGING 2496 1369138 if (PL_lex_brackets) 2497 ###### Perl_croak(aTHX_ "panic: INTERPCONCAT"); 2498 #endif 2499 1369138 if (PL_bufptr == PL_bufend) 2500 205178 return REPORT(sublex_done()); 2501 2502 1163960 if (SvIVX(PL_linestr) == '\'') { 2503 9369 SV *sv = newSVsv(PL_linestr); 2504 9369 if (!PL_lex_inpat) 2505 5 sv = tokeq(sv); 2506 9364 else if ( PL_hints & HINT_NEW_RE ) 2507 2 sv = new_constant(NULL, 0, "qr", sv, sv, "q"); 2508 9369 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); 2509 9369 s = PL_bufend; 2510 } 2511 else { 2512 1154591 s = scan_const(PL_bufptr); 2513 1154587 if (*s == '\\') 2514 6180 PL_lex_state = LEX_INTERPCASEMOD; 2515 else 2516 1148407 PL_lex_state = LEX_INTERPSTART; 2517 } 2518 2519 1163956 if (s != PL_bufptr) { 2520 1031962 PL_nextval[PL_nexttoke] = yylval; 2521 1031962 PL_expect = XTERM; 2522 1031962 force_next(THING); 2523 1031962 if (PL_lex_starts++) { 2524 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ 2525 304101 if (!PL_lex_casemods && PL_lex_inpat) 2526 13060 OPERATOR(','); 2527 else 2528 291041 Aop(OP_CONCAT); 2529 } 2530 else { 2531 727861 PL_bufptr = s; 2532 727861 return yylex(); 2533 } 2534 } 2535 2536 131994 return yylex(); 2537 case LEX_FORMLINE: 2538 265 PL_lex_state = LEX_NORMAL; 2539 265 s = scan_formline(PL_bufptr); 2540 265 if (!PL_lex_formbrack) 2541 88 goto rightbracket; 2542 177 OPERATOR(';'); 2543 } 2544 2545 27240340 s = PL_bufptr; 2546 27240340 PL_oldoldbufptr = PL_oldbufptr; 2547 27240340 PL_oldbufptr = s; 2548 DEBUG_T( { 2549 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at [%s]\n", 2550 exp_name[PL_expect], s); 2551 27240340 } ); 2552 2553 retry: 2554 66447326 switch (*s) { 2555 default: 2556 2 if (isIDFIRST_lazy_if(s,UTF)) 2557 2 goto keylookup; 2558 ###### Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255); 2559 case 4: 2560 case 26: 2561 6653408 goto fake_eof; /* emulate EOF on ^D or ^Z */ 2562 case 0: 2563 6653408 if (!PL_rsfp) { 2564 105470 PL_last_uni = 0; 2565 105470 PL_last_lop = 0; 2566 105470 if (PL_lex_brackets) { 2567 2 if (PL_lex_formbrack) 2568 1 yyerror("Format not terminated"); 2569 else 2570 1 yyerror("Missing right curly or square bracket"); 2571 } 2572 DEBUG_T( { PerlIO_printf(Perl_debug_log, 2573 "### Tokener got EOF\n"); 2574 105470 } ); 2575 105470 TOKEN(0); 2576 } 2577 6547938 if (s++ < PL_bufend) 2578 7 goto retry; /* ignore stray nulls */ 2579 6547931 PL_last_uni = 0; 2580 6547931 PL_last_lop = 0; 2581 6547931 if (!PL_in_eval && !PL_preambled) { 2582 4506 PL_preambled = TRUE; 2583 4506 sv_setpv(PL_linestr,incl_perldb()); 2584 4506 if (SvCUR(PL_linestr)) 2585 9 sv_catpvn(PL_linestr,";", 1); 2586 4506 if (PL_preambleav){ 2587 1414 while(AvFILLp(PL_preambleav) >= 0) { 2588 711 SV *tmpsv = av_shift(PL_preambleav); 2589 711 sv_catsv(PL_linestr, tmpsv); 2590 711 sv_catpvn(PL_linestr, ";", 1); 2591 711 sv_free(tmpsv); 2592 } 2593 703 sv_free((SV*)PL_preambleav); 2594 703 PL_preambleav = NULL; 2595 } 2596 4506 if (PL_minus_n || PL_minus_p) { 2597 21 sv_catpv(PL_linestr, "LINE: while (<>) {"); 2598 21 if (PL_minus_l) 2599 3 sv_catpv(PL_linestr,"chomp;"); 2600 21 if (PL_minus_a) { 2601 5 if (PL_minus_F) { 2602 2 if ((*PL_splitstr == '/' || *PL_splitstr == '\'' 2603 || *PL_splitstr == '"') 2604 && strchr(PL_splitstr + 1, *PL_splitstr)) 2605 ###### Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr); 2606 else { 2607 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL 2608 bytes can be used as quoting characters. :-) */ 2609 /* The count here deliberately includes the NUL 2610 that terminates the C string constant. This 2611 embeds the opening NUL into the string. */ 2612 2 const char *splits = PL_splitstr; 2613 2 sv_catpvn(PL_linestr, "our @F=split(q", 15); 2614 15 do { 2615 /* Need to \ \s */ 2616 15 if (*splits == '\\') 2617 2 sv_catpvn(PL_linestr, splits, 1); 2618 15 sv_catpvn(PL_linestr, splits, 1); 2619 15 } while (*splits++); 2620 /* This loop will embed the trailing NUL of 2621 PL_linestr as the last thing it does before 2622 terminating. */ 2623 2 sv_catpvn(PL_linestr, ");", 2); 2624 } 2625 } 2626 else 2627 3 sv_catpv(PL_linestr,"our @F=split(' ');"); 2628 } 2629 } 2630 4506 sv_catpvn(PL_linestr, "\n", 1); 2631 4506 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); 2632 4506 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 2633 4506 PL_last_lop = PL_last_uni = Nullch; 2634 4506 if (PERLDB_LINE && PL_curstash != PL_debstash) { 2635 9 SV * const sv = NEWSV(85,0); 2636 2637 9 sv_upgrade(sv, SVt_PVMG); 2638 9 sv_setsv(sv,PL_linestr); 2639 9 (void)SvIOK_on(sv); 2640 9 SvIV_set(sv, 0); 2641 9 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); 2642 } 2643 9 goto retry; 2644 } 2645 8418620 do { 2646 8418620 bof = PL_rsfp ? TRUE : FALSE; 2647 8418620 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { 2648 fake_eof: 2649 38009 if (PL_rsfp) { 2650 37719 if (PL_preprocess && !PL_in_eval) 2651 3 (void)PerlProc_pclose(PL_rsfp); 2652 37716 else if ((PerlIO *)PL_rsfp == PerlIO_stdin()) 2653 19 PerlIO_clearerr(PL_rsfp); 2654 else 2655 37697 (void)PerlIO_close(PL_rsfp); 2656 37719 PL_rsfp = Nullfp; 2657 37719 PL_doextract = FALSE; 2658 } 2659 38009 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) { 2660 16 sv_setpv(PL_linestr,PL_minus_p 2661 ? ";}continue{print;}" : ";}"); 2662 16 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); 2663 16 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 2664 16 PL_last_lop = PL_last_uni = Nullch; 2665 16 PL_minus_n = PL_minus_p = 0; 2666 16 goto retry; 2667 } 2668 37993 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); 2669 37993 PL_last_lop = PL_last_uni = Nullch; 2670 37993 sv_setpvn(PL_linestr,"",0); 2671 37993 TOKEN(';'); /* not infinite loop because rsfp is NULL now */ 2672 } 2673 /* If it looks like the start of a BOM or raw UTF-16, 2674 * check if it in fact is. */ 2675 8396125 else if (bof && 2676 (*s == 0 || 2677 *(U8*)s == 0xEF || 2678 *(U8*)s >= 0xFE || 2679 s[1] == 0)) { 2680 #ifdef PERLIO_IS_STDIO 2681 # ifdef __GNU_LIBRARY__ 2682 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */ 2683 # define FTELL_FOR_PIPE_IS_BROKEN 2684 # endif 2685 # else 2686 # ifdef __GLIBC__ 2687 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */ 2688 # define FTELL_FOR_PIPE_IS_BROKEN 2689 # endif 2690 # endif 2691 # endif 2692 #endif 2693 #ifdef FTELL_FOR_PIPE_IS_BROKEN 2694 /* This loses the possibility to detect the bof 2695 * situation on perl -P when the libc5 is being used. 2696 * Workaround? Maybe attach some extra state to PL_rsfp? 2697 */ 2698 if (!PL_preprocess) 2699 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr); 2700 #else 2701 1751063 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr); 2702 #endif 2703 1751063 if (bof) { 2704 1685 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 2705 1685 s = swallow_bom((U8*)s); 2706 } 2707 } 2708 8396125 if (PL_doextract) { 2709 /* Incest with pod. */ 2710 1944147 if (*s == '=' && strnEQ(s, "=cut", 4)) { 2711 68952 sv_setpvn(PL_linestr, "", 0); 2712 68952 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); 2713 68952 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 2714 68952 PL_last_lop = PL_last_uni = Nullch; 2715 68952 PL_doextract = FALSE; 2716 } 2717 } 2718 8396125 incline(s); 2719 8396125 } while (PL_doextract); 2720 6520930 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; 2721 6520930 if (PERLDB_LINE && PL_curstash != PL_debstash) { 2722 937 SV * const sv = NEWSV(85,0); 2723 2724 937 sv_upgrade(sv, SVt_PVMG); 2725 937 sv_setsv(sv,PL_linestr); 2726 937 (void)SvIOK_on(sv); 2727 937 SvIV_set(sv, 0); 2728 937 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); 2729 } 2730 6520930 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 2731 6520930 PL_last_lop = PL_last_uni = Nullch; 2732 6520930 if (CopLINE(PL_curcop) == 1) { 2733 42348 while (s < PL_bufend && isSPACE(*s)) 2734 1925 s++; 2735 40423 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */ 2736 ###### s++; 2737 40423 d = Nullch; 2738 40423 if (!PL_in_eval) { 2739 5049 if (*s == '#' && *(s+1) == '!') 2740 1048 d = s + 2; 2741 #ifdef ALTERNATE_SHEBANG 2742 else { 2743 static char const as[] = ALTERNATE_SHEBANG; 2744 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1)) 2745 d = s + (sizeof(as) - 1); 2746 } 2747 #endif /* ALTERNATE_SHEBANG */ 2748 } 2749 40423 if (d) { 2750 1073 char *ipath; 2751 1073 char *ipathend; 2752 2753 1073 while (isSPACE(*d)) 2754 25 d++; 2755 1048 ipath = d; 2756 14461 while (*d && !isSPACE(*d)) 2757 13413 d++; 2758 1048 ipathend = d; 2759 2760 #ifdef ARG_ZERO_IS_SCRIPT 2761 if (ipathend > ipath) { 2762 /* 2763 * HP-UX (at least) sets argv[0] to the script name, 2764 * which makes $^X incorrect. And Digital UNIX and Linux, 2765 * at least, set argv[0] to the basename of the Perl 2766 * interpreter. So, having found "#!", we'll set it right. 2767 */ 2768 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */ 2769 assert(SvPOK(x) || SvGMAGICAL(x)); 2770 if (sv_eq(x, CopFILESV(PL_curcop))) { 2771 sv_setpvn(x, ipath, ipathend - ipath); 2772 SvSETMAGIC(x); 2773 } 2774 else { 2775 STRLEN blen; 2776 STRLEN llen; 2777 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen); 2778 const char * const lstart = SvPV_const(x,llen); 2779 if (llen < blen) { 2780 bstart += blen - llen; 2781 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') { 2782 sv_setpvn(x, ipath, ipathend - ipath); 2783 SvSETMAGIC(x); 2784 } 2785 } 2786 } 2787 TAINT_NOT; /* $^X is always tainted, but that's OK */ 2788 } 2789 #endif /* ARG_ZERO_IS_SCRIPT */ 2790 2791 /* 2792 * Look for options. 2793 */ 2794 1048 d = instr(s,"perl -"); 2795 1048 if (!d) { 2796 684 d = instr(s,"perl"); 2797 #if defined(DOSISH) 2798 /* avoid getting into infinite loops when shebang 2799 * line contains "Perl" rather than "perl" */ 2800 if (!d) { 2801 for (d = ipathend-4; d >= ipath; --d) { 2802 if ((*d == 'p' || *d == 'P') 2803 && !ibcmp(d, "perl", 4)) 2804 { 2805 break; 2806 } 2807 } 2808 if (d < ipath) 2809 d = Nullch; 2810 } 2811 #endif 2812 } 2813 #ifdef ALTERNATE_SHEBANG 2814 /* 2815 * If the ALTERNATE_SHEBANG on this system starts with a 2816 * character that can be part of a Perl expression, then if 2817 * we see it but not "perl", we're probably looking at the 2818 * start of Perl code, not a request to hand off to some 2819 * other interpreter. Similarly, if "perl" is there, but 2820 * not in the first 'word' of the line, we assume the line 2821 * contains the start of the Perl program. 2822 */ 2823 if (d && *s != '#') { 2824 const char *c = ipath; 2825 while (*c && !strchr("; \t\r\n\f\v#", *c)) 2826 c++; 2827 if (c < d) 2828 d = Nullch; /* "perl" not in first word; ignore */ 2829 else 2830 *s = '#'; /* Don't try to parse shebang line */ 2831 } 2832 #endif /* ALTERNATE_SHEBANG */ 2833 #ifndef MACOS_TRADITIONAL 2834 1048 if (!d && 2835 *s == '#' && 2836 ipathend > ipath && 2837 !PL_minus_c && 2838 !instr(s,"indir") && 2839 instr(PL_origargv[0],"perl")) 2840 { 2841 dVAR; 2842 ###### char **newargv; 2843 2844 ###### *ipathend = '\0'; 2845 ###### s = ipathend + 1; 2846 ###### while (s < PL_bufend && isSPACE(*s)) 2847 ###### s++; 2848 ###### if (s < PL_bufend) { 2849 ###### Newz(899,newargv,PL_origargc+3,char*); 2850 ###### newargv[1] = s; 2851 ###### while (s < PL_bufend && !isSPACE(*s)) 2852 ###### s++; 2853 ###### *s = '\0'; 2854 ###### Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*); 2855 } 2856 else 2857 ###### newargv = PL_origargv; 2858 ###### newargv[0] = ipath; 2859 ###### PERL_FPU_PRE_EXEC 2860 ###### PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv)); 2861 ###### PERL_FPU_POST_EXEC 2862 ###### Perl_croak(aTHX_ "Can't exec %s", ipath); 2863 } 2864 #endif 2865 1048 if (d) { 2866 1048 const U32 oldpdb = PL_perldb; 2867 1048 const bool oldn = PL_minus_n; 2868 1048 const bool oldp = PL_minus_p; 2869 2870 5809 while (*d && !isSPACE(*d)) d++; 2871 1447 while (SPACE_OR_TAB(*d)) d++; 2872 2873 1048 if (*d++ == '-') { 2874 392 const bool switches_done = PL_doswitches; 2875 818 do { 2876 818 if (*d == 'M' || *d == 'm' || *d == 'C') { 2877 ###### const char * const m = d; 2878 ###### while (*d && !isSPACE(*d)) d++; 2879 ###### Perl_croak(aTHX_ "Too late for \"-%.*s\" option", 2880 (int)(d - m), m); 2881 } 2882 818 d = moreswitches(d); 2883 818 } while (d); 2884 392 if (PL_doswitches && !switches_done) { 2885 1 int argc = PL_origargc; 2886 1 char **argv = PL_origargv; 2887 2 do { 2888 2 argc--,argv++; 2889 2 } while (argc && argv[0][0] == '-' && argv[0][1]); 2890 1 init_argv_symbols(argc,argv); 2891 } 2892 392 if ((PERLDB_LINE && !oldpdb) || 2893 ((PL_minus_n || PL_minus_p) && !(oldn || oldp))) 2894 /* if we have already added "LINE: while (<>) {", 2895 we must not do it again */ 2896 { 2897 6 sv_setpvn(PL_linestr, "", 0); 2898 6 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); 2899 6 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 2900 6 PL_last_lop = PL_last_uni = Nullch; 2901 6 PL_preambled = FALSE; 2902 6 if (PERLDB_LINE) 2903 ###### (void)gv_fetchfile(PL_origfilename); 2904 ###### goto retry; 2905 } 2906 386 if (PL_doswitches && !switches_done) { 2907 ###### int argc = PL_origargc; 2908 ###### char **argv = PL_origargv; 2909 ###### do { 2910 ###### argc--,argv++; 2911 ###### } while (argc && argv[0][0] == '-' && argv[0][1]); 2912 ###### init_argv_symbols(argc,argv); 2913 } 2914 } 2915 } 2916 } 2917 } 2918 6520924 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { 2919 155 PL_bufptr = s; 2920 155 PL_lex_state = LEX_FORMLINE; 2921 155 return yylex(); 2922 } 2923 26156837 goto retry; 2924 case '\r': 2925 #ifdef PERL_STRICT_CR 2926 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r'); 2927 Perl_croak(aTHX_ 2928 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n"); 2929 #endif 2930 case ' ': case '\t': case '\f': case 013: 2931 #ifdef MACOS_TRADITIONAL 2932 case '\312': 2933 #endif 2934 26156837 s++; 2935 26156837 goto retry; 2936 case '#': 2937 case '\n': 2938 6455967 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) { 2939 47885 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) { 2940 /* handle eval qq[#line 1 "foo"\n ...] */ 2941 181 CopLINE_dec(PL_curcop); 2942 181 incline(s); 2943 } 2944 47885 d = PL_bufend; 2945 268266 while (s < d && *s != '\n') 2946 220381 s++; 2947 47885 if (s < d) 2948 47885 s++; 2949 ###### else if (s > d) /* Found by Ilya: feed random input to Perl. */ 2950 ###### Perl_croak(aTHX_ "panic: input overflow"); 2951 47885 incline(s); 2952 47885 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { 2953 76 PL_bufptr = s; 2954 76 PL_lex_state = LEX_FORMLINE; 2955 76 return yylex(); 2956 } 2957 } 2958 else { 2959 6408082 *s = '\0'; 2960 6408082 PL_bufend = s; 2961 } 2962 6408082 goto retry; 2963 case '-': 2964 596704 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) { 2965 35950 I32 ftst = 0; 2966 2967 35950 s++; 2968 35950 PL_bufptr = s; 2969 35950 tmp = *s++; 2970 2971 71137 while (s < PL_bufend && SPACE_OR_TAB(*s)) 2972 35187 s++; 2973 2974 35950 if (strnEQ(s,"=>",2)) { 2975 ###### s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE); 2976 DEBUG_T( { PerlIO_printf(Perl_debug_log, 2977 "### Saw unary minus before =>, forcing word '%s'\n", s); 2978 ###### } ); 2979 ###### OPERATOR('-'); /* unary minus */ 2980 } 2981 35950 PL_last_uni = PL_oldbufptr; 2982 35950 switch (tmp) { 2983 1655 case 'r': ftst = OP_FTEREAD; break; 2984 2626 case 'w': ftst = OP_FTEWRITE; break; 2985 922 case 'x': ftst = OP_FTEEXEC; break; 2986 2 case 'o': ftst = OP_FTEOWNED; break; 2987 2 case 'R': ftst = OP_FTRREAD; break; 2988 4 case 'W': ftst = OP_FTRWRITE; break; 2989 2 case 'X': ftst = OP_FTREXEC; break; 2990 1 case 'O': ftst = OP_FTROWNED; break; 2991 2972 case 'e': ftst = OP_FTIS; break; 2992 8 case 'z': ftst = OP_FTZERO; break; 2993 4464 case 's': ftst = OP_FTSIZE; break; 2994 8063 case 'f': ftst = OP_FTFILE; break; 2995 12288 case 'd': ftst = OP_FTDIR; break; 2996 1740 case 'l': ftst = OP_FTLINK; break; 2997 8 case 'p': ftst = OP_FTPIPE; break; 2998 11 case 'S': ftst = OP_FTSOCK; break; 2999 6 case 'u': ftst = OP_FTSUID; break; 3000 5 case 'g': ftst = OP_FTSGID; break; 3001 10 case 'k': ftst = OP_FTSVTX; break; 3002 10 case 'b': ftst = OP_FTBLK; break; 3003 108 case 'c': ftst = OP_FTCHR; break; 3004 241 case 't': ftst = OP_FTTTY; break; 3005 82 case 'T': ftst = OP_FTTEXT; break; 3006 404 case 'B': ftst = OP_FTBINARY; break; 3007 case 'M': case 'A': case 'C': 3008 314 gv_fetchpv("\024",TRUE, SVt_PV); 3009 314 switch (tmp) { 3010 306 case 'M': ftst = OP_FTMTIME; break; 3011 4 case 'A': ftst = OP_FTATIME; break; 3012 4 case 'C': ftst = OP_FTCTIME; break; 3013 35950 default: break; 3014 } 3015 35950 break; 3016 default: 3017 35950 break; 3018 } 3019 35950 if (ftst) { 3020 35948 PL_last_lop_op = (OPCODE)ftst; 3021 DEBUG_T( { PerlIO_printf(Perl_debug_log, 3022 "### Saw file test %c\n", (int)ftst); 3023 35948 } ); 3024 35948 FTST(ftst); 3025 } 3026 else { 3027 /* Assume it was a minus followed by a one-letter named 3028 * subroutine call (or a -bareword), then. */ 3029 DEBUG_T( { PerlIO_printf(Perl_debug_log, 3030 "### '-%c' looked like a file test but was not\n", 3031 (int) tmp); 3032 2 } ); 3033 2 s = --PL_bufptr; 3034 } 3035 } 3036 560756 tmp = *s++; 3037 560756 if (*s == tmp) { 3038 14147 s++; 3039 14147 if (PL_expect == XOPERATOR) 3040 12250 TERM(POSTDEC); 3041 else 3042 1897 OPERATOR(PREDEC); 3043 } 3044 546609 else if (*s == '>') { 3045 495232 s++; 3046 495232 s = skipspace(s); 3047 495232 if (isIDFIRST_lazy_if(s,UTF)) { 3048 239230 s = force_word(s,METHOD,FALSE,TRUE,FALSE); 3049 239230 TOKEN(ARROW); 3050 } 3051 256002 else if (*s == '$') 3052 1393 OPERATOR(ARROW); 3053 else 3054 254609 TERM(ARROW); 3055 } 3056 51377 if (PL_expect == XOPERATOR) 3057 23904 Aop(OP_SUBTRACT); 3058 else { 3059 27473 if (isSPACE(*s) || !isSPACE(*PL_bufptr)) 3060 13302 check_uni(); 3061 27473 OPERATOR('-'); /* unary minus */ 3062 } 3063 3064 case '+': 3065 82457 tmp = *s++; 3066 82457 if (*s == tmp) { 3067 37868 s++; 3068 37868 if (PL_expect == XOPERATOR) 3069 30749 TERM(POSTINC); 3070 else 3071 7119 OPERATOR(PREINC); 3072 } 3073 44589 if (PL_expect == XOPERATOR) 3074 42883 Aop(OP_ADD); 3075 else { 3076 1706 if (isSPACE(*s) || !isSPACE(*PL_bufptr)) 3077 695 check_uni(); 3078 1706 OPERATOR('+'); 3079 } 3080 3081 case '*': 3082 70556 if (PL_expect != XOPERATOR) { 3083 59972 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE); 3084 59972 PL_expect = XOPERATOR; 3085 59972 force_ident(PL_tokenbuf, '*'); 3086 59972 if (!*PL_tokenbuf) 3087 25986 PREREF('*'); 3088 33986 TERM('*'); 3089 } 3090 10584 s++; 3091 10584 if (*s == '*') { 3092 1658 s++; 3093 1658 PWop(OP_POW); 3094 } 3095 8926 Mop(OP_MULTIPLY); 3096 3097 case '%': 3098 93761 if (PL_expect == XOPERATOR) { 3099 2952 ++s; 3100 2952 Mop(OP_MODULO); 3101 } 3102 90809 PL_tokenbuf[0] = '%'; 3103 90809 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE); 3104 90809 if (!PL_tokenbuf[1]) { 3105 23908 PREREF('%'); 3106 } 3107 66901 PL_pending_ident = '%'; 3108 66901 TERM('%'); 3109 3110 case '^': 3111 522 s++; 3112 522 BOop(OP_BIT_XOR); 3113 case '[': 3114 225673 PL_lex_brackets++; 3115 /* FALL THROUGH */ 3116 case '~': 3117 case ',': 3118 1740784 tmp = *s++; 3119 1740784 OPERATOR(tmp); 3120 case ':': 3121 94287 if (s[1] == ':') { 3122 150 len = 0; 3123 150 goto just_a_word; 3124 } 3125 94137 s++; 3126 94137 switch (PL_expect) { 3127 91912 OP *attrs; 3128 case XOPERATOR: 3129 91912 if (!PL_in_my || PL_lex_state != LEX_NORMAL) 3130 1142 break; 3131 1142 PL_bufptr = s; /* update in case we back off */ 3132 1142 goto grabattrs; 3133 case XATTRBLOCK: 3134 105 PL_expect = XBLOCK; 3135 105 goto grabattrs; 3136 case XATTRTERM: 3137 8 PL_expect = XTERMBLOCK; 3138 grabattrs: 3139 1255 s = skipspace(s); 3140 1255 attrs = Nullop; 3141 2465 while (isIDFIRST_lazy_if(s,UTF)) { 3142 1261 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); 3143 1261 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) { 3144 ###### if (tmp < 0) tmp = -tmp; 3145 ###### switch (tmp) { 3146 case KEY_or: 3147 case KEY_and: 3148 case KEY_err: 3149 case KEY_for: 3150 case KEY_unless: 3151 case KEY_if: 3152 case KEY_while: 3153 case KEY_until: 3154 1261 goto got_attrs; 3155 default: 3156 1261 break; 3157 } 3158 } 3159 1261 if (*d == '(') { 3160 60 d = scan_str(d,TRUE,TRUE); 3161 60 if (!d) { 3162 /* MUST advance bufptr here to avoid bogus 3163 "at end of line" context messages from yyerror(). 3164 */ 3165 4 PL_bufptr = s + len; 3166 4 yyerror("Unterminated attribute parameter in attribute list"); 3167 4 if (attrs) 3168 ###### op_free(attrs); 3169 4 return REPORT(0); /* EOF indicator */ 3170 } 3171 } 3172 1257 if (PL_lex_stuff) { 3173 56 SV *sv = newSVpvn(s, len); 3174 56 sv_catsv(sv, PL_lex_stuff); 3175 56 attrs = append_elem(OP_LIST, attrs, 3176 newSVOP(OP_CONST, 0, sv)); 3177 56 SvREFCNT_dec(PL_lex_stuff); 3178 56 PL_lex_stuff = Nullsv; 3179 } 3180 else { 3181 1201 if (len == 6 && strnEQ(s, "unique", len)) { 3182 1086 if (PL_in_my == KEY_our) 3183 #ifdef USE_ITHREADS 3184 GvUNIQUE_on(cGVOPx_gv(yylval.opval)); 3185 #else 3186 ; /* skip to avoid loading attributes.pm */ 3187 #endif 3188 else 3189 ###### Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables"); 3190 } 3191 3192 /* NOTE: any CV attrs applied here need to be part of 3193 the CVf_BUILTIN_ATTRS define in cv.h! */ 3194 115 else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len)) 3195 54 CvLVALUE_on(PL_compcv); 3196 61 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len)) 3197 15 CvLOCKED_on(PL_compcv); 3198 46 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len)) 3199 6 CvMETHOD_on(PL_compcv); 3200 40 else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len)) 3201 9 CvASSERTION_on(PL_compcv); 3202 /* After we've set the flags, it could be argued that 3203 we don't need to do the attributes.pm-based setting 3204 process, and shouldn't bother appending recognized 3205 flags. To experiment with that, uncomment the 3206 following "else". (Note that's already been 3207 uncommented. That keeps the above-applied built-in 3208 attributes from being intercepted (and possibly 3209 rejected) by a package's attribute routines, but is 3210 justified by the performance win for the common case 3211 of applying only built-in attributes.) */ 3212 else 3213 31 attrs = append_elem(OP_LIST, attrs, 3214 newSVOP(OP_CONST, 0, 3215 newSVpvn(s, len))); 3216 } 3217 1257 s = skipspace(d); 3218 1257 if (*s == ':' && s[1] != ':') 3219 6 s = skipspace(s+1); 3220 1251 else if (s == d) 3221 1251 break; /* require real whitespace or :'s */ 3222 } 3223 1251 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */ 3224 1251 if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) { 3225 4 const char q = ((*s == '\'') ? '"' : '\''); 3226 /* If here for an expression, and parsed no attrs, back off. */ 3227 4 if (tmp == '=' && !attrs) { 3228 1 s = PL_bufptr; 3229 1 break; 3230 } 3231 /* MUST advance bufptr here to avoid bogus "at end of line" 3232 context messages from yyerror(). 3233 */ 3234 3 PL_bufptr = s; 3235 3 if (!*s) 3236 ###### yyerror("Unterminated attribute list"); 3237 else 3238 3 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list", 3239 q, *s, q)); 3240 3 if (attrs) 3241 3 op_free(attrs); 3242 3 OPERATOR(':'); 3243 } 3244 got_attrs: 3245 1247 if (attrs) { 3246 77 PL_nextval[PL_nexttoke].opval = attrs; 3247 77 force_next(THING); 3248 } 3249 1247 TOKEN(COLONATTR); 3250 } 3251 92883 OPERATOR(':'); 3252 case '(': 3253 1769795 s++; 3254 1769795 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr) 3255 310753 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */ 3256 else 3257 1459042 PL_expect = XTERM; 3258 1769795 s = skipspace(s); 3259 1769795 TOKEN('('); 3260 case ';': 3261 2552416 CLINE; 3262 2552416 tmp = *s++; 3263 2552416 OPERATOR(tmp); 3264 case ')': 3265 1769590 tmp = *s++; 3266 1769590 s = skipspace(s); 3267 1769590 if (*s == '{') 3268 439150 PREBLOCK(tmp); 3269 1330440 TERM(tmp); 3270 case ']': 3271 225673 s++; 3272 225673 if (PL_lex_brackets <= 0) 3273 ###### yyerror("Unmatched right square bracket"); 3274 else 3275 225673 --PL_lex_brackets; 3276 225673 if (PL_lex_state == LEX_INTERPNORMAL) { 3277 11644 if (PL_lex_brackets == 0) { 3278 11178 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>')) 3279 11139 PL_lex_state = LEX_INTERPEND; 3280 } 3281 } 3282 225673 TERM(']'); 3283 case '{': 3284 leftbracket: 3285 1488694 s++; 3286 1488694 if (PL_lex_brackets > 100) { 3287 50 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char); 3288 } 3289 1488694 switch (PL_expect) { 3290 case XTERM: 3291 24929 if (PL_lex_formbrack) { 3292 3 s--; 3293 3 PRETERMBLOCK(DO); 3294 } 3295 24926 if (PL_oldoldbufptr == PL_last_lop) 3296 1486 PL_lex_brackstack[PL_lex_brackets++] = XTERM; 3297 else 3298 23440 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; 3299 24926 OPERATOR(HASHBRACK); 3300 case XOPERATOR: 3301 486923 while (s < PL_bufend && SPACE_OR_TAB(*s)) 3302 1672 s++; 3303 485251 d = s; 3304 485251 PL_tokenbuf[0] = '\0'; 3305 485251 if (d < PL_bufend && *d == '-') { 3306 2034 PL_tokenbuf[0] = '-'; 3307 2034 d++; 3308 2034 while (d < PL_bufend && SPACE_OR_TAB(*d)) 3309 ###### d++; 3310 } 3311 485251 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) { 3312 268367 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, 3313 FALSE, &len); 3314 270613 while (d < PL_bufend && SPACE_OR_TAB(*d)) 3315 2246 d++; 3316 268367 if (*d == '}') { 3317 261779 const char minus = (PL_tokenbuf[0] == '-'); 3318 261779 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE); 3319 261779 if (minus) 3320 2034 force_next('-'); 3321 } 3322 } 3323 /* FALL THROUGH */ 3324 case XATTRBLOCK: 3325 case XBLOCK: 3326 1288955 PL_lex_brackstack[PL_lex_brackets++] = XSTATE; 3327 1288955 PL_expect = XSTATE; 3328 1288955 break; 3329 case XATTRTERM: 3330 case XTERMBLOCK: 3331 45899 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; 3332 45899 PL_expect = XSTATE; 3333 45899 break; 3334 default: { 3335 128911 const char *t; 3336 128911 if (PL_oldoldbufptr == PL_last_lop) 3337 19151 PL_lex_brackstack[PL_lex_brackets++] = XTERM; 3338 else 3339 109760 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; 3340 128911 s = skipspace(s); 3341 128911 if (*s == '}') { 3342 3 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) { 3343 1 PL_expect = XTERM; 3344 /* This hack is to get the ${} in the message. */ 3345 1 PL_bufptr = s+1; 3346 1 yyerror("syntax error"); 3347 1 break; 3348 } 3349 2 OPERATOR(HASHBRACK); 3350 } 3351 /* This hack serves to disambiguate a pair of curlies 3352 * as being a block or an anon hash. Normally, expectation 3353 * determines that, but in cases where we're not in a 3354 * position to expect anything in particular (like inside 3355 * eval"") we have to resolve the ambiguity. This code 3356 * covers the case where the first term in the curlies is a 3357 * quoted string. Most other cases need to be explicitly 3358 * disambiguated by prepending a "+" before the opening 3359 * curly in order to force resolution as an anon hash. 3360 * 3361 * XXX should probably propagate the outer expectation 3362 * into eval"" to rely less on this hack, but that could 3363 * potentially break current behavior of eval"". 3364 * GSAR 97-07-21 3365 */ 3366 128908 t = s; 3367 128908 if (*s == '\'' || *s == '"' || *s == '`') { 3368 /* common case: get past first string, handling escapes */ 3369 36054 for (t++; t < PL_bufend && *t != *s;) 3370 527653 if (*t++ == '\\' && (*t == '\\' || *t == *s)) 3371 11 t++; 3372 36043 t++; 3373 } 3374 92865 else if (*s == 'q') { 3375 1182 if (++t < PL_bufend 3376 && (!isALNUM(*t) 3377 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend 3378 && !isALNUM(*t)))) 3379 { 3380 /* skip q//-like construct */ 3381 799 const char *tmps; 3382 799 char open, close, term; 3383 799 I32 brackets = 1; 3384 3385 804 while (t < PL_bufend && isSPACE(*t)) 3386 5 t++; 3387 /* check for q => */ 3388 799 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') { 3389 2 OPERATOR(HASHBRACK); 3390 } 3391 797 term = *t; 3392 797 open = term; 3393 797 if (term && (tmps = strchr("([{< )]}> )]}>",term))) 3394 792 term = tmps[5]; 3395 797 close = term; 3396 797 if (open == close) 3397 22 for (t++; t < PL_bufend; t++) { 3398 22 if (*t == '\\' && t+1 < PL_bufend && open != '\\') 3399 ###### t++; 3400 22 else if (*t == open) 3401 5 break; 3402 } 3403 else { 3404 3973 for (t++; t < PL_bufend; t++) { 3405 3973 if (*t == '\\' && t+1 < PL_bufend) 3406 ###### t++; 3407 3973 else if (*t == close && --brackets <= 0) 3408 792 break; 3409 3181 else if (*t == open) 3410 1 brackets++; 3411 } 3412 } 3413 797 t++; 3414 } 3415 else 3416 /* skip plain q word */ 3417 2775 while (t < PL_bufend && isALNUM_lazy_if(t,UTF)) 3418 2392 t += UTF8SKIP(t); 3419 } 3420 91683 else if (isALNUM_lazy_if(t,UTF)) { 3421 28476 t += UTF8SKIP(t); 3422 156237 while (t < PL_bufend && isALNUM_lazy_if(t,UTF)) 3423 127761 t += UTF8SKIP(t); 3424 } 3425 143050 while (t < PL_bufend && isSPACE(*t)) 3426 14144 t++; 3427 /* if comma follows first term, call it an anon hash */ 3428 /* XXX it could be a comma expression with loop modifiers */ 3429 128906 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s))) 3430 || (*t == '=' && t[1] == '>'))) 3431 47 OPERATOR(HASHBRACK); 3432 128859 if (PL_expect == XREF) 3433 113790 PL_expect = XTERM; 3434 else { 3435 15069 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE; 3436 15069 PL_expect = XSTATE; 3437 } 3438 } 3439 1463714 break; 3440 } 3441 1463714 yylval.ival = CopLINE(PL_curcop); 3442 1463714 if (isSPACE(*s) || *s == '#') 3443 840761 PL_copline = NOLINE; /* invalidate current command line number */ 3444 1463714 TOKEN('{'); 3445 case '}': 3446 rightbracket: 3447 1488693 s++; 3448 1488693 if (PL_lex_brackets <= 0) 3449 8 yyerror("Unmatched right curly bracket"); 3450 else 3451 1488685 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets]; 3452 1488693 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL) 3453 ###### PL_lex_formbrack = 0; 3454 1488693 if (PL_lex_state == LEX_INTERPNORMAL) { 3455 28945 if (PL_lex_brackets == 0) { 3456 26692 if (PL_expect & XFAKEBRACK) { 3457 1 PL_expect &= XENUMMASK; 3458 1 PL_lex_state = LEX_INTERPEND; 3459 1 PL_bufptr = s; 3460 1 return yylex(); /* ignore fake brackets */ 3461 } 3462 26691 if (*s == '-' && s[1] == '>') 3463 95 PL_lex_state = LEX_INTERPENDMAYBE; 3464 26596 else if (*s != '[' && *s != '{') 3465 26022 PL_lex_state = LEX_INTERPEND; 3466 } 3467 } 3468 1488692 if (PL_expect & XFAKEBRACK) { 3469 4 PL_expect &= XENUMMASK; 3470 4 PL_bufptr = s; 3471 4 return yylex(); /* ignore fake brackets */ 3472 } 3473 1488688 force_next('}'); 3474 1488688 TOKEN(';'); 3475 case '&': 3476 196998 s++; 3477 196998 tmp = *s++; 3478 196998 if (tmp == '&') 3479 84443 AOPERATOR(ANDAND); 3480 112555 s--; 3481 112555 if (PL_expect == XOPERATOR) { 3482 20413 if (ckWARN(WARN_SEMICOLON) 3483 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart) 3484 { 3485 1 CopLINE_dec(PL_curcop); 3486 1 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi); 3487 1 CopLINE_inc(PL_curcop); 3488 } 3489 20413 BAop(OP_BIT_AND); 3490 } 3491 3492 92142 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE); 3493 92142 if (*PL_tokenbuf) { 3494 60777 PL_expect = XOPERATOR; 3495 60777 force_ident(PL_tokenbuf, '&'); 3496 } 3497 else 3498 31365 PREREF('&'); 3499 60777 yylval.ival = (OPpENTERSUB_AMPER<<8); 3500 60777 TERM('&'); 3501 3502 case '|': 3503 156569 s++; 3504 156569 tmp = *s++; 3505 156569 if (tmp == '|') 3506 115439 AOPERATOR(OROR); 3507 41130 s--; 3508 41130 BOop(OP_BIT_OR); 3509 case '=': 3510 1956246 s++; 3511 1956246 tmp = *s++; 3512 1956246 if (tmp == '=') 3513 63690 Eop(OP_EQ); 3514 1892556 if (tmp == '>') 3515 489414 OPERATOR(','); 3516 1403142 if (tmp == '~') 3517 163841 PMop(OP_MATCH); 3518 1239301 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp)) 3519 50 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp); 3520 1239292 s--; 3521 1239292 if (PL_expect == XSTATE && isALPHA(tmp) && 3522 (s == PL_linestart+1 || s[-2] == '\n') ) 3523 { 3524 68954 if (PL_in_eval && !PL_rsfp) { 3525 ###### d = PL_bufend; 3526 ###### while (s < d) { 3527 ###### if (*s++ == '\n') { 3528 ###### incline(s); 3529 ###### if (strnEQ(s,"=cut",4)) { 3530 ###### s = strchr(s,'\n'); 3531 ###### if (s) 3532 ###### s++; 3533 else 3534 ###### s = d; 3535 ###### incline(s); 3536 ###### goto retry; 3537 } 3538 } 3539 } 3540 68954 goto retry; 3541 } 3542 68954 s = PL_bufend; 3543 68954 PL_doextract = TRUE; 3544 68954 goto retry; 3545 } 3546 1170338 if (PL_lex_brackets < PL_lex_formbrack) { 3547 89 const char *t; 3548 #ifdef PERL_STRICT_CR 3549 for (t = s; SPACE_OR_TAB(*t); t++) ; 3550 #else 3551 89 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ; 3552 #endif 3553 89 if (*t == '\n' || *t == '#') { 3554 89 s--; 3555 89 PL_expect = XBLOCK; 3556 89 goto leftbracket; 3557 } 3558 } 3559 1170249 yylval.ival = 0; 3560 1170249 OPERATOR(ASSIGNOP); 3561 case '!': 3562 102081 s++; 3563 102081 tmp = *s++; 3564 102081 if (tmp == '=') { 3565 /* was this !=~ where !~ was meant? 3566 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */ 3567 3568 10978 if (*s == '~' && ckWARN(WARN_SYNTAX)) { 3569 7 const char *t = s+1; 3570 3571 14 while (t < PL_bufend && isSPACE(*t)) 3572 7 ++t; 3573 3574 7 if (*t == '/' || *t == '?' || 3575 ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) || 3576 (*t == 't' && t[1] == 'r' && !isALNUM(t[2]))) 3577 7 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 3578 "!=~ should be !~"); 3579 } 3580 10978 Eop(OP_NE); 3581 } 3582 91103 if (tmp == '~') 3583 15169 PMop(OP_NOT); 3584 75934 s--; 3585 75934 OPERATOR('!'); 3586 case '<': 3587 60498 if (PL_expect != XOPERATOR) { 3588 33311 if (s[1] != '<' && !strchr(s,'>')) 3589 2 check_uni(); 3590 33311 if (s[1] == '<') 3591 26511 s = scan_heredoc(s); 3592 else 3593 6800 s = scan_inputsymbol(s); 3594 33308 TERM(sublex_start()); 3595 } 3596 27187 s++; 3597 27187 tmp = *s++; 3598 27187 if (tmp == '<') 3599 844 SHop(OP_LEFT_SHIFT); 3600 26343 if (tmp == '=') { 3601 8755 tmp = *s++; 3602 8755 if (tmp == '>') 3603 2841 Eop(OP_NCMP); 3604 5914 s--; 3605 5914 Rop(OP_LE); 3606 } 3607 17588 s--; 3608 17588 Rop(OP_LT); 3609 case '>': 3610 34748 s++; 3611 34748 tmp = *s++; 3612 34748 if (tmp == '>') 3613 466 SHop(OP_RIGHT_SHIFT); 3614 34282 if (tmp == '=') 3615 8274 Rop(OP_GE); 3616 26008 s--; 3617 26008 Rop(OP_GT); 3618 3619 case '$': 3620 4544311 CLINE; 3621 3622 4544311 if (PL_expect == XOPERATOR) { 3623 2 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { 3624 2 PL_expect = XTERM; 3625 2 depcom(); 3626 2 return REPORT(','); /* grandfather non-comma-format format */ 3627 } 3628 } 3629 3630 4544309 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) { 3631 9035 PL_tokenbuf[0] = '@'; 3632 9035 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, 3633 sizeof PL_tokenbuf - 1, FALSE); 3634 9035 if (PL_expect == XOPERATOR) 3635 ###### no_op("Array length", s); 3636 9035 if (!PL_tokenbuf[1]) 3637 4143 PREREF(DOLSHARP); 3638 4892 PL_expect = XOPERATOR; 3639 4892 PL_pending_ident = '#'; 3640 4892 TOKEN(DOLSHARP); 3641 } 3642 3643 4535274 PL_tokenbuf[0] = '$'; 3644 4535274 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, 3645 sizeof PL_tokenbuf - 1, FALSE); 3646 4535274 if (PL_expect == XOPERATOR) 3647 ###### no_op("Scalar", s); 3648 4535274 if (!PL_tokenbuf[1]) { 3649 40874 if (s == PL_bufend) 3650 1 yyerror("Final $ should be \\$ or $name"); 3651 40874 PREREF('$'); 3652 } 3653 3654 /* This kludge not intended to be bulletproof. */ 3655 4494400 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) { 3656 135 yylval.opval = newSVOP(OP_CONST, 0, 3657 newSViv(PL_compiling.cop_arybase)); 3658 135 yylval.opval->op_private = OPpCONST_ARYBASE; 3659 135 TERM(THING); 3660 } 3661 3662 4494265 d = s; 3663 4494265 tmp = (I32)*s; 3664 4494265 if (PL_lex_state == LEX_NORMAL) 3665 4053885 s = skipspace(s); 3666 3667 4494265 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { 3668 3673112 char *t; 3669 3673112 if (*s == '[') { 3670 130803 PL_tokenbuf[0] = '@'; 3671 130803 if (ckWARN(WARN_SYNTAX)) { 3672 62445 for(t = s + 1; 3673 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$'; 3674 t++) ; 3675 62445 if (*t++ == ',') { 3676 1 PL_bufptr = skipspace(PL_bufptr); 3677 2 while (t < PL_bufend && *t != ']') 3678 1 t++; 3679 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 3680 "Multidimensional syntax %.*s not supported", 3681 (t - PL_bufptr) + 1, PL_bufptr); 3682 } 3683 } 3684 } 3685 3542309 else if (*s == '{') { 3686 231171 PL_tokenbuf[0] = '%'; 3687 231171 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") && 3688 (t = strchr(s, '}')) && (t = strchr(t, '='))) 3689 { 3690 1321 char tmpbuf[sizeof PL_tokenbuf]; 3691 1321 for (t++; isSPACE(*t); t++) ; 3692 1321 if (isIDFIRST_lazy_if(t,UTF)) { 3693 869 STRLEN len; 3694 869 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len); 3695 1735 for (; isSPACE(*t); t++) ; 3696 869 if (*t == ';' && get_cv(tmpbuf, FALSE)) 3697 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 3698 "You need to quote \"%s\"", tmpbuf); 3699 } 3700 } 3701 } 3702 } 3703 3704 4494265 PL_expect = XOPERATOR; 3705 4494265 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) { 3706 1595174 const bool islop = (PL_last_lop == PL_oldoldbufptr); 3707 1595174 if (!islop || PL_last_lop_op == OP_GREPSTART) 3708 1578847 PL_expect = XOPERATOR; 3709 16327 else if (strchr("$@\"'`q", *s)) 3710 8987 PL_expect = XTERM; /* e.g. print $fh "foo" */ 3711 7340 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF)) 3712 7 PL_expect = XTERM; /* e.g. print $fh &sub */ 3713 7333 else if (isIDFIRST_lazy_if(s,UTF)) { 3714 3489 char tmpbuf[sizeof PL_tokenbuf]; 3715 3489 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); 3716 3489 if ((tmp = keyword(tmpbuf, len))) { 3717 /* binary operators exclude handle interpretations */ 3718 3202 switch (tmp) { 3719 case -KEY_x: 3720 case -KEY_eq: 3721 case -KEY_ne: 3722 case -KEY_gt: 3723 case -KEY_lt: 3724 case -KEY_ge: 3725 case -KEY_le: 3726 case -KEY_cmp: 3727 3005 break; 3728 default: 3729 3005 PL_expect = XTERM; /* e.g. print $fh length() */ 3730 3005 break; 3731 } 3732 } 3733 else { 3734 287 PL_expect = XTERM; /* e.g. print $fh subr() */ 3735 } 3736 } 3737 3844 else if (isDIGIT(*s)) 3738 21 PL_expect = XTERM; /* e.g. print $fh 3 */ 3739 3823 else if (*s == '.' && isDIGIT(s[1])) 3740 ###### PL_expect = XTERM; /* e.g. print $fh .3 */ 3741 3823 else if ((*s == '?' || *s == '-' || *s == '+') 3742 && !isSPACE(s[1]) && s[1] != '=') 3743 9 PL_expect = XTERM; /* e.g. print $fh -1 */ 3744 3814 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/') 3745 2 PL_expect = XTERM; /* e.g. print $fh /.../ 3746 XXX except DORDOR operator */ 3747 3812 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=') 3748 555 PL_expect = XTERM; /* print $fh <<"EOF" */ 3749 } 3750 4494265 PL_pending_ident = '$'; 3751 4494265 TOKEN('$'); 3752 3753 case '@': 3754 640969 if (PL_expect == XOPERATOR) 3755 ###### no_op("Array", s); 3756 640969 PL_tokenbuf[0] = '@'; 3757 640969 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); 3758 640969 if (!PL_tokenbuf[1]) { 3759 79786 PREREF('@'); 3760 } 3761 561183 if (PL_lex_state == LEX_NORMAL) 3762 548980 s = skipspace(s); 3763 561183 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { 3764 499476 if (*s == '{') 3765 5644 PL_tokenbuf[0] = '%'; 3766 3767 /* Warn about @ where they meant $. */ 3768 499476 if (ckWARN(WARN_SYNTAX)) { 3769 170012 if (*s == '[' || *s == '{') { 3770 1597 const char *t = s + 1; 3771 4147 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t))) 3772 2550 t++; 3773 1597 if (*t == '}' || *t == ']') { 3774 11 t++; 3775 11 PL_bufptr = skipspace(PL_bufptr); 3776 11 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 3777 "Scalar value %.*s better written as $%.*s", 3778 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1); 3779 } 3780 } 3781 } 3782 } 3783 561183 PL_pending_ident = '@'; 3784 561183 TERM('@'); 3785 3786 case '/': /* may be division, defined-or, or pattern */ 3787 108884 if (PL_expect == XTERMORDORDOR && s[1] == '/') { 3788 10 s += 2; 3789 10 AOPERATOR(DORDOR); 3790 } 3791 case '?': /* may either be conditional or pattern */ 3792 201747 if(PL_expect == XOPERATOR) { 3793 97713 tmp = *s++; 3794 97713 if(tmp == '?') { 3795 92869 OPERATOR('?'); 3796 } 3797 else { 3798 4844 tmp = *s++; 3799 4844 if(tmp == '/') { 3800 /* A // operator. */ 3801 21 AOPERATOR(DORDOR); 3802 } 3803 else { 3804 4823 s--; 3805 4823 Mop(OP_DIVIDE); 3806 } 3807 } 3808 } 3809 else { 3810 /* Disable warning on "study /blah/" */ 3811 104034 if (PL_oldoldbufptr == PL_last_uni 3812 && (*PL_last_uni != 's' || s - PL_last_uni < 5 3813 || memNE(PL_last_uni, "study", 5) 3814 || isALNUM_lazy_if(PL_last_uni+5,UTF) 3815 )) 3816 ###### check_uni(); 3817 104034 s = scan_pat(s,OP_MATCH); 3818 104030 TERM(sublex_start()); 3819 } 3820 3821 case '.': 3822 139350 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack 3823 #ifdef PERL_STRICT_CR 3824 && s[1] == '\n' 3825 #else 3826 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n')) 3827 #endif 3828 && (s == PL_linestart || s[-1] == '\n') ) 3829 { 3830 ###### PL_lex_formbrack = 0; 3831 ###### PL_expect = XSTATE; 3832 ###### goto rightbracket; 3833 } 3834 139350 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) { 3835 139317 tmp = *s++; 3836 139317 if (*s == tmp) { 3837 7553 s++; 3838 7553 if (*s == tmp) { 3839 26 s++; 3840 26 yylval.ival = OPf_SPECIAL; 3841 } 3842 else 3843 7527 yylval.ival = 0; 3844 7553 OPERATOR(DOTDOT); 3845 } 3846 131764 if (PL_expect != XOPERATOR) 3847 4 check_uni(); 3848 131764 Aop(OP_CONCAT); 3849 } 3850 /* FALL THROUGH */ 3851 case '0': case '1': case '2': case '3': case '4': 3852 case '5': case '6': case '7': case '8': case '9': 3853 859883 s = scan_num(s, &yylval); 3854 DEBUG_T( { PerlIO_printf(Perl_debug_log, 3855 "### Saw number in '%s'\n", s); 3856 859881 } ); 3857 859881 if (PL_expect == XOPERATOR) 3858 5 no_op("Number",s); 3859 859881 TERM(THING); 3860 3861 case '\'': 3862 986727 s = scan_str(s,FALSE,FALSE); 3863 DEBUG_T( { PerlIO_printf(Perl_debug_log, 3864 "### Saw string before '%s'\n", s); 3865 986727 } ); 3866 986727 if (PL_expect == XOPERATOR) { 3867 2 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { 3868 2 PL_expect = XTERM; 3869 2 depcom(); 3870 2 return REPORT(','); /* grandfather non-comma-format format */ 3871 } 3872 else 3873 ###### no_op("String",s); 3874 } 3875 986725 if (!s) 3876 ###### missingterm((char*)0); 3877 986725 yylval.ival = OP_CONST; 3878 986725 TERM(sublex_start()); 3879 3880 case '"': 3881 762597 s = scan_str(s,FALSE,FALSE); 3882 DEBUG_T( { PerlIO_printf(Perl_debug_log, 3883 "### Saw string before '%s'\n", s); 3884 762597 } ); 3885 762597 if (PL_expect == XOPERATOR) { 3886 2 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { 3887 2 PL_expect = XTERM; 3888 2 depcom(); 3889 2 return REPORT(','); /* grandfather non-comma-format format */ 3890 } 3891 else 3892 ###### no_op("String",s); 3893 } 3894 762595 if (!s) 3895 ###### missingterm((char*)0); 3896 762595 yylval.ival = OP_CONST; 3897 /* FIXME. I think that this can be const if char *d is replaced by 3898 more localised variables. */ 3899 5677019 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) { 3900 5456001 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) { 3901 541577 yylval.ival = OP_STRINGIFY; 3902 541577 break; 3903 } 3904 } 3905 762595 TERM(sublex_start()); 3906 3907 case '`': 3908 2160 s = scan_str(s,FALSE,FALSE); 3909 DEBUG_T( { PerlIO_printf(Perl_debug_log, 3910 "### Saw backtick string before '%s'\n", s); 3911 2160 } ); 3912 2160 if (PL_expect == XOPERATOR) 3913 ###### no_op("Backticks",s); 3914 2160 if (!s) 3915 ###### missingterm((char*)0); 3916 2160 yylval.ival = OP_BACKTICK; 3917 2160 set_csh(); 3918 2160 TERM(sublex_start()); 3919 3920 case '\\': 3921 89292 s++; 3922 89292 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s)) 3923 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression", 3924 *s, *s); 3925 89292 if (PL_expect == XOPERATOR) 3926 ###### no_op("Backslash",s); 3927 89292 OPERATOR(REFGEN); 3928 3929 case 'v': 3930 47194 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) { 3931 1598 char *start = s + 2; 3932 1834 while (isDIGIT(*start) || *start == '_') 3933 236 start++; 3934 1598 if (*start == '.' && isDIGIT(start[1])) { 3935 1566 s = scan_num(s, &yylval); 3936 1566 TERM(THING); 3937 } 3938 /* avoid v123abc() or $h{v1}, allow C */ 3939 32 else if (!isALPHA(*start) && (PL_expect == XTERM 3940 || PL_expect == XREF || PL_expect == XSTATE 3941 || PL_expect == XTERMORDORDOR)) { 3942 32 const char c = *start; 3943 32 GV *gv; 3944 32 *start = '\0'; 3945 32 gv = gv_fetchpv(s, FALSE, SVt_PVCV); 3946 32 *start = c; 3947 32 if (!gv) { 3948 31 s = scan_num(s, &yylval); 3949 31 TERM(THING); 3950 } 3951 } 3952 } 3953 10296 goto keylookup; 3954 case 'x': 3955 10296 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) { 3956 126 s++; 3957 126 Mop(OP_REPEAT); 3958 } 3959 4471483 goto keylookup; 3960 3961 case '_': 3962 case 'a': case 'A': 3963 case 'b': case 'B': 3964 case 'c': case 'C': 3965 case 'd': case 'D': 3966 case 'e': case 'E': 3967 case 'f': case 'F': 3968 case 'g': case 'G': 3969 case 'h': case 'H': 3970 case 'i': case 'I': 3971 case 'j': case 'J': 3972 case 'k': case 'K': 3973 case 'l': case 'L': 3974 case 'm': case 'M': 3975 case 'n': case 'N': 3976 case 'o': case 'O': 3977 case 'p': case 'P': 3978 case 'q': case 'Q': 3979 case 'r': case 'R': 3980 case 's': case 'S': 3981 case 't': case 'T': 3982 case 'u': case 'U': 3983 case 'V': 3984 case 'w': case 'W': 3985 case 'X': 3986 case 'y': case 'Y': 3987 case 'z': case 'Z': 3988 3989 keylookup: { 3990 4471483 orig_keyword = 0; 3991 4471483 gv = Nullgv; 3992 4471483 gvp = 0; 3993 3994 4471483 PL_bufptr = s; 3995 4471483 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); 3996 3997 /* Some keywords can be followed by any delimiter, including ':' */ 3998 4471483 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) || 3999 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') || 4000 (PL_tokenbuf[0] == 'q' && 4001 strchr("qwxr", PL_tokenbuf[1]))))); 4002 4003 /* x::* is just a word, unless x is "CORE" */ 4004 4471483 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE")) 4005 116039 goto just_a_word; 4006 4007 4355444 d = s; 4008 7892199 while (d < PL_bufend && isSPACE(*d)) 4009 3536755 d++; /* no comments skipped here, or s### is misparsed */ 4010 4011 /* Is this a label? */ 4012 4355444 if (!tmp && PL_expect == XSTATE 4013 && d < PL_bufend && *d == ':' && *(d + 1) != ':') { 4014 7104 s = d + 1; 4015 7104 yylval.pval = savepv(PL_tokenbuf); 4016 7104 CLINE; 4017 7104 TOKEN(LABEL); 4018 } 4019 4020 /* Check for keywords */ 4021 4348340 tmp = keyword(PL_tokenbuf, len); 4022 4023 /* Is this a word before a => operator? */ 4024 4348340 if (*d == '=' && d[1] == '>') { 4025 128987 CLINE; 4026 128987 yylval.opval 4027 = (OP*)newSVOP(OP_CONST, 0, 4028 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len)); 4029 128987 yylval.opval->op_private = OPpCONST_BARE; 4030 128987 TERM(WORD); 4031 } 4032 4033 4219353 if (tmp < 0) { /* second-class keyword? */ 4034 909147 GV *ogv = Nullgv; /* override (winner) */ 4035 909147 GV *hgv = Nullgv; /* hidden (loser) */ 4036 909147 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) { 4037 593990 CV *cv; 4038 593990 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) && 4039 (cv = GvCVu(gv))) 4040 { 4041 1547 if (GvIMPORTED_CV(gv)) 4042 289 ogv = gv; 4043 1258 else if (! CvMETHOD(cv)) 4044 1258 hgv = gv; 4045 } 4046 593990 if (!ogv && 4047 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) && 4048 (gv = *gvp) != (GV*)&PL_sv_undef && 4049 GvCVu(gv) && GvIMPORTED_CV(gv)) 4050 { 4051 8 ogv = gv; 4052 } 4053 } 4054 909147 if (ogv) { 4055 297 orig_keyword = tmp; 4056 297 tmp = 0; /* overridden by import or by GLOBAL */ 4057 } 4058 908850 else if (gv && !gvp 4059 && -tmp==KEY_lock /* XXX generalizable kludge */ 4060 && GvCVu(gv) 4061 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE)) 4062 { 4063 1248 tmp = 0; /* any sub overrides "weak" keyword */ 4064 } 4065 907602 else if (gv && !gvp 4066 && tmp == -KEY_err 4067 && GvCVu(gv) 4068 && PL_expect != XOPERATOR 4069 && PL_expect != XTERMORDORDOR) 4070 { 4071 /* any sub overrides the "err" keyword, except when really an 4072 * operator is expected */ 4073 4 tmp = 0; 4074 } 4075 else { /* no override */ 4076 907598 tmp = -tmp; 4077 907598 if (tmp == KEY_dump && ckWARN(WARN_MISC)) { 4078 1 Perl_warner(aTHX_ packWARN(WARN_MISC), 4079 "dump() better written as CORE::dump()"); 4080 } 4081 907598 gv = Nullgv; 4082 907598 gvp = 0; 4083 907598 if (ckWARN(WARN_AMBIGUOUS) && hgv 4084 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */ 4085 1 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), 4086 "Ambiguous call resolved as CORE::%s(), %s", 4087 GvENAME(hgv), "qualify as such or use &"); 4088 } 4089 } 4090 4091 reserved_word: 4092 4224384 switch (tmp) { 4093 4094 default: /* not a keyword */ 4095 just_a_word: { 4096 468471 SV *sv; 4097 468471 int pkgname = 0; 4098 468471 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); 4099 4100 /* Get the rest if it looks like a package qualifier */ 4101 4102 468471 if (*s == '\'' || (*s == ':' && s[1] == ':')) { 4103 116193 STRLEN morelen; 4104 116193 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len, 4105 TRUE, &morelen); 4106 116193 if (!morelen) 4107 ###### Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf, 4108 *s == '\'' ? "'" : "::"); 4109 116193 len += morelen; 4110 116193 pkgname = 1; 4111 } 4112 4113 468471 if (PL_expect == XOPERATOR) { 4114 11 if (PL_bufptr == PL_linestart) { 4115 1 CopLINE_dec(PL_curcop); 4116 1 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi); 4117 1 CopLINE_inc(PL_curcop); 4118 } 4119 else 4120 10 no_op("Bareword",s); 4121 } 4122 4123 /* Look for a subroutine with this name in current package, 4124 unless name is "Foo::", in which case Foo is a bearword 4125 (and a package name). */ 4126 4127 468471 if (len > 2 && 4128 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':') 4129 { 4130 18 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV)) 4131 1 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), 4132 "Bareword \"%s\" refers to nonexistent package", 4133 PL_tokenbuf); 4134 18 len -= 2; 4135 18 PL_tokenbuf[len] = '\0'; 4136 18 gv = Nullgv; 4137 18 gvp = 0; 4138 } 4139 else { 4140 468453 len = 0; 4141 468453 if (!gv) 4142 466904 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV); 4143 } 4144 4145 /* if we saw a global override before, get the right name */ 4146 4147 468471 if (gvp) { 4148 8 sv = newSVpvn("CORE::GLOBAL::",14); 4149 8 sv_catpv(sv,PL_tokenbuf); 4150 } 4151 else { 4152 /* If len is 0, newSVpv does strlen(), which is correct. 4153 If len is non-zero, then it will be the true length, 4154 and so the scalar will be created correctly. */ 4155 468463 sv = newSVpv(PL_tokenbuf,len); 4156 } 4157 4158 /* Presume this is going to be a bareword of some sort. */ 4159 4160 468471 CLINE; 4161 468471 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); 4162 468471 yylval.opval->op_private = OPpCONST_BARE; 4163 /* UTF-8 package name? */ 4164 468471 if (UTF && !IN_BYTES && 4165 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv))) 4166 213 SvUTF8_on(sv); 4167 4168 /* And if "Foo::", then that's what it certainly is. */ 4169 4170 468471 if (len) 4171 18 goto safe_bareword; 4172 4173 /* See if it's the indirect object for a list operator. */ 4174 4175 468453 if (PL_oldoldbufptr && 4176 PL_oldoldbufptr < PL_bufptr && 4177 (PL_oldoldbufptr == PL_last_lop 4178 || PL_oldoldbufptr == PL_last_uni) && 4179 /* NO SKIPSPACE BEFORE HERE! */ 4180 (PL_expect == XREF || 4181 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF)) 4182 { 4183 49436 bool immediate_paren = *s == '('; 4184 4185 /* (Now we can afford to cross potential line boundary.) */ 4186 49436 s = skipspace(s); 4187 4188 /* Two barewords in a row may indicate method call. */ 4189 4190 49436 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv))) 4191 ###### return REPORT(tmp); 4192 4193 /* If not a declared subroutine, it's an indirect object. */ 4194 /* (But it's an indir obj regardless for sort.) */ 4195 4196 49436 if ( !immediate_paren && (PL_last_lop_op == OP_SORT || 4197 ((!gv || !GvCVu(gv)) && 4198 (PL_last_lop_op != OP_MAPSTART && 4199 PL_last_lop_op != OP_GREPSTART)))) 4200 { 4201 46683 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR; 4202 46683 goto bareword; 4203 } 4204 } 4205 4206 421770 PL_expect = XOPERATOR; 4207 421770 s = skipspace(s); 4208 4209 /* Is this a word before a => operator? */ 4210 421770 if (*s == '=' && s[1] == '>' && !pkgname) { 4211 11 CLINE; 4212 11 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf); 4213 11 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len)) 4214 ###### SvUTF8_on(((SVOP*)yylval.opval)->op_sv); 4215 11 TERM(WORD); 4216 } 4217 4218 /* If followed by a paren, it's certainly a subroutine. */ 4219 421759 if (*s == '(') { 4220 315755 CLINE; 4221 315755 if (gv && GvCVu(gv)) { 4222 206469 for (d = s + 1; SPACE_OR_TAB(*d); d++) ; 4223 206469 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) { 4224 157 s = d + 1; 4225 157 goto its_constant; 4226 } 4227 } 4228 315598 PL_nextval[PL_nexttoke].opval = yylval.opval; 4229 315598 PL_expect = XOPERATOR; 4230 315598 force_next(WORD); 4231 315598 yylval.ival = 0; 4232 315598 TOKEN('&'); 4233 } 4234 4235 /* If followed by var or block, call it a method (unless sub) */ 4236 4237 106004 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) { 4238 57 PL_last_lop = PL_oldbufptr; 4239 57 PL_last_lop_op = OP_METHOD; 4240 57 PREBLOCK(METHOD); 4241 } 4242 4243 /* If followed by a bareword, see if it looks like indir obj. */ 4244 4245 105947 if (!orig_keyword 4246 && (isIDFIRST_lazy_if(s,UTF) || *s == '$') 4247 && (tmp = intuit_method(s,gv))) 4248 5390 return REPORT(tmp); 4249 4250 /* Not a method, so call it a subroutine (if defined) */ 4251 4252 100557 if (gv && GvCVu(gv)) { 4253 66213 CV* cv; 4254 66213 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS)) 4255 5 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), 4256 "Ambiguous use of -%s resolved as -&%s()", 4257 PL_tokenbuf, PL_tokenbuf); 4258 /* Check for a constant sub */ 4259 66213 cv = GvCV(gv); 4260 66213 if ((sv = cv_const_sv(cv))) { 4261 its_constant: 4262 19211 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv); 4263 19211 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv); 4264 19211 yylval.opval->op_private = 0; 4265 19211 TOKEN(WORD); 4266 } 4267 4268 /* Resolve to GV now. */ 4269 47159 op_free(yylval.opval); 4270 47159 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); 4271 47159 yylval.opval->op_private |= OPpENTERSUB_NOPAREN; 4272 47159 PL_last_lop = PL_oldbufptr; 4273 47159 PL_last_lop_op = OP_ENTERSUB; 4274 /* Is there a prototype? */ 4275 47159 if (SvPOK(cv)) { 4276 4263 STRLEN len; 4277 4263 const char *proto = SvPV_const((SV*)cv, len); 4278 4263 if (!len) 4279 1276 TERM(FUNC0SUB); 4280 2987 if (*proto == '$' && proto[1] == '\0') 4281 582 OPERATOR(UNIOPSUB); 4282 2436 while (*proto == ';') 4283 31 proto++; 4284 2405 if (*proto == '&' && *s == '{') { 4285 547 sv_setpv(PL_subname, PL_curstash ? 4286 "__ANON__" : "__ANON__::__ANON__"); 4287 547 PREBLOCK(LSTOPSUB); 4288 } 4289 } 4290 44754 PL_nextval[PL_nexttoke].opval = yylval.opval; 4291 44754 PL_expect = XTERM; 4292 44754 force_next(WORD); 4293 44754 TOKEN(NOAMP); 4294 } 4295 4296 /* Call it a bare word */ 4297 4298 34344 if (PL_hints & HINT_STRICT_SUBS) 4299 26902 yylval.opval->op_private |= OPpCONST_STRICT; 4300 else { 4301 bareword: 4302 54125 if (ckWARN(WARN_RESERVED)) { 4303 22343 if (lastchar != '-') { 4304 22342 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ; 4305 22342 if (!*d && !gv_stashpv(PL_tokenbuf,FALSE)) 4306 1 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved, 4307 PL_tokenbuf); 4308 } 4309 } 4310 } 4311 4312 safe_bareword: 4313 81045 if ((lastchar == '*' || lastchar == '%' || lastchar == '&') 4314 && ckWARN_d(WARN_AMBIGUOUS)) { 4315 3 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), 4316 "Operator or semicolon missing before %c%s", 4317 lastchar, PL_tokenbuf); 4318 3 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), 4319 "Ambiguous use of %c resolved as operator %c", 4320 lastchar, lastchar); 4321 } 4322 81045 TOKEN(WORD); 4323 } 4324 4325 case KEY___FILE__: 4326 260 yylval.opval = (OP*)newSVOP(OP_CONST, 0, 4327 newSVpv(CopFILE(PL_curcop),0)); 4328 260 TERM(THING); 4329 4330 case KEY___LINE__: 4331 116 yylval.opval = (OP*)newSVOP(OP_CONST, 0, 4332 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop))); 4333 116 TERM(THING); 4334 4335 case KEY___PACKAGE__: 4336 4972 yylval.opval = (OP*)newSVOP(OP_CONST, 0, 4337 (PL_curstash 4338 ? newSVhek(HvNAME_HEK(PL_curstash)) 4339 : &PL_sv_undef)); 4340 4972 TERM(THING); 4341 4342 case KEY___DATA__: 4343 case KEY___END__: { 4344 15515 GV *gv; 4345 15515 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) { 4346 284 const char *pname = "main"; 4347 284 if (PL_tokenbuf[2] == 'D') 4348 128 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash); 4349 284 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO); 4350 284 GvMULTI_on(gv); 4351 284 if (!GvIO(gv)) 4352 ###### GvIOp(gv) = newIO(); 4353 284 IoIFP(GvIOp(gv)) = PL_rsfp; 4354 #if defined(HAS_FCNTL) && defined(F_SETFD) 4355 { 4356 284 const int fd = PerlIO_fileno(PL_rsfp); 4357 284 fcntl(fd,F_SETFD,fd >= 3); 4358 } 4359 #endif 4360 /* Mark this internal pseudo-handle as clean */ 4361 284 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT; 4362 284 if (PL_preprocess) 4363 ###### IoTYPE(GvIOp(gv)) = IoTYPE_PIPE; 4364 284 else if ((PerlIO*)PL_rsfp == PerlIO_stdin()) 4365 ###### IoTYPE(GvIOp(gv)) = IoTYPE_STD; 4366 else 4367 284 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY; 4368 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS) 4369 /* if the script was opened in binmode, we need to revert 4370 * it to text mode for compatibility; but only iff it has CRs 4371 * XXX this is a questionable hack at best. */ 4372 if (PL_bufend-PL_bufptr > 2 4373 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r') 4374 { 4375 Off_t loc = 0; 4376 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) { 4377 loc = PerlIO_tell(PL_rsfp); 4378 (void)PerlIO_seek(PL_rsfp, 0L, 0); 4379 } 4380 #ifdef NETWARE 4381 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) { 4382 #else 4383 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) { 4384 #endif /* NETWARE */ 4385 #ifdef PERLIO_IS_STDIO /* really? */ 4386 # if defined(__BORLANDC__) 4387 /* XXX see note in do_binmode() */ 4388 ((FILE*)PL_rsfp)->flags &= ~_F_BIN; 4389 # endif 4390 #endif 4391 if (loc > 0) 4392 PerlIO_seek(PL_rsfp, loc, 0); 4393 } 4394 } 4395 #endif 4396 #ifdef PERLIO_LAYERS 4397 284 if (!IN_BYTES) { 4398 283 if (UTF) 4399 2 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8"); 4400 281 else if (PL_encoding) { 4401 7 SV *name; 4402 7 dSP; 4403 7 ENTER; 4404 7 SAVETMPS; 4405 7 PUSHMARK(sp); 4406 7 EXTEND(SP, 1); 4407 7 XPUSHs(PL_encoding); 4408 7 PUTBACK; 4409 7 call_method("name", G_SCALAR); 4410 7 SPAGAIN; 4411 7 name = POPs; 4412 7 PUTBACK; 4413 7 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, 4414 Perl_form(aTHX_ ":encoding(%"SVf")", 4415 name)); 4416 7 FREETMPS; 4417 7 LEAVE; 4418 } 4419 } 4420 #endif 4421 284 PL_rsfp = Nullfp; 4422 } 4423 284 goto fake_eof; 4424 } 4425 4426 case KEY_AUTOLOAD: 4427 case KEY_DESTROY: 4428 case KEY_BEGIN: 4429 case KEY_CHECK: 4430 case KEY_INIT: 4431 case KEY_END: 4432 7231 if (PL_expect == XSTATE) { 4433 7230 s = PL_bufptr; 4434 7230 goto really_sub; 4435 } 4436 5031 goto just_a_word; 4437 4438 case KEY_CORE: 4439 5031 if (*s == ':' && s[1] == ':') { 4440 5031 s += 2; 4441 5031 d = s; 4442 5031 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); 4443 5031 if (!(tmp = keyword(PL_tokenbuf, len))) 4444 ###### Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf); 4445 5031 if (tmp < 0) 4446 5002 tmp = -tmp; 4447 5002 goto reserved_word; 4448 } 4449 1934 goto just_a_word; 4450 4451 case KEY_abs: 4452 1934 UNI(OP_ABS); 4453 4454 case KEY_alarm: 4455 37 UNI(OP_ALARM); 4456 4457 case KEY_accept: 4458 16 LOP(OP_ACCEPT,XTERM); 4459 4460 case KEY_and: 4461 45343 OPERATOR(ANDOP); 4462 4463 case KEY_atan2: 4464 166 LOP(OP_ATAN2,XTERM); 4465 4466 case KEY_bind: 4467 56 LOP(OP_BIND,XTERM); 4468 4469 case KEY_binmode: 4470 2454 LOP(OP_BINMODE,XTERM); 4471 4472 case KEY_bless: 4473 5926 LOP(OP_BLESS,XTERM); 4474 4475 case KEY_chop: 4476 2247 UNI(OP_CHOP); 4477 4478 case KEY_continue: 4479 756 PREBLOCK(CONTINUE); 4480 4481 case KEY_chdir: 4482 4374 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */ 4483 4374 UNI(OP_CHDIR); 4484 4485 case KEY_close: 4486 11032 UNI(OP_CLOSE); 4487 4488 case KEY_closedir: 4489 2635 UNI(OP_CLOSEDIR); 4490 4491 case KEY_cmp: 4492 3231 Eop(OP_SCMP); 4493 4494 case KEY_caller: 4495 32088 UNI(OP_CALLER); 4496 4497 case KEY_crypt: 4498 #ifdef FCRYPT 4499 if (!PL_cryptseen) { 4500 PL_cryptseen = TRUE; 4501 init_des(); 4502 } 4503 #endif 4504 9 LOP(OP_CRYPT,XTERM); 4505 4506 case KEY_chmod: 4507 4536 LOP(OP_CHMOD,XTERM); 4508 4509 case KEY_chown: 4510 5 LOP(OP_CHOWN,XTERM); 4511 4512 case KEY_connect: 4513 84 LOP(OP_CONNECT,XTERM); 4514 4515 case KEY_chr: 4516 1454 UNI(OP_CHR); 4517 4518 case KEY_cos: 4519 168 UNI(OP_COS); 4520 4521 case KEY_chroot: 4522 2 UNI(OP_CHROOT); 4523 4524 case KEY_do: 4525 17147 s = skipspace(s); 4526 17147 if (*s == '{') 4527 16029 PRETERMBLOCK(DO); 4528 1118 if (*s != '\'') 4529 1015 s = force_word(s,WORD,TRUE,TRUE,FALSE); 4530 1118 OPERATOR(DO); 4531 4532 case KEY_die: 4533 29596 PL_hints |= HINT_BLOCK_SCOPE; 4534 29596 LOP(OP_DIE,XTERM); 4535 4536 case KEY_defined: 4537 122592 UNI(OP_DEFINED); 4538 4539 case KEY_delete: 4540 10834 UNI(OP_DELETE); 4541 4542 case KEY_dbmopen: 4543 2 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV); 4544 2 LOP(OP_DBMOPEN,XTERM); 4545 4546 case KEY_dbmclose: 4547 2 UNI(OP_DBMCLOSE); 4548 4549 case KEY_dump: 4550 3 s = force_word(s,WORD,TRUE,FALSE,FALSE); 4551 3 LOOPX(OP_DUMP); 4552 4553 case KEY_else: 4554 97851 PREBLOCK(ELSE); 4555 4556 case KEY_elsif: 4557 67708 yylval.ival = CopLINE(PL_curcop); 4558 67708 OPERATOR(ELSIF); 4559 4560 case KEY_eq: 4561 163908 Eop(OP_SEQ); 4562 4563 case KEY_exists: 4564 23185 UNI(OP_EXISTS); 4565 4566 case KEY_exit: 4567 3486 UNI(OP_EXIT); 4568 4569 case KEY_eval: 4570 22067 s = skipspace(s); 4571 22067 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM; 4572 22067 UNIBRACK(OP_ENTEREVAL); 4573 4574 case KEY_eof: 4575 385 UNI(OP_EOF); 4576 4577 case KEY_err: 4578 10 OPERATOR(DOROP); 4579 4580 case KEY_exp: 4581 195 UNI(OP_EXP); 4582 4583 case KEY_each: 4584 2335 UNI(OP_EACH); 4585 4586 case KEY_exec: 4587 385 set_csh(); 4588 385 LOP(OP_EXEC,XREF); 4589 4590 case KEY_endhostent: 4591 1 FUN0(OP_EHOSTENT); 4592 4593 case KEY_endnetent: 4594 1 FUN0(OP_ENETENT); 4595 4596 case KEY_endservent: 4597 1 FUN0(OP_ESERVENT); 4598 4599 case KEY_endprotoent: 4600 1 FUN0(OP_EPROTOENT); 4601 4602 case KEY_endpwent: 4603 5 FUN0(OP_EPWENT); 4604 4605 case KEY_endgrent: 4606 4 FUN0(OP_EGRENT); 4607 4608 case KEY_for: 4609 case KEY_foreach: 4610 76905 yylval.ival = CopLINE(PL_curcop); 4611 76905 s = skipspace(s); 4612 76905 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) { 4613 33297 char *p = s; 4614 33297 if ((PL_bufend - p) >= 3 && 4615 strnEQ(p, "my", 2) && isSPACE(*(p + 2))) 4616 33290 p += 2; 4617 7 else if ((PL_bufend - p) >= 4 && 4618 strnEQ(p, "our", 3) && isSPACE(*(p + 3))) 4619 7 p += 3; 4620 33297 p = skipspace(p); 4621 33297 if (isIDFIRST_lazy_if(p,UTF)) { 4622 ###### p = scan_ident(p, PL_bufend, 4623 PL_tokenbuf, sizeof PL_tokenbuf, TRUE); 4624 ###### p = skipspace(p); 4625 } 4626 33297 if (*p != '$') 4627 ###### Perl_croak(aTHX_ "Missing $ on loop variable"); 4628 } 4629 76905 OPERATOR(FOR); 4630 4631 case KEY_formline: 4632 99 LOP(OP_FORMLINE,XTERM); 4633 4634 case KEY_fork: 4635 70 FUN0(OP_FORK); 4636 4637 case KEY_fcntl: 4638 119 LOP(OP_FCNTL,XTERM); 4639 4640 case KEY_fileno: 4641 855 UNI(OP_FILENO); 4642 4643 case KEY_flock: 4644 68 LOP(OP_FLOCK,XTERM); 4645 4646 case KEY_gt: 4647 79 Rop(OP_SGT); 4648 4649 case KEY_ge: 4650 5579 Rop(OP_SGE); 4651 4652 case KEY_grep: 4653 13071 LOP(OP_GREPSTART, XREF); 4654 4655 case KEY_goto: 4656 38125 s = force_word(s,WORD,TRUE,FALSE,FALSE); 4657 38125 LOOPX(OP_GOTO); 4658 4659 case KEY_gmtime: 4660 222 UNI(OP_GMTIME); 4661 4662 case KEY_getc: 4663 130 UNIDOR(OP_GETC); 4664 4665 case KEY_getppid: 4666 8 FUN0(OP_GETPPID); 4667 4668 case KEY_getpgrp: 4669 5 UNI(OP_GETPGRP); 4670 4671 case KEY_getpriority: 4672 5 LOP(OP_GETPRIORITY,XTERM); 4673 4674 case KEY_getprotobyname: 4675 82 UNI(OP_GPBYNAME); 4676 4677 case KEY_getprotobynumber: 4678 15 LOP(OP_GPBYNUMBER,XTERM); 4679 4680 case KEY_getprotoent: 4681 4 FUN0(OP_GPROTOENT); 4682 4683 case KEY_getpwent: 4684 6 FUN0(OP_GPWENT); 4685 4686 case KEY_getpwnam: 4687 103 UNI(OP_GPWNAM); 4688 4689 case KEY_getpwuid: 4690 130 UNI(OP_GPWUID); 4691 4692 case KEY_getpeername: 4693 62 UNI(OP_GETPEERNAME); 4694 4695 case KEY_gethostbyname: 4696 37 UNI(OP_GHBYNAME); 4697 4698 case KEY_gethostbyaddr: 4699 9 LOP(OP_GHBYADDR,XTERM); 4700 4701 case KEY_gethostent: 4702 3 FUN0(OP_GHOSTENT); 4703 4704 case KEY_getnetbyname: 4705 5 UNI(OP_GNBYNAME); 4706 4707 case KEY_getnetbyaddr: 4708 3 LOP(OP_GNBYADDR,XTERM); 4709 4710 case KEY_getnetent: 4711 3 FUN0(OP_GNETENT); 4712 4713 case KEY_getservbyname: 4714 69 LOP(OP_GSBYNAME,XTERM); 4715 4716 case KEY_getservbyport: 4717 4 LOP(OP_GSBYPORT,XTERM); 4718 4719 case KEY_getservent: 4720 4 FUN0(OP_GSERVENT); 4721 4722 case KEY_getsockname: 4723 18 UNI(OP_GETSOCKNAME); 4724 4725 case KEY_getsockopt: 4726 26 LOP(OP_GSOCKOPT,XTERM); 4727 4728 case KEY_getgrent: 4729 4 FUN0(OP_GGRENT); 4730 4731 case KEY_getgrnam: 4732 5 UNI(OP_GGRNAM); 4733 4734 case KEY_getgrgid: 4735 17 UNI(OP_GGRGID); 4736 4737 case KEY_getlogin: 4738 4 FUN0(OP_GETLOGIN); 4739 4740 case KEY_glob: 4741 496 set_csh(); 4742 496 LOP(OP_GLOB,XTERM); 4743 4744 case KEY_hex: 4745 1076 UNI(OP_HEX); 4746 4747 case KEY_if: 4748 449054 yylval.ival = CopLINE(PL_curcop); 4749 449054 OPERATOR(IF); 4750 4751 case KEY_index: 4752 4526 LOP(OP_INDEX,XTERM); 4753 4754 case KEY_int: 4755 4843 UNI(OP_INT); 4756 4757 case KEY_ioctl: 4758 105 LOP(OP_IOCTL,XTERM); 4759 4760 case KEY_join: 4761 23488 LOP(OP_JOIN,XTERM); 4762 4763 case KEY_keys: 4764 18330 UNI(OP_KEYS); 4765 4766 case KEY_kill: 4767 100 LOP(OP_KILL,XTERM); 4768 4769 case KEY_last: 4770 23012 s = force_word(s,WORD,TRUE,FALSE,FALSE); 4771 23012 LOOPX(OP_LAST); 4772 4773 case KEY_lc: 4774 3677 UNI(OP_LC); 4775 4776 case KEY_lcfirst: 4777 14 UNI(OP_LCFIRST); 4778 4779 case KEY_local: 4780 51078 yylval.ival = 0; 4781 51078 OPERATOR(LOCAL); 4782 4783 case KEY_length: 4784 22580 UNI(OP_LENGTH); 4785 4786 case KEY_lt: 4787 193 Rop(OP_SLT); 4788 4789 case KEY_le: 4790 3754 Rop(OP_SLE); 4791 4792 case KEY_localtime: 4793 573 UNI(OP_LOCALTIME); 4794 4795 case KEY_log: 4796 191 UNI(OP_LOG); 4797 4798 case KEY_link: 4799 39 LOP(OP_LINK,XTERM); 4800 4801 case KEY_listen: 4802 16 LOP(OP_LISTEN,XTERM); 4803 4804 case KEY_lock: 4805 1 UNI(OP_LOCK); 4806 4807 case KEY_lstat: 4808 2649 UNI(OP_LSTAT); 4809 4810 case KEY_m: 4811 29770 s = scan_pat(s,OP_MATCH); 4812 29764 TERM(sublex_start()); 4813 4814 case KEY_map: 4815 19639 LOP(OP_MAPSTART, XREF); 4816 4817 case KEY_mkdir: 4818 681 LOP(OP_MKDIR,XTERM); 4819 4820 case KEY_msgctl: 4821 7 LOP(OP_MSGCTL,XTERM); 4822 4823 case KEY_msgget: 4824 4 LOP(OP_MSGGET,XTERM); 4825 4826 case KEY_msgrcv: 4827 4 LOP(OP_MSGRCV,XTERM); 4828 4829 case KEY_msgsnd: 4830 4 LOP(OP_MSGSND,XTERM); 4831 4832 case KEY_our: 4833 case KEY_my: 4834 640466 PL_in_my = tmp; 4835 640466 s = skipspace(s); 4836 640466 if (isIDFIRST_lazy_if(s,UTF)) { 4837 30 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); 4838 30 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3)) 4839 ###### goto really_sub; 4840 30 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len); 4841 30 if (!PL_in_my_stash) { 4842 3 char tmpbuf[1024]; 4843 3 PL_bufptr = s; 4844 3 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf); 4845 3 yyerror(tmpbuf); 4846 } 4847 } 4848 640466 yylval.ival = 1; 4849 640466 OPERATOR(MY); 4850 4851 case KEY_next: 4852 29686 s = force_word(s,WORD,TRUE,FALSE,FALSE); 4853 29686 LOOPX(OP_NEXT); 4854 4855 case KEY_ne: 4856 25453 Eop(OP_SNE); 4857 4858 case KEY_no: 4859 12055 if (PL_expect != XSTATE) 4860 ###### yyerror("\"no\" not allowed in expression"); 4861 12055 s = force_word(s,WORD,FALSE,TRUE,FALSE); 4862 12055 s = force_version(s, FALSE); 4863 12055 yylval.ival = 0; 4864 12055 OPERATOR(USE); 4865 4866 case KEY_not: 4867 18568 if (*s == '(' || (s = skipspace(s), *s == '(')) 4868 9375 FUN1(OP_NOT); 4869 else 4870 9193 OPERATOR(NOTOP); 4871 4872 case KEY_open: 4873 10448 s = skipspace(s); 4874 10448 if (isIDFIRST_lazy_if(s,UTF)) { 4875 2130 const char *t; 4876 2130 for (d = s; isALNUM_lazy_if(d,UTF); d++) ; 4877 2130 for (t=d; *t && isSPACE(*t); t++) ; 4878 2130 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE) 4879 /* [perl #16184] */ 4880 && !(t[0] == '=' && t[1] == '>') 4881 ) { 4882 4 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE), 4883 "Precedence problem: open %.*s should be open(%.*s)", 4884 d - s, s, d - s, s); 4885 } 4886 } 4887 10448 LOP(OP_OPEN,XTERM); 4888 4889 case KEY_or: 4890 54424 yylval.ival = OP_OR; 4891 54424 OPERATOR(OROP); 4892 4893 case KEY_ord: 4894 3574 UNI(OP_ORD); 4895 4896 case KEY_oct: 4897 953 UNI(OP_OCT); 4898 4899 case KEY_opendir: 4900 1936 LOP(OP_OPEN_DIR,XTERM); 4901 4902 case KEY_print: 4903 60989 checkcomma(s,PL_tokenbuf,"filehandle"); 4904 60989 LOP(OP_PRINT,XREF); 4905 4906 case KEY_printf: 4907 1059 checkcomma(s,PL_tokenbuf,"filehandle"); 4908 1059 LOP(OP_PRTF,XREF); 4909 4910 case KEY_prototype: 4911 188 UNI(OP_PROTOTYPE); 4912 4913 case KEY_push: 4914 53718 LOP(OP_PUSH,XTERM); 4915 4916 case KEY_pop: 4917 9438 UNIDOR(OP_POP); 4918 4919 case KEY_pos: 4920 2471 UNIDOR(OP_POS); 4921 4922 case KEY_pack: 4923 2209 LOP(OP_PACK,XTERM); 4924 4925 case KEY_package: 4926 39129 s = force_word(s,WORD,FALSE,TRUE,FALSE); 4927 39129 OPERATOR(PACKAGE); 4928 4929 case KEY_pipe: 4930 70 LOP(OP_PIPE_OP,XTERM); 4931 4932 case KEY_q: 4933 7311 s = scan_str(s,FALSE,FALSE); 4934 7311 if (!s) 4935 1 missingterm((char*)0); 4936 7310 yylval.ival = OP_CONST; 4937 7310 TERM(sublex_start()); 4938 4939 case KEY_quotemeta: 4940 506 UNI(OP_QUOTEMETA); 4941 4942 case KEY_qw: 4943 54440 s = scan_str(s,FALSE,FALSE); 4944 54440 if (!s) 4945 1 missingterm((char*)0); 4946 54439 PL_expect = XOPERATOR; 4947 54439 force_next(')'); 4948 54439 if (SvCUR(PL_lex_stuff)) { 4949 54324 OP *words = Nullop; 4950 54324 int warned = 0; 4951 54324 d = SvPV_force(PL_lex_stuff, len); 4952 426014 while (len) { 4953 1069312 SV *sv; 4954 1069312 for (; isSPACE(*d) && len; --len, ++d) ; 4955 371690 if (len) { 4956 364094 const char *b = d; 4957 364094 if (!warned && ckWARN(WARN_QW)) { 4958 1469384 for (; !isSPACE(*d) && len; --len, ++d) { 4959 688436 if (*d == ',') { 4960 1 Perl_warner(aTHX_ packWARN(WARN_QW), 4961 "Possible attempt to separate words with commas"); 4962 1 ++warned; 4963 } 4964 688435 else if (*d == '#') { 4965 1 Perl_warner(aTHX_ packWARN(WARN_QW), 4966 "Possible attempt to put comments in qw() list"); 4967 1 ++warned; 4968 } 4969 } 4970 } 4971 else { 4972 2561711 for (; !isSPACE(*d) && len; --len, ++d) ; 4973 } 4974 364094 sv = newSVpvn(b, d-b); 4975 364094 if (DO_UTF8(PL_lex_stuff)) 4976 5 SvUTF8_on(sv); 4977 364094 words = append_elem(OP_LIST, words, 4978 newSVOP(OP_CONST, 0, tokeq(sv))); 4979 } 4980 } 4981 54324 if (words) { 4982 54290 PL_nextval[PL_nexttoke].opval = words; 4983 54290 force_next(THING); 4984 } 4985 } 4986 54439 if (PL_lex_stuff) { 4987 54439 SvREFCNT_dec(PL_lex_stuff); 4988 54439 PL_lex_stuff = Nullsv; 4989 } 4990 54439 PL_expect = XTERM; 4991 54439 TOKEN('('); 4992 4993 case KEY_qq: 4994 14049 s = scan_str(s,FALSE,FALSE); 4995 14049 if (!s) 4996 1 missingterm((char*)0); 4997 14048 yylval.ival = OP_STRINGIFY; 4998 14048 if (SvIVX(PL_lex_stuff) == '\'') 4999 12 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */ 5000 14048 TERM(sublex_start()); 5001 5002 case KEY_qr: 5003 9659 s = scan_pat(s,OP_QR); 5004 9652 TERM(sublex_start()); 5005 5006 case KEY_qx: 5007 21 s = scan_str(s,FALSE,FALSE); 5008 21 if (!s) 5009 1 missingterm((char*)0); 5010 20 yylval.ival = OP_BACKTICK; 5011 20 set_csh(); 5012 20 TERM(sublex_start()); 5013 5014 case KEY_return: 5015 193588 OLDLOP(OP_RETURN); 5016 5017 case KEY_require: 5018 84668 s = skipspace(s); 5019 84668 if (isDIGIT(*s)) { 5020 3663 s = force_version(s, FALSE); 5021 } 5022 81005 else if (*s != 'v' || !isDIGIT(s[1]) 5023 || (s = force_version(s, TRUE), *s == 'v')) 5024 { 5025 81002 *PL_tokenbuf = '\0'; 5026 81002 s = force_word(s,WORD,TRUE,TRUE,FALSE); 5027 81002 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF)) 5028 74948 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE); 5029 6054 else if (*s == '<') 5030 ###### yyerror("<> should be quotes"); 5031 } 5032 84668 UNI(OP_REQUIRE); 5033 5034 case KEY_reset: 5035 13 UNI(OP_RESET); 5036 5037 case KEY_redo: 5038 2978 s = force_word(s,WORD,TRUE,FALSE,FALSE); 5039 2978 LOOPX(OP_REDO); 5040 5041 case KEY_rename: 5042 1202 LOP(OP_RENAME,XTERM); 5043 5044 case KEY_rand: 5045 174 UNI(OP_RAND); 5046 5047 case KEY_rmdir: 5048 638 UNI(OP_RMDIR); 5049 5050 case KEY_rindex: 5051 389 LOP(OP_RINDEX,XTERM); 5052 5053 case KEY_read: 5054 1792 LOP(OP_READ,XTERM); 5055 5056 case KEY_readdir: 5057 2514 UNI(OP_READDIR); 5058 5059 case KEY_readline: 5060 27 set_csh(); 5061 27 UNIDOR(OP_READLINE); 5062 5063 case KEY_readpipe: 5064 ###### set_csh(); 5065 ###### UNI(OP_BACKTICK); 5066 5067 case KEY_rewinddir: 5068 100 UNI(OP_REWINDDIR); 5069 5070 case KEY_recv: 5071 32 LOP(OP_RECV,XTERM); 5072 5073 case KEY_reverse: 5074 1585 LOP(OP_REVERSE,XTERM); 5075 5076 case KEY_readlink: 5077 887 UNIDOR(OP_READLINK); 5078 5079 case KEY_ref: 5080 53830 UNI(OP_REF); 5081 5082 case KEY_s: 5083 77195 s = scan_subst(s); 5084 77189 if (yylval.opval) 5085 77189 TERM(sublex_start()); 5086 else 5087 ###### TOKEN(1); /* force error */ 5088 5089 case KEY_chomp: 5090 4584 UNI(OP_CHOMP); 5091 5092 case KEY_scalar: 5093 7603 UNI(OP_SCALAR); 5094 5095 case KEY_select: 5096 2124 LOP(OP_SELECT,XTERM); 5097 5098 case KEY_seek: 5099 465 LOP(OP_SEEK,XTERM); 5100 5101 case KEY_semctl: 5102 17 LOP(OP_SEMCTL,XTERM); 5103 5104 case KEY_semget: 5105 3 LOP(OP_SEMGET,XTERM); 5106 5107 case KEY_semop: 5108 2 LOP(OP_SEMOP,XTERM); 5109 5110 case KEY_send: 5111 59 LOP(OP_SEND,XTERM); 5112 5113 case KEY_setpgrp: 5114 2 LOP(OP_SETPGRP,XTERM); 5115 5116 case KEY_setpriority: 5117 2 LOP(OP_SETPRIORITY,XTERM); 5118 5119 case KEY_sethostent: 5120 1 UNI(OP_SHOSTENT); 5121 5122 case KEY_setnetent: 5123 1 UNI(OP_SNETENT); 5124 5125 case KEY_setservent: 5126 1 UNI(OP_SSERVENT); 5127 5128 case KEY_setprotoent: 5129 1 UNI(OP_SPROTOENT); 5130 5131 case KEY_setpwent: 5132 7 FUN0(OP_SPWENT); 5133 5134 case KEY_setgrent: 5135 4 FUN0(OP_SGRENT); 5136 5137 case KEY_seekdir: 5138 3 LOP(OP_SEEKDIR,XTERM); 5139 5140 case KEY_setsockopt: 5141 118 LOP(OP_SSOCKOPT,XTERM); 5142 5143 case KEY_shift: 5144 96319 UNIDOR(OP_SHIFT); 5145 5146 case KEY_shmctl: 5147 2 LOP(OP_SHMCTL,XTERM); 5148 5149 case KEY_shmget: 5150 2 LOP(OP_SHMGET,XTERM); 5151 5152 case KEY_shmread: 5153 2 LOP(OP_SHMREAD,XTERM); 5154 5155 case KEY_shmwrite: 5156 2 LOP(OP_SHMWRITE,XTERM); 5157 5158 case KEY_shutdown: 5159 18 LOP(OP_SHUTDOWN,XTERM); 5160 5161 case KEY_sin: 5162 195 UNI(OP_SIN); 5163 5164 case KEY_sleep: 5165 114 UNI(OP_SLEEP); 5166 5167 case KEY_socket: 5168 80 LOP(OP_SOCKET,XTERM); 5169 5170 case KEY_socketpair: 5171 16 LOP(OP_SOCKPAIR,XTERM); 5172 5173 case KEY_sort: 5174 8352 checkcomma(s,PL_tokenbuf,"subroutine name"); 5175 8352 s = skipspace(s); 5176 8352 if (*s == ';' || *s == ')') /* probably a close */ 5177 ###### Perl_croak(aTHX_ "sort is now a reserved word"); 5178 8352 PL_expect = XTERM; 5179 8352 s = force_word(s,WORD,TRUE,TRUE,FALSE); 5180 8352 LOP(OP_SORT,XREF); 5181 5182 case KEY_split: 5183 12931 LOP(OP_SPLIT,XTERM); 5184 5185 case KEY_sprintf: 5186 14880 LOP(OP_SPRINTF,XTERM); 5187 5188 case KEY_splice: 5189 3308 LOP(OP_SPLICE,XTERM); 5190 5191 case KEY_sqrt: 5192 256 UNI(OP_SQRT); 5193 5194 case KEY_srand: 5195 15 UNI(OP_SRAND); 5196 5197 case KEY_stat: 5198 7071 UNI(OP_STAT); 5199 5200 case KEY_study: 5201 4588 UNI(OP_STUDY); 5202 5203 case KEY_substr: 5204 16286 LOP(OP_SUBSTR,XTERM); 5205 5206 case KEY_format: 5207 case KEY_sub: 5208 really_sub: 5209 { 5210 314466 char tmpbuf[sizeof PL_tokenbuf]; 5211 314466 SSize_t tboffset = 0; 5212 314466 expectation attrful; 5213 314466 bool have_name, have_proto, bad_proto; 5214 314466 const int key = tmp; 5215 5216 314466 s = skipspace(s); 5217 5218 314466 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' || 5219 (*s == ':' && s[1] == ':')) 5220 { 5221 296122 PL_expect = XBLOCK; 5222 296122 attrful = XATTRBLOCK; 5223 /* remember buffer pos'n for later force_word */ 5224 296122 tboffset = s - PL_oldbufptr; 5225 296122 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); 5226 296122 if (strchr(tmpbuf, ':')) 5227 3290 sv_setpv(PL_subname, tmpbuf); 5228 else { 5229 292832 sv_setsv(PL_subname,PL_curstname); 5230 292832 sv_catpvn(PL_subname,"::",2); 5231 292832 sv_catpvn(PL_subname,tmpbuf,len); 5232 } 5233 296122 s = skipspace(d); 5234 296122 have_name = TRUE; 5235 } 5236 else { 5237 18344 if (key == KEY_my) 5238 ###### Perl_croak(aTHX_ "Missing name in \"my sub\""); 5239 18344 PL_expect = XTERMBLOCK; 5240 18344 attrful = XATTRTERM; 5241 18344 sv_setpvn(PL_subname,"?",1); 5242 18344 have_name = FALSE; 5243 } 5244 5245 314466 if (key == KEY_format) { 5246 89 if (*s == '=') 5247 89 PL_lex_formbrack = PL_lex_brackets + 1; 5248 89 if (have_name) 5249 86 (void) force_word(PL_oldbufptr + tboffset, WORD, 5250 FALSE, TRUE, TRUE); 5251 89 OPERATOR(FORMAT); 5252 } 5253 5254 /* Look for a prototype */ 5255 314377 if (*s == '(') { 5256 28863 char *p; 5257 5258 28863 s = scan_str(s,FALSE,FALSE); 5259 28863 if (!s) 5260 ###### Perl_croak(aTHX_ "Prototype not terminated"); 5261 /* strip spaces and check for bad characters */ 5262 28863 d = SvPVX(PL_lex_stuff); 5263 28863 tmp = 0; 5264 28863 bad_proto = FALSE; 5265 68933 for (p = d; *p; ++p) { 5266 40070 if (!isSPACE(*p)) { 5267 39892 d[tmp++] = *p; 5268 39892 if (!strchr("$@%*;[]&\\", *p)) 5269 12 bad_proto = TRUE; 5270 } 5271 } 5272 28863 d[tmp] = '\0'; 5273 28863 if (bad_proto && ckWARN(WARN_SYNTAX)) 5274 4 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 5275 "Illegal character in prototype for %"SVf" : %s", 5276 PL_subname, d); 5277 28863 SvCUR_set(PL_lex_stuff, tmp); 5278 28863 have_proto = TRUE; 5279 5280 28863 s = skipspace(s); 5281 } 5282 else 5283 285514 have_proto = FALSE; 5284 5285 314377 if (*s == ':' && s[1] != ':') 5286 113 PL_expect = attrful; 5287 314264 else if (*s != '{' && key == KEY_sub) { 5288 30705 if (!have_name) 5289 6 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine"); 5290 30699 else if (*s != ';') 5291 2 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname); 5292 } 5293 5294 314369 if (have_proto) { 5295 28861 PL_nextval[PL_nexttoke].opval = 5296 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff); 5297 28861 PL_lex_stuff = Nullsv; 5298 28861 force_next(THING); 5299 } 5300 314369 if (!have_name) { 5301 18335 sv_setpv(PL_subname, 5302 PL_curstash ? "__ANON__" : "__ANON__::__ANON__"); 5303 18335 TOKEN(ANONSUB); 5304 } 5305 296034 (void) force_word(PL_oldbufptr + tboffset, WORD, 5306 FALSE, TRUE, TRUE); 5307 296034 if (key == KEY_my) 5308 ###### TOKEN(MYSUB); 5309 296034 TOKEN(SUB); 5310 } 5311 5312 case KEY_system: 5313 864 set_csh(); 5314 864 LOP(OP_SYSTEM,XREF); 5315 5316 case KEY_symlink: 5317 25 LOP(OP_SYMLINK,XTERM); 5318 5319 case KEY_syscall: 5320 18 LOP(OP_SYSCALL,XTERM); 5321 5322 case KEY_sysopen: 5323 133 LOP(OP_SYSOPEN,XTERM); 5324 5325 case KEY_sysseek: 5326 79 LOP(OP_SYSSEEK,XTERM); 5327 5328 case KEY_sysread: 5329 721 LOP(OP_SYSREAD,XTERM); 5330 5331 case KEY_syswrite: 5332 843 LOP(OP_SYSWRITE,XTERM); 5333 5334 case KEY_tr: 5335 6376 s = scan_trans(s); 5336 6371 TERM(sublex_start()); 5337 5338 case KEY_tell: 5339 434 UNI(OP_TELL); 5340 5341 case KEY_telldir: 5342 5 UNI(OP_TELLDIR); 5343 5344 case KEY_tie: 5345 2230 LOP(OP_TIE,XTERM); 5346 5347 case KEY_tied: 5348 1521 UNI(OP_TIED); 5349 5350 case KEY_time: 5351 585 FUN0(OP_TIME); 5352 5353 case KEY_times: 5354 135 FUN0(OP_TMS); 5355 5356 case KEY_truncate: 5357 148 LOP(OP_TRUNCATE,XTERM); 5358 5359 case KEY_uc: 5360 2739 UNI(OP_UC); 5361 5362 case KEY_ucfirst: 5363 27 UNI(OP_UCFIRST); 5364 5365 case KEY_untie: 5366 185 UNI(OP_UNTIE); 5367 5368 case KEY_until: 5369 204 yylval.ival = CopLINE(PL_curcop); 5370 204 OPERATOR(UNTIL); 5371 5372 case KEY_unless: 5373 161485 yylval.ival = CopLINE(PL_curcop); 5374 161485 OPERATOR(UNLESS); 5375 5376 case KEY_unlink: 5377 4727 LOP(OP_UNLINK,XTERM); 5378 5379 case KEY_undef: 5380 37879 UNIDOR(OP_UNDEF); 5381 5382 case KEY_unpack: 5383 1810 LOP(OP_UNPACK,XTERM); 5384 5385 case KEY_utime: 5386 959 LOP(OP_UTIME,XTERM); 5387 5388 case KEY_umask: 5389 88 UNIDOR(OP_UMASK); 5390 5391 case KEY_unshift: 5392 7593 LOP(OP_UNSHIFT,XTERM); 5393 5394 case KEY_use: 5395 59984 if (PL_expect != XSTATE) 5396 ###### yyerror("\"use\" not allowed in expression"); 5397 59984 s = skipspace(s); 5398 59984 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { 5399 6974 s = force_version(s, TRUE); 5400 6974 if (*s == ';' || (s = skipspace(s), *s == ';')) { 5401 6974 PL_nextval[PL_nexttoke].opval = Nullop; 5402 6974 force_next(WORD); 5403 } 5404 ###### else if (*s == 'v') { 5405 ###### s = force_word(s,WORD,FALSE,TRUE,FALSE); 5406 ###### s = force_version(s, FALSE); 5407 } 5408 } 5409 else { 5410 53010 s = force_word(s,WORD,FALSE,TRUE,FALSE); 5411 53010 s = force_version(s, FALSE); 5412 } 5413 59984 yylval.ival = 1; 5414 59984 OPERATOR(USE); 5415 5416 case KEY_values: 5417 1147 UNI(OP_VALUES); 5418 5419 case KEY_vec: 5420 37154 LOP(OP_VEC,XTERM); 5421 5422 case KEY_while: 5423 33629 yylval.ival = CopLINE(PL_curcop); 5424 33629 OPERATOR(WHILE); 5425 5426 case KEY_warn: 5427 21775 PL_hints |= HINT_BLOCK_SCOPE; 5428 21775 LOP(OP_WARN,XTERM); 5429 5430 case KEY_wait: 5431 10 FUN0(OP_WAIT); 5432 5433 case KEY_waitpid: 5434 85 LOP(OP_WAITPID,XTERM); 5435 5436 case KEY_wantarray: 5437 5760 FUN0(OP_WANTARRAY); 5438 5439 case KEY_write: 5440 #ifdef EBCDIC 5441 { 5442 char ctl_l[2]; 5443 ctl_l[0] = toCTRL('L'); 5444 ctl_l[1] = '\0'; 5445 gv_fetchpv(ctl_l,TRUE, SVt_PV); 5446 } 5447 #else 5448 280 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */ 5449 #endif 5450 280 UNI(OP_ENTERWRITE); 5451 5452 case KEY_x: 5453 8857 if (PL_expect == XOPERATOR) 5454 8848 Mop(OP_REPEAT); 5455 9 check_uni(); 5456 9 goto just_a_word; 5457 5458 case KEY_xor: 5459 1200 yylval.ival = OP_XOR; 5460 1200 OPERATOR(OROP); 5461 5462 case KEY_y: 5463 77 s = scan_trans(s); 5464 71 TERM(sublex_start()); 5465 } 5466 }} 5467 } 5468 #ifdef __SC__ 5469 #pragma segment Main 5470 #endif 5471 5472 static int 5473 S_pending_ident(pTHX) 5474 5127241 { 5475 5127241 register char *d; 5476 5127241 register I32 tmp = 0; 5477 /* pit holds the identifier we read and pending_ident is reset */ 5478 5127241 char pit = PL_pending_ident; 5479 5127241 PL_pending_ident = 0; 5480 5481 DEBUG_T({ PerlIO_printf(Perl_debug_log, 5482 5127241 "### Tokener saw identifier '%s'\n", PL_tokenbuf); }); 5483 5484 /* if we're in a my(), we can't allow dynamics here. 5485 $foo'bar has already been turned into $foo::bar, so 5486 just check for colons. 5487 5488 if it's a legal name, the OP is a PADANY. 5489 */ 5490 5127241 if (PL_in_my) { 5491 849655 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */ 5492 68821 if (strchr(PL_tokenbuf,':')) 5493 ###### yyerror(Perl_form(aTHX_ "No package name allowed for " 5494 "variable %s in \"our\"", 5495 PL_tokenbuf)); 5496 68821 tmp = allocmy(PL_tokenbuf); 5497 } 5498 else { 5499 780834 if (strchr(PL_tokenbuf,':')) 5500 ###### yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf)); 5501 5502 780834 yylval.opval = newOP(OP_PADANY, 0); 5503 780834 yylval.opval->op_targ = allocmy(PL_tokenbuf); 5504 780834 return PRIVATEREF; 5505 } 5506 } 5507 5508 /* 5509 build the ops for accesses to a my() variable. 5510 5511 Deny my($a) or my($b) in a sort block, *if* $a or $b is 5512 then used in a comparison. This catches most, but not 5513 all cases. For instance, it catches 5514 sort { my($a); $a <=> $b } 5515 but not 5516 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; } 5517 (although why you'd do that is anyone's guess). 5518 */ 5519 5520 4346407 if (!strchr(PL_tokenbuf,':')) { 5521 4266501 if (!PL_in_my) 5522 4197680 tmp = pad_findmy(PL_tokenbuf); 5523 4266501 if (tmp != NOT_IN_PAD) { 5524 /* might be an "our" variable" */ 5525 3235177 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) { 5526 /* build ops for a bareword */ 5527 205985 HV *stash = PAD_COMPNAME_OURSTASH(tmp); 5528 205985 HEK *stashname = HvNAME_HEK(stash); 5529 205985 SV *sym = newSVhek(stashname); 5530 205985 sv_catpvn(sym, "::", 2); 5531 205985 sv_catpv(sym, PL_tokenbuf+1); 5532 205985 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym); 5533 205985 yylval.opval->op_private = OPpCONST_ENTERED; 5534 205985 gv_fetchsv(sym, 5535 (PL_in_eval 5536 ? (GV_ADDMULTI | GV_ADDINEVAL) 5537 : GV_ADDMULTI 5538 ), 5539 ((PL_tokenbuf[0] == '$') ? SVt_PV 5540 : (PL_tokenbuf[0] == '@') ? SVt_PVAV 5541 : SVt_PVHV)); 5542 205985 return WORD; 5543 } 5544 5545 /* if it's a sort block and they're naming $a or $b */ 5546 3029192 if (PL_last_lop_op == OP_SORT && 5547 PL_tokenbuf[0] == '$' && 5548 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b') 5549 && !PL_tokenbuf[2]) 5550 { 5551 2308 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart; 5552 d < PL_bufend && *d != '\n'; 5553 d++) 5554 { 5555 2242 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) { 5556 ###### Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison", 5557 PL_tokenbuf); 5558 } 5559 } 5560 } 5561 5562 3029192 yylval.opval = newOP(OP_PADANY, 0); 5563 3029192 yylval.opval->op_targ = tmp; 5564 3029192 return PRIVATEREF; 5565 } 5566 } 5567 5568 /* 5569 Whine if they've said @foo in a doublequoted string, 5570 and @foo isn't a variable we can find in the symbol 5571 table. 5572 */ 5573 1111230 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) { 5574 3281 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV); 5575 3281 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) 5576 && ckWARN(WARN_AMBIGUOUS)) 5577 { 5578 /* Downgraded from fatal to warning 20000522 mjd */ 5579 2 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), 5580 "Possible unintended interpolation of %s in string", 5581 PL_tokenbuf); 5582 } 5583 } 5584 5585 /* build ops for a bareword */ 5586 1111230 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0)); 5587 1111230 yylval.opval->op_private = OPpCONST_ENTERED; 5588 1111230 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE, 5589 ((PL_tokenbuf[0] == '$') ? SVt_PV 5590 : (PL_tokenbuf[0] == '@') ? SVt_PVAV 5591 : SVt_PVHV)); 5592 1111230 return WORD; 5593 } 5594 5595 /* 5596 * The following code was generated by perl_keyword.pl. 5597 */ 5598 5599 I32 5600 Perl_keyword (pTHX_ const char *name, I32 len) 5601 4498037 { 5602 4498037 switch (len) 5603 { 5604 case 1: /* 5 tokens of length 1 */ 5605 139618 switch (name[0]) 5606 { 5607 case 'm': 5608 { /* m */ 5609 29771 return KEY_m; 5610 } 5611 5612 case 'q': 5613 { /* q */ 5614 7485 return KEY_q; 5615 } 5616 5617 case 's': 5618 { /* s */ 5619 78702 return KEY_s; 5620 } 5621 5622 case 'x': 5623 { /* x */ 5624 8864 return -KEY_x; 5625 } 5626 5627 case 'y': 5628 { /* y */ 5629 79 return KEY_y; 5630 } 5631 5632 default: 5633 1456410 goto unknown; 5634 } 5635 5636 case 2: /* 18 tokens of length 2 */ 5637 1456410 switch (name[0]) 5638 { 5639 case 'd': 5640 17148 if (name[1] == 'o') 5641 { /* do */ 5642 17148 return KEY_do; 5643 } 5644 5645 164117 goto unknown; 5646 5647 case 'e': 5648 164117 if (name[1] == 'q') 5649 { /* eq */ 5650 164115 return -KEY_eq; 5651 } 5652 5653 5661 goto unknown; 5654 5655 case 'g': 5656 5661 switch (name[1]) 5657 { 5658 case 'e': 5659 { /* ge */ 5660 5580 return -KEY_ge; 5661 } 5662 5663 case 't': 5664 { /* gt */ 5665 80 return -KEY_gt; 5666 } 5667 5668 default: 5669 470230 goto unknown; 5670 } 5671 5672 case 'i': 5673 470230 if (name[1] == 'f') 5674 { /* if */ 5675 465720 return KEY_if; 5676 } 5677 5678 7718 goto unknown; 5679 5680 case 'l': 5681 7718 switch (name[1]) 5682 { 5683 case 'c': 5684 { /* lc */ 5685 3698 return -KEY_lc; 5686 } 5687 5688 case 'e': 5689 { /* le */ 5690 3755 return -KEY_le; 5691 } 5692 5693 case 't': 5694 { /* lt */ 5695 194 return -KEY_lt; 5696 } 5697 5698 default: 5699 588422 goto unknown; 5700 } 5701 5702 case 'm': 5703 588422 if (name[1] == 'y') 5704 { /* my */ 5705 588403 return KEY_my; 5706 } 5707 5708 37519 goto unknown; 5709 5710 case 'n': 5711 37519 switch (name[1]) 5712 { 5713 case 'e': 5714 { /* ne */ 5715 25457 return -KEY_ne; 5716 } 5717 5718 case 'o': 5719 { /* no */ 5720 12056 return KEY_no; 5721 } 5722 5723 default: 5724 64061 goto unknown; 5725 } 5726 5727 case 'o': 5728 64061 if (name[1] == 'r') 5729 { /* or */ 5730 55597 return -KEY_or; 5731 } 5732 5733 78439 goto unknown; 5734 5735 case 'q': 5736 78439 switch (name[1]) 5737 { 5738 case 'q': 5739 { /* qq */ 5740 14245 return KEY_qq; 5741 } 5742 5743 case 'r': 5744 { /* qr */ 5745 9661 return KEY_qr; 5746 } 5747 5748 case 'w': 5749 { /* qw */ 5750 54506 return KEY_qw; 5751 } 5752 5753 case 'x': 5754 { /* qx */ 5755 23 return KEY_qx; 5756 } 5757 5758 default: 5759 6381 goto unknown; 5760 } 5761 5762 case 't': 5763 6381 if (name[1] == 'r') 5764 { /* tr */ 5765 6377 return KEY_tr; 5766 } 5767 5768 2745 goto unknown; 5769 5770 case 'u': 5771 2745 if (name[1] == 'c') 5772 { /* uc */ 5773 2742 return -KEY_uc; 5774 } 5775 5776 707721 goto unknown; 5777 5778 default: 5779 707721 goto unknown; 5780 } 5781 5782 case 3: /* 28 tokens of length 3 */ 5783 707721 switch (name[0]) 5784 { 5785 case 'E': 5786 1098 if (name[1] == 'N' && 5787 name[2] == 'D') 5788 { /* END */ 5789 1027 return KEY_END; 5790 } 5791 5792 51343 goto unknown; 5793 5794 case 'a': 5795 51343 switch (name[1]) 5796 { 5797 case 'b': 5798 1942 if (name[2] == 's') 5799 { /* abs */ 5800 1936 return -KEY_abs; 5801 } 5802 5803 46244 goto unknown; 5804 5805 case 'n': 5806 46244 if (name[2] == 'd') 5807 { /* and */ 5808 46243 return -KEY_and; 5809 } 5810 5811 8753 goto unknown; 5812 5813 default: 5814 8753 goto unknown; 5815 } 5816 5817 case 'c': 5818 8753 switch (name[1]) 5819 { 5820 case 'h': 5821 1457 if (name[2] == 'r') 5822 { /* chr */ 5823 1457 return -KEY_chr; 5824 } 5825 5826 3234 goto unknown; 5827 5828 case 'm': 5829 3234 if (name[2] == 'p') 5830 { /* cmp */ 5831 3234 return -KEY_cmp; 5832 } 5833 5834 217 goto unknown; 5835 5836 case 'o': 5837 217 if (name[2] == 's') 5838 { /* cos */ 5839 169 return -KEY_cos; 5840 } 5841 5842 30775 goto unknown; 5843 5844 default: 5845 30775 goto unknown; 5846 } 5847 5848 case 'd': 5849 30775 if (name[1] == 'i' && 5850 name[2] == 'e') 5851 { /* die */ 5852 29601 return -KEY_die; 5853 } 5854 5855 605 goto unknown; 5856 5857 case 'e': 5858 605 switch (name[1]) 5859 { 5860 case 'o': 5861 386 if (name[2] == 'f') 5862 { /* eof */ 5863 386 return -KEY_eof; 5864 } 5865 5866 16 goto unknown; 5867 5868 case 'r': 5869 16 if (name[2] == 'r') 5870 { /* err */ 5871 15 return -KEY_err; 5872 } 5873 5874 196 goto unknown; 5875 5876 case 'x': 5877 196 if (name[2] == 'p') 5878 { /* exp */ 5879 196 return -KEY_exp; 5880 } 5881 5882 20929 goto unknown; 5883 5884 default: 5885 20929 goto unknown; 5886 } 5887 5888 case 'f': 5889 20929 if (name[1] == 'o' && 5890 name[2] == 'r') 5891 { /* for */ 5892 20766 return KEY_for; 5893 } 5894 5895 1116 goto unknown; 5896 5897 case 'h': 5898 1116 if (name[1] == 'e' && 5899 name[2] == 'x') 5900 { /* hex */ 5901 1077 return -KEY_hex; 5902 } 5903 5904 5476 goto unknown; 5905 5906 case 'i': 5907 5476 if (name[1] == 'n' && 5908 name[2] == 't') 5909 { /* int */ 5910 4844 return -KEY_int; 5911 } 5912 5913 665 goto unknown; 5914 5915 case 'l': 5916 665 if (name[1] == 'o' && 5917 name[2] == 'g') 5918 { /* log */ 5919 335 return -KEY_log; 5920 } 5921 5922 19962 goto unknown; 5923 5924 case 'm': 5925 19962 if (name[1] == 'a' && 5926 name[2] == 'p') 5927 { /* map */ 5928 19683 return KEY_map; 5929 } 5930 5931 21026 goto unknown; 5932 5933 case 'n': 5934 21026 if (name[1] == 'o' && 5935 name[2] == 't') 5936 { /* not */ 5937 18598 return -KEY_not; 5938 } 5939 5940 57448 goto unknown; 5941 5942 case 'o': 5943 57448 switch (name[1]) 5944 { 5945 case 'c': 5946 954 if (name[2] == 't') 5947 { /* oct */ 5948 954 return -KEY_oct; 5949 } 5950 5951 3577 goto unknown; 5952 5953 case 'r': 5954 3577 if (name[2] == 'd') 5955 { /* ord */ 5956 3577 return -KEY_ord; 5957 } 5958 5959 52070 goto unknown; 5960 5961 case 'u': 5962 52070 if (name[2] == 'r') 5963 { /* our */ 5964 52069 return KEY_our; 5965 } 5966 5967 12258 goto unknown; 5968 5969 default: 5970 12258 goto unknown; 5971 } 5972 5973 case 'p': 5974 12258 if (name[1] == 'o') 5975 { 5976 11930 switch (name[2]) 5977 { 5978 case 'p': 5979 { /* pop */ 5980 9441 return -KEY_pop; 5981 } 5982 5983 case 's': 5984 { /* pos */ 5985 2489 return KEY_pos; 5986 } 5987 5988 default: 5989 53949 goto unknown; 5990 } 5991 } 5992 5993 53949 goto unknown; 5994 5995 case 'r': 5996 53949 if (name[1] == 'e' && 5997 name[2] == 'f') 5998 { /* ref */ 5999 53903 return -KEY_ref; 6000 } 6001 6002 307991 goto unknown; 6003 6004 case 's': 6005 307991 switch (name[1]) 6006 { 6007 case 'i': 6008 196 if (name[2] == 'n') 6009 { /* sin */ 6010 196 return -KEY_sin; 6011 } 6012 6013 307211 goto unknown; 6014 6015 case 'u': 6016 307211 if (name[2] == 'b') 6017 { /* sub */ 6018 307199 return KEY_sub; 6019 } 6020 6021 2953 goto unknown; 6022 6023 default: 6024 2953 goto unknown; 6025 } 6026 6027 case 't': 6028 2953 if (name[1] == 'i' && 6029 name[2] == 'e') 6030 { /* tie */ 6031 2232 return KEY_tie; 6032 } 6033 6034 60013 goto unknown; 6035 6036 case 'u': 6037 60013 if (name[1] == 's' && 6038 name[2] == 'e') 6039 { /* use */ 6040 59985 return KEY_use; 6041 } 6042 6043 37158 goto unknown; 6044 6045 case 'v': 6046 37158 if (name[1] == 'e' && 6047 name[2] == 'c') 6048 { /* vec */ 6049 37155 return -KEY_vec; 6050 } 6051 6052 1209 goto unknown; 6053 6054 case 'x': 6055 1209 if (name[1] == 'o' && 6056 name[2] == 'r') 6057 { /* xor */ 6058 1202 return -KEY_xor; 6059 } 6060 6061 504250 goto unknown; 6062 6063 default: 6064 504250 goto unknown; 6065 } 6066 6067 case 4: /* 40 tokens of length 4 */ 6068 504250 switch (name[0]) 6069 { 6070 case 'C': 6071 45274 if (name[1] == 'O' && 6072 name[2] == 'R' && 6073 name[3] == 'E') 6074 { /* CORE */ 6075 5031 return -KEY_CORE; 6076 } 6077 6078 120 goto unknown; 6079 6080 case 'I': 6081 120 if (name[1] == 'N' && 6082 name[2] == 'I' && 6083 name[3] == 'T') 6084 { /* INIT */ 6085 15 return KEY_INIT; 6086 } 6087 6088 9048 goto unknown; 6089 6090 case 'b': 6091 9048 if (name[1] == 'i' && 6092 name[2] == 'n' && 6093 name[3] == 'd') 6094 { /* bind */ 6095 57 return -KEY_bind; 6096 } 6097 6098 11777 goto unknown; 6099 6100 case 'c': 6101 11777 if (name[1] == 'h' && 6102 name[2] == 'o' && 6103 name[3] == 'p') 6104 { /* chop */ 6105 2248 return -KEY_chop; 6106 } 6107 6108 462 goto unknown; 6109 6110 case 'd': 6111 462 if (name[1] == 'u' && 6112 name[2] == 'm' && 6113 name[3] == 'p') 6114 { /* dump */ 6115 13 return -KEY_dump; 6116 } 6117 6118 128105 goto unknown; 6119 6120 case 'e': 6121 128105 switch (name[1]) 6122 { 6123 case 'a': 6124 2336 if (name[2] == 'c' && 6125 name[3] == 'h') 6126 { /* each */ 6127 2336 return -KEY_each; 6128 } 6129 6130 97864 goto unknown; 6131 6132 case 'l': 6133 97864 if (name[2] == 's' && 6134 name[3] == 'e') 6135 { /* else */ 6136 97852 return KEY_else; 6137 } 6138 6139 22830 goto unknown; 6140 6141 case 'v': 6142 22830 if (name[2] == 'a' && 6143 name[3] == 'l') 6144 { /* eval */ 6145 22830 return KEY_eval; 6146 } 6147 6148 3886 goto unknown; 6149 6150 case 'x': 6151 3886 switch (name[2]) 6152 { 6153 case 'e': 6154 386 if (name[3] == 'c') 6155 { /* exec */ 6156 386 return -KEY_exec; 6157 } 6158 6159 3495 goto unknown; 6160 6161 case 'i': 6162 3495 if (name[3] == 't') 6163 { /* exit */ 6164 3495 return -KEY_exit; 6165 } 6166 6167 1317 goto unknown; 6168 6169 default: 6170 1317 goto unknown; 6171 } 6172 6173 default: 6174 1317 goto unknown; 6175 } 6176 6177 case 'f': 6178 1317 if (name[1] == 'o' && 6179 name[2] == 'r' && 6180 name[3] == 'k') 6181 { /* fork */ 6182 71 return -KEY_fork; 6183 } 6184 6185 51895 goto unknown; 6186 6187 case 'g': 6188 51895 switch (name[1]) 6189 { 6190 case 'e': 6191 131 if (name[2] == 't' && 6192 name[3] == 'c') 6193 { /* getc */ 6194 131 return -KEY_getc; 6195 } 6196 6197 499 goto unknown; 6198 6199 case 'l': 6200 499 if (name[2] == 'o' && 6201 name[3] == 'b') 6202 { /* glob */ 6203 499 return KEY_glob; 6204 } 6205 6206 38168 goto unknown; 6207 6208 case 'o': 6209 38168 if (name[2] == 't' && 6210 name[3] == 'o') 6211 { /* goto */ 6212 38126 return KEY_goto; 6213 } 6214 6215 13097 goto unknown; 6216 6217 case 'r': 6218 13097 if (name[2] == 'e' && 6219 name[3] == 'p') 6220 { /* grep */ 6221 13097 return KEY_grep; 6222 } 6223 6224 23518 goto unknown; 6225 6226 default: 6227 23518 goto unknown; 6228 } 6229 6230 case 'j': 6231 23518 if (name[1] == 'o' && 6232 name[2] == 'i' && 6233 name[3] == 'n') 6234 { /* join */ 6235 23517 return -KEY_join; 6236 } 6237 6238 22346 goto unknown; 6239 6240 case 'k': 6241 22346 switch (name[1]) 6242 { 6243 case 'e': 6244 22185 if (name[2] == 'y' && 6245 name[3] == 's') 6246 { /* keys */ 6247 22183 return -KEY_keys; 6248 } 6249 6250 161 goto unknown; 6251 6252 case 'i': 6253 161 if (name[2] == 'l' && 6254 name[3] == 'l') 6255 { /* kill */ 6256 101 return -KEY_kill; 6257 } 6258 6259 25296 goto unknown; 6260 6261 default: 6262 25296 goto unknown; 6263 } 6264 6265 case 'l': 6266 25296 switch (name[1]) 6267 { 6268 case 'a': 6269 23014 if (name[2] == 's' && 6270 name[3] == 't') 6271 { /* last */ 6272 23013 return KEY_last; 6273 } 6274 6275 979 goto unknown; 6276 6277 case 'i': 6278 979 if (name[2] == 'n' && 6279 name[3] == 'k') 6280 { /* link */ 6281 42 return -KEY_link; 6282 } 6283 6284 1284 goto unknown; 6285 6286 case 'o': 6287 1284 if (name[2] == 'c' && 6288 name[3] == 'k') 6289 { /* lock */ 6290 1250 return -KEY_lock; 6291 } 6292 6293 32078 goto unknown; 6294 6295 default: 6296 32078 goto unknown; 6297 } 6298 6299 case 'n': 6300 32078 if (name[1] == 'e' && 6301 name[2] == 'x' && 6302 name[3] == 't') 6303 { /* next */ 6304 29687 return KEY_next; 6305 } 6306 6307 10508 goto unknown; 6308 6309 case 'o': 6310 10508 if (name[1] == 'p' && 6311 name[2] == 'e' && 6312 name[3] == 'n') 6313 { /* open */ 6314 10470 return -KEY_open; 6315 } 6316 6317 57556 goto unknown; 6318 6319 case 'p': 6320 57556 switch (name[1]) 6321 { 6322 case 'a': 6323 2309 if (name[2] == 'c' && 6324 name[3] == 'k') 6325 { /* pack */ 6326 2210 return -KEY_pack; 6327 } 6328 6329 107 goto unknown; 6330 6331 case 'i': 6332 107 if (name[2] == 'p' && 6333 name[3] == 'e') 6334 { /* pipe */ 6335 71 return -KEY_pipe; 6336 } 6337 6338 53719 goto unknown; 6339 6340 case 'u': 6341 53719 if (name[2] == 's' && 6342 name[3] == 'h') 6343 { /* push */ 6344 53719 return -KEY_push; 6345 } 6346 6347 7306 goto unknown; 6348 6349 default: 6350 7306 goto unknown; 6351 } 6352 6353 case 'r': 6354 7306 switch (name[1]) 6355 { 6356 case 'a': 6357 176 if (name[2] == 'n' && 6358 name[3] == 'd') 6359 { /* rand */ 6360 175 return -KEY_rand; 6361 } 6362 6363 7073 goto unknown; 6364 6365 case 'e': 6366 7073 switch (name[2]) 6367 { 6368 case 'a': 6369 1866 if (name[3] == 'd') 6370 { /* read */ 6371 1866 return -KEY_read; 6372 } 6373 6374 34 goto unknown; 6375 6376 case 'c': 6377 34 if (name[3] == 'v') 6378 { /* recv */ 6379 34 return -KEY_recv; 6380 } 6381 6382 2979 goto unknown; 6383 6384 case 'd': 6385 2979 if (name[3] == 'o') 6386 { /* redo */ 6387 2979 return KEY_redo; 6388 } 6389 6390 19351 goto unknown; 6391 6392 default: 6393 19351 goto unknown; 6394 } 6395 6396 default: 6397 19351 goto unknown; 6398 } 6399 6400 case 's': 6401 19351 switch (name[1]) 6402 { 6403 case 'e': 6404 611 switch (name[2]) 6405 { 6406 case 'e': 6407 518 if (name[3] == 'k') 6408 { /* seek */ 6409 466 return -KEY_seek; 6410 } 6411 6412 60 goto unknown; 6413 6414 case 'n': 6415 60 if (name[3] == 'd') 6416 { /* send */ 6417 60 return -KEY_send; 6418 } 6419 6420 8354 goto unknown; 6421 6422 default: 6423 8354 goto unknown; 6424 } 6425 6426 case 'o': 6427 8354 if (name[2] == 'r' && 6428 name[3] == 't') 6429 { /* sort */ 6430 8353 return KEY_sort; 6431 } 6432 6433 307 goto unknown; 6434 6435 case 'q': 6436 307 if (name[2] == 'r' && 6437 name[3] == 't') 6438 { /* sqrt */ 6439 307 return -KEY_sqrt; 6440 } 6441 6442 7084 goto unknown; 6443 6444 case 't': 6445 7084 if (name[2] == 'a' && 6446 name[3] == 't') 6447 { /* stat */ 6448 7073 return -KEY_stat; 6449 } 6450 6451 7374 goto unknown; 6452 6453 default: 6454 7374 goto unknown; 6455 } 6456 6457 case 't': 6458 7374 switch (name[1]) 6459 { 6460 case 'e': 6461 1574 if (name[2] == 'l' && 6462 name[3] == 'l') 6463 { /* tell */ 6464 435 return -KEY_tell; 6465 } 6466 6467 2213 goto unknown; 6468 6469 case 'i': 6470 2213 switch (name[2]) 6471 { 6472 case 'e': 6473 1564 if (name[3] == 'd') 6474 { /* tied */ 6475 1533 return KEY_tied; 6476 } 6477 6478 646 goto unknown; 6479 6480 case 'm': 6481 646 if (name[3] == 'e') 6482 { /* time */ 6483 646 return -KEY_time; 6484 } 6485 6486 21950 goto unknown; 6487 6488 default: 6489 21950 goto unknown; 6490 } 6491 6492 default: 6493 21950 goto unknown; 6494 } 6495 6496 case 'w': 6497 21950 if (name[1] == 'a') 6498 { 6499 21789 switch (name[2]) 6500 { 6501 case 'i': 6502 11 if (name[3] == 't') 6503 { /* wait */ 6504 11 return -KEY_wait; 6505 } 6506 6507 21778 goto unknown; 6508 6509 case 'r': 6510 21778 if (name[3] == 'n') 6511 { /* warn */ 6512 21778 return -KEY_warn; 6513 } 6514 6515 474743 goto unknown; 6516 6517 default: 6518 474743 goto unknown; 6519 } 6520 } 6521 6522 474743 goto unknown; 6523 6524 default: 6525 474743 goto unknown; 6526 } 6527 6528 case 5: /* 36 tokens of length 5 */ 6529 474743 switch (name[0]) 6530 { 6531 case 'B': 6532 6114 if (name[1] == 'E' && 6533 name[2] == 'G' && 6534 name[3] == 'I' && 6535 name[4] == 'N') 6536 { /* BEGIN */ 6537 5424 return KEY_BEGIN; 6538 } 6539 6540 278 goto unknown; 6541 6542 case 'C': 6543 278 if (name[1] == 'H' && 6544 name[2] == 'E' && 6545 name[3] == 'C' && 6546 name[4] == 'K') 6547 { /* CHECK */ 6548 97 return KEY_CHECK; 6549 } 6550 6551 542 goto unknown; 6552 6553 case 'a': 6554 542 switch (name[1]) 6555 { 6556 case 'l': 6557 125 if (name[2] == 'a' && 6558 name[3] == 'r' && 6559 name[4] == 'm') 6560 { /* alarm */ 6561 41 return -KEY_alarm; 6562 } 6563 6564 201 goto unknown; 6565 6566 case 't': 6567 201 if (name[2] == 'a' && 6568 name[3] == 'n' && 6569 name[4] == '2') 6570 { /* atan2 */ 6571 167 return -KEY_atan2; 6572 } 6573 6574 7435 goto unknown; 6575 6576 default: 6577 7435 goto unknown; 6578 } 6579 6580 case 'b': 6581 7435 if (name[1] == 'l' && 6582 name[2] == 'e' && 6583 name[3] == 's' && 6584 name[4] == 's') 6585 { /* bless */ 6586 5927 return -KEY_bless; 6587 } 6588 6589 44974 goto unknown; 6590 6591 case 'c': 6592 44974 switch (name[1]) 6593 { 6594 case 'h': 6595 14645 switch (name[2]) 6596 { 6597 case 'd': 6598 4376 if (name[3] == 'i' && 6599 name[4] == 'r') 6600 { /* chdir */ 6601 4376 return -KEY_chdir; 6602 } 6603 6604 4538 goto unknown; 6605 6606 case 'm': 6607 4538 if (name[3] == 'o' && 6608 name[4] == 'd') 6609 { /* chmod */ 6610 4538 return -KEY_chmod; 6611 } 6612 6613 4592 goto unknown; 6614 6615 case 'o': 6616 4592 switch (name[3]) 6617 { 6618 case 'm': 6619 4586 if (name[4] == 'p') 6620 { /* chomp */ 6621 4586 return -KEY_chomp; 6622 } 6623 6624 6 goto unknown; 6625 6626 case 'w': 6627 6 if (name[4] == 'n') 6628 { /* chown */ 6629 6 return -KEY_chown; 6630 } 6631 6632 12936 goto unknown; 6633 6634 default: 6635 12936 goto unknown; 6636 } 6637 6638 default: 6639 12936 goto unknown; 6640 } 6641 6642 case 'l': 6643 12936 if (name[2] == 'o' && 6644 name[3] == 's' && 6645 name[4] == 'e') 6646 { /* close */ 6647 11039 return -KEY_close; 6648 } 6649 6650 17180 goto unknown; 6651 6652 case 'r': 6653 17180 if (name[2] == 'y' && 6654 name[3] == 'p' && 6655 name[4] == 't') 6656 { /* crypt */ 6657 10 return -KEY_crypt; 6658 } 6659 6660 68221 goto unknown; 6661 6662 default: 6663 68221 goto unknown; 6664 } 6665 6666 case 'e': 6667 68221 if (name[1] == 'l' && 6668 name[2] == 's' && 6669 name[3] == 'i' && 6670 name[4] == 'f') 6671 { /* elsif */ 6672 67709 return KEY_elsif; 6673 } 6674 6675 396 goto unknown; 6676 6677 case 'f': 6678 396 switch (name[1]) 6679 { 6680 case 'c': 6681 120 if (name[2] == 'n' && 6682 name[3] == 't' && 6683 name[4] == 'l') 6684 { /* fcntl */ 6685 120 return -KEY_fcntl; 6686 } 6687 6688 199 goto unknown; 6689 6690 case 'l': 6691 199 if (name[2] == 'o' && 6692 name[3] == 'c' && 6693 name[4] == 'k') 6694 { /* flock */ 6695 69 return -KEY_flock; 6696 } 6697 6698 4763 goto unknown; 6699 6700 default: 6701 4763 goto unknown; 6702 } 6703 6704 case 'i': 6705 4763 switch (name[1]) 6706 { 6707 case 'n': 6708 4653 if (name[2] == 'd' && 6709 name[3] == 'e' && 6710 name[4] == 'x') 6711 { /* index */ 6712 4527 return -KEY_index; 6713 } 6714 6715 106 goto unknown; 6716 6717 case 'o': 6718 106 if (name[2] == 'c' && 6719 name[3] == 't' && 6720 name[4] == 'l') 6721 { /* ioctl */ 6722 106 return -KEY_ioctl; 6723 } 6724 6725 53913 goto unknown; 6726 6727 default: 6728 53913 goto unknown; 6729 } 6730 6731 case 'l': 6732 53913 switch (name[1]) 6733 { 6734 case 'o': 6735 51120 if (name[2] == 'c' && 6736 name[3] == 'a' && 6737 name[4] == 'l') 6738 { /* local */ 6739 51080 return KEY_local; 6740 } 6741 6742 2651 goto unknown; 6743 6744 case 's': 6745 2651 if (name[2] == 't' && 6746 name[3] == 'a' && 6747 name[4] == 't') 6748 { /* lstat */ 6749 2650 return -KEY_lstat; 6750 } 6751 6752 5129 goto unknown; 6753 6754 default: 6755 5129 goto unknown; 6756 } 6757 6758 case 'm': 6759 5129 if (name[1] == 'k' && 6760 name[2] == 'd' && 6761 name[3] == 'i' && 6762 name[4] == 'r') 6763 { /* mkdir */ 6764 682 return -KEY_mkdir; 6765 } 6766 6767 61132 goto unknown; 6768 6769 case 'p': 6770 61132 if (name[1] == 'r' && 6771 name[2] == 'i' && 6772 name[3] == 'n' && 6773 name[4] == 't') 6774 { /* print */ 6775 60992 return KEY_print; 6776 } 6777 6778 2377 goto unknown; 6779 6780 case 'r': 6781 2377 switch (name[1]) 6782 { 6783 case 'e': 6784 1706 if (name[2] == 's' && 6785 name[3] == 'e' && 6786 name[4] == 't') 6787 { /* reset */ 6788 14 return -KEY_reset; 6789 } 6790 6791 641 goto unknown; 6792 6793 case 'm': 6794 641 if (name[2] == 'd' && 6795 name[3] == 'i' && 6796 name[4] == 'r') 6797 { /* rmdir */ 6798 639 return -KEY_rmdir; 6799 } 6800 6801 115757 goto unknown; 6802 6803 default: 6804 115757 goto unknown; 6805 } 6806 6807 case 's': 6808 115757 switch (name[1]) 6809 { 6810 case 'e': 6811 4 if (name[2] == 'm' && 6812 name[3] == 'o' && 6813 name[4] == 'p') 6814 { /* semop */ 6815 3 return -KEY_semop; 6816 } 6817 6818 96725 goto unknown; 6819 6820 case 'h': 6821 96725 if (name[2] == 'i' && 6822 name[3] == 'f' && 6823 name[4] == 't') 6824 { /* shift */ 6825 96377 return -KEY_shift; 6826 } 6827 6828 134 goto unknown; 6829 6830 case 'l': 6831 134 if (name[2] == 'e' && 6832 name[3] == 'e' && 6833 name[4] == 'p') 6834 { /* sleep */ 6835 118 return -KEY_sleep; 6836 } 6837 6838 12955 goto unknown; 6839 6840 case 'p': 6841 12955 if (name[2] == 'l' && 6842 name[3] == 'i' && 6843 name[4] == 't') 6844 { /* split */ 6845 12955 return KEY_split; 6846 } 6847 6848 16 goto unknown; 6849 6850 case 'r': 6851 16 if (name[2] == 'a' && 6852 name[3] == 'n' && 6853 name[4] == 'd') 6854 { /* srand */ 6855 16 return -KEY_srand; 6856 } 6857 6858 5845 goto unknown; 6859 6860 case 't': 6861 5845 if (name[2] == 'u' && 6862 name[3] == 'd' && 6863 name[4] == 'y') 6864 { /* study */ 6865 4589 return KEY_study; 6866 } 6867 6868 2510 goto unknown; 6869 6870 default: 6871 2510 goto unknown; 6872 } 6873 6874 case 't': 6875 2510 if (name[1] == 'i' && 6876 name[2] == 'm' && 6877 name[3] == 'e' && 6878 name[4] == 's') 6879 { /* times */ 6880 136 return -KEY_times; 6881 } 6882 6883 40381 goto unknown; 6884 6885 case 'u': 6886 40381 switch (name[1]) 6887 { 6888 case 'm': 6889 89 if (name[2] == 'a' && 6890 name[3] == 's' && 6891 name[4] == 'k') 6892 { /* umask */ 6893 89 return -KEY_umask; 6894 } 6895 6896 38665 goto unknown; 6897 6898 case 'n': 6899 38665 switch (name[2]) 6900 { 6901 case 'd': 6902 37881 if (name[3] == 'e' && 6903 name[4] == 'f') 6904 { /* undef */ 6905 37881 return KEY_undef; 6906 } 6907 6908 394 goto unknown; 6909 6910 case 't': 6911 394 if (name[3] == 'i') 6912 { 6913 394 switch (name[4]) 6914 { 6915 case 'e': 6916 { /* untie */ 6917 186 return KEY_untie; 6918 } 6919 6920 case 'l': 6921 { /* until */ 6922 208 return KEY_until; 6923 } 6924 6925 default: 6926 960 goto unknown; 6927 } 6928 } 6929 6930 960 goto unknown; 6931 6932 default: 6933 960 goto unknown; 6934 } 6935 6936 case 't': 6937 960 if (name[2] == 'i' && 6938 name[3] == 'm' && 6939 name[4] == 'e') 6940 { /* utime */ 6941 960 return -KEY_utime; 6942 } 6943 6944 34075 goto unknown; 6945 6946 default: 6947 34075 goto unknown; 6948 } 6949 6950 case 'w': 6951 34075 switch (name[1]) 6952 { 6953 case 'h': 6954 33632 if (name[2] == 'i' && 6955 name[3] == 'l' && 6956 name[4] == 'e') 6957 { /* while */ 6958 33632 return KEY_while; 6959 } 6960 6961 355 goto unknown; 6962 6963 case 'r': 6964 355 if (name[2] == 'i' && 6965 name[3] == 't' && 6966 name[4] == 'e') 6967 { /* write */ 6968 352 return -KEY_write; 6969 } 6970 6971 559052 goto unknown; 6972 6973 default: 6974 559052 goto unknown; 6975 } 6976 6977 default: 6978 559052 goto unknown; 6979 } 6980 6981 case 6: /* 33 tokens of length 6 */ 6982 559052 switch (name[0]) 6983 { 6984 case 'a': 6985 641 if (name[1] == 'c' && 6986 name[2] == 'c' && 6987 name[3] == 'e' && 6988 name[4] == 'p' && 6989 name[5] == 't') 6990 { /* accept */ 6991 17 return -KEY_accept; 6992 } 6993 6994 33808 goto unknown; 6995 6996 case 'c': 6997 33808 switch (name[1]) 6998 { 6999 case 'a': 7000 32311 if (name[2] == 'l' && 7001 name[3] == 'l' && 7002 name[4] == 'e' && 7003 name[5] == 'r') 7004 { /* caller */ 7005 32101 return -KEY_caller; 7006 } 7007 7008 13 goto unknown; 7009 7010 case 'h': 7011 13 if (name[2] == 'r' && 7012 name[3] == 'o' && 7013 name[4] == 'o' && 7014 name[5] == 't') 7015 { /* chroot */ 7016 3 return -KEY_chroot; 7017 } 7018 7019 11653 goto unknown; 7020 7021 default: 7022 11653 goto unknown; 7023 } 7024 7025 case 'd': 7026 11653 if (name[1] == 'e' && 7027 name[2] == 'l' && 7028 name[3] == 'e' && 7029 name[4] == 't' && 7030 name[5] == 'e') 7031 { /* delete */ 7032 10835 return KEY_delete; 7033 } 7034 7035 27559 goto unknown; 7036 7037 case 'e': 7038 27559 switch (name[1]) 7039 { 7040 case 'l': 7041 2 if (name[2] == 's' && 7042 name[3] == 'e' && 7043 name[4] == 'i' && 7044 name[5] == 'f') 7045 { /* elseif */ 7046 2 if(ckWARN_d(WARN_SYNTAX)) 7047 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif"); 7048 } 7049 7050 1 goto unknown; 7051 7052 case 'x': 7053 27407 if (name[2] == 'i' && 7054 name[3] == 's' && 7055 name[4] == 't' && 7056 name[5] == 's') 7057 { /* exists */ 7058 23189 return KEY_exists; 7059 } 7060 7061 1294 goto unknown; 7062 7063 default: 7064 1294 goto unknown; 7065 } 7066 7067 case 'f': 7068 1294 switch (name[1]) 7069 { 7070 case 'i': 7071 856 if (name[2] == 'l' && 7072 name[3] == 'e' && 7073 name[4] == 'n' && 7074 name[5] == 'o') 7075 { /* fileno */ 7076 856 return -KEY_fileno; 7077 } 7078 7079 125 goto unknown; 7080 7081 case 'o': 7082 125 if (name[2] == 'r' && 7083 name[3] == 'm' && 7084 name[4] == 'a' && 7085 name[5] == 't') 7086 { /* format */ 7087 108 return KEY_format; 7088 } 7089 7090 4126 goto unknown; 7091 7092 default: 7093 4126 goto unknown; 7094 } 7095 7096 case 'g': 7097 4126 if (name[1] == 'm' && 7098 name[2] == 't' && 7099 name[3] == 'i' && 7100 name[4] == 'm' && 7101 name[5] == 'e') 7102 { /* gmtime */ 7103 224 return -KEY_gmtime; 7104 } 7105 7106 24663 goto unknown; 7107 7108 case 'l': 7109 24663 switch (name[1]) 7110 { 7111 case 'e': 7112 22604 if (name[2] == 'n' && 7113 name[3] == 'g' && 7114 name[4] == 't' && 7115 name[5] == 'h') 7116 { /* length */ 7117 22586 return -KEY_length; 7118 } 7119 7120 1846 goto unknown; 7121 7122 case 'i': 7123 1846 if (name[2] == 's' && 7124 name[3] == 't' && 7125 name[4] == 'e' && 7126 name[5] == 'n') 7127 { /* listen */ 7128 17 return -KEY_listen; 7129 } 7130 7131 5098 goto unknown; 7132 7133 default: 7134 5098 goto unknown; 7135 } 7136 7137 case 'm': 7138 5098 if (name[1] == 's' && 7139 name[2] == 'g') 7140 { 7141 23 switch (name[3]) 7142 { 7143 case 'c': 7144 8 if (name[4] == 't' && 7145 name[5] == 'l') 7146 { /* msgctl */ 7147 8 return -KEY_msgctl; 7148 } 7149 7150 5 goto unknown; 7151 7152 case 'g': 7153 5 if (name[4] == 'e' && 7154 name[5] == 't') 7155 { /* msgget */ 7156 5 return -KEY_msgget; 7157 } 7158 7159 5 goto unknown; 7160 7161 case 'r': 7162 5 if (name[4] == 'c' && 7163 name[5] == 'v') 7164 { /* msgrcv */ 7165 5 return -KEY_msgrcv; 7166 } 7167 7168 5 goto unknown; 7169 7170 case 's': 7171 5 if (name[4] == 'n' && 7172 name[5] == 'd') 7173 { /* msgsnd */ 7174 5 return -KEY_msgsnd; 7175 } 7176 7177 1627 goto unknown; 7178 7179 default: 7180 1627 goto unknown; 7181 } 7182 } 7183 7184 1627 goto unknown; 7185 7186 case 'p': 7187 1627 if (name[1] == 'r' && 7188 name[2] == 'i' && 7189 name[3] == 'n' && 7190 name[4] == 't' && 7191 name[5] == 'f') 7192 { /* printf */ 7193 1060 return KEY_printf; 7194 } 7195 7196 197570 goto unknown; 7197 7198 case 'r': 7199 197570 switch (name[1]) 7200 { 7201 case 'e': 7202 196050 switch (name[2]) 7203 { 7204 case 'n': 7205 1212 if (name[3] == 'a' && 7206 name[4] == 'm' && 7207 name[5] == 'e') 7208 { /* rename */ 7209 1203 return -KEY_rename; 7210 } 7211 7212 193589 goto unknown; 7213 7214 case 't': 7215 193589 if (name[3] == 'u' && 7216 name[4] == 'r' && 7217 name[5] == 'n') 7218 { /* return */ 7219 193589 return KEY_return; 7220 } 7221 7222 390 goto unknown; 7223 7224 default: 7225 390 goto unknown; 7226 } 7227 7228 case 'i': 7229 390 if (name[2] == 'n' && 7230 name[3] == 'd' && 7231 name[4] == 'e' && 7232 name[5] == 'x') 7233 { /* rindex */ 7234 390 return -KEY_rindex; 7235 } 7236 7237 30718 goto unknown; 7238 7239 default: 7240 30718 goto unknown; 7241 } 7242 7243 case 's': 7244 30718 switch (name[1]) 7245 { 7246 case 'c': 7247 7729 if (name[2] == 'a' && 7248 name[3] == 'l' && 7249 name[4] == 'a' && 7250 name[5] == 'r') 7251 { /* scalar */ 7252 7607 return KEY_scalar; 7253 } 7254 7255 2152 goto unknown; 7256 7257 case 'e': 7258 2152 switch (name[2]) 7259 { 7260 case 'l': 7261 2125 if (name[3] == 'e' && 7262 name[4] == 'c' && 7263 name[5] == 't') 7264 { /* select */ 7265 2125 return -KEY_select; 7266 } 7267 7268 22 goto unknown; 7269 7270 case 'm': 7271 22 switch (name[3]) 7272 { 7273 case 'c': 7274 18 if (name[4] == 't' && 7275 name[5] == 'l') 7276 { /* semctl */ 7277 18 return -KEY_semctl; 7278 } 7279 7280 4 goto unknown; 7281 7282 case 'g': 7283 4 if (name[4] == 'e' && 7284 name[5] == 't') 7285 { /* semget */ 7286 4 return -KEY_semget; 7287 } 7288 7289 6 goto unknown; 7290 7291 default: 7292 6 goto unknown; 7293 } 7294 7295 default: 7296 6 goto unknown; 7297 } 7298 7299 case 'h': 7300 6 if (name[2] == 'm') 7301 { 7302 6 switch (name[3]) 7303 { 7304 case 'c': 7305 3 if (name[4] == 't' && 7306 name[5] == 'l') 7307 { /* shmctl */ 7308 3 return -KEY_shmctl; 7309 } 7310 7311 3 goto unknown; 7312 7313 case 'g': 7314 3 if (name[4] == 'e' && 7315 name[5] == 't') 7316 { /* shmget */ 7317 3 return -KEY_shmget; 7318 } 7319 7320 90 goto unknown; 7321 7322 default: 7323 90 goto unknown; 7324 } 7325 } 7326 7327 90 goto unknown; 7328 7329 case 'o': 7330 90 if (name[2] == 'c' && 7331 name[3] == 'k' && 7332 name[4] == 'e' && 7333 name[5] == 't') 7334 { /* socket */ 7335 81 return -KEY_socket; 7336 } 7337 7338 3309 goto unknown; 7339 7340 case 'p': 7341 3309 if (name[2] == 'l' && 7342 name[3] == 'i' && 7343 name[4] == 'c' && 7344 name[5] == 'e') 7345 { /* splice */ 7346 3309 return -KEY_splice; 7347 } 7348 7349 16332 goto unknown; 7350 7351 case 'u': 7352 16332 if (name[2] == 'b' && 7353 name[3] == 's' && 7354 name[4] == 't' && 7355 name[5] == 'r') 7356 { /* substr */ 7357 16328 return -KEY_substr; 7358 } 7359 7360 904 goto unknown; 7361 7362 case 'y': 7363 904 if (name[2] == 's' && 7364 name[3] == 't' && 7365 name[4] == 'e' && 7366 name[5] == 'm') 7367 { /* system */ 7368 866 return -KEY_system; 7369 } 7370 7371 182538 goto unknown; 7372 7373 default: 7374 182538 goto unknown; 7375 } 7376 7377 case 'u': 7378 182538 if (name[1] == 'n') 7379 { 7380 182398 switch (name[2]) 7381 { 7382 case 'l': 7383 179465 switch (name[3]) 7384 { 7385 case 'e': 7386 174698 if (name[4] == 's' && 7387 name[5] == 's') 7388 { /* unless */ 7389 174698 return KEY_unless; 7390 } 7391 7392 4767 goto unknown; 7393 7394 case 'i': 7395 4767 if (name[4] == 'n' && 7396 name[5] == 'k') 7397 { /* unlink */ 7398 4729 return -KEY_unlink; 7399 } 7400 7401 1811 goto unknown; 7402 7403 default: 7404 1811 goto unknown; 7405 } 7406 7407 case 'p': 7408 1811 if (name[3] == 'a' && 7409 name[4] == 'c' && 7410 name[5] == 'k') 7411 { /* unpack */ 7412 1811 return -KEY_unpack; 7413 } 7414 7415 1865 goto unknown; 7416 7417 default: 7418 1865 goto unknown; 7419 } 7420 } 7421 7422 1865 goto unknown; 7423 7424 case 'v': 7425 1865 if (name[1] == 'a' && 7426 name[2] == 'l' && 7427 name[3] == 'u' && 7428 name[4] == 'e' && 7429 name[5] == 's') 7430 { /* values */ 7431 1374 return -KEY_values; 7432 } 7433 7434 411291 goto unknown; 7435 7436 default: 7437 411291 goto unknown; 7438 } 7439 7440 case 7: /* 28 tokens of length 7 */ 7441 411291 switch (name[0]) 7442 { 7443 case 'D': 7444 124 if (name[1] == 'E' && 7445 name[2] == 'S' && 7446 name[3] == 'T' && 7447 name[4] == 'R' && 7448 name[5] == 'O' && 7449 name[6] == 'Y') 7450 { /* DESTROY */ 7451 7 return KEY_DESTROY; 7452 } 7453 7454 20229 goto unknown; 7455 7456 case '_': 7457 20229 if (name[1] == '_' && 7458 name[2] == 'E' && 7459 name[3] == 'N' && 7460 name[4] == 'D' && 7461 name[5] == '_' && 7462 name[6] == '_') 7463 { /* __END__ */ 7464 15387 return KEY___END__; 7465 } 7466 7467 2528 goto unknown; 7468 7469 case 'b': 7470 2528 if (name[1] == 'i' && 7471 name[2] == 'n' && 7472 name[3] == 'm' && 7473 name[4] == 'o' && 7474 name[5] == 'd' && 7475 name[6] == 'e') 7476 { /* binmode */ 7477 2455 return -KEY_binmode; 7478 } 7479 7480 3125 goto unknown; 7481 7482 case 'c': 7483 3125 if (name[1] == 'o' && 7484 name[2] == 'n' && 7485 name[3] == 'n' && 7486 name[4] == 'e' && 7487 name[5] == 'c' && 7488 name[6] == 't') 7489 { /* connect */ 7490 85 return -KEY_connect; 7491 } 7492 7493 123948 goto unknown; 7494 7495 case 'd': 7496 123948 switch (name[1]) 7497 { 7498 case 'b': 7499 3 if (name[2] == 'm' && 7500 name[3] == 'o' && 7501 name[4] == 'p' && 7502 name[5] == 'e' && 7503 name[6] == 'n') 7504 { /* dbmopen */ 7505 3 return -KEY_dbmopen; 7506 } 7507 7508 122787 goto unknown; 7509 7510 case 'e': 7511 122787 if (name[2] == 'f' && 7512 name[3] == 'i' && 7513 name[4] == 'n' && 7514 name[5] == 'e' && 7515 name[6] == 'd') 7516 { /* defined */ 7517 122622 return KEY_defined; 7518 } 7519 7520 62384 goto unknown; 7521 7522 default: 7523 62384 goto unknown; 7524 } 7525 7526 case 'f': 7527 62384 if (name[1] == 'o' && 7528 name[2] == 'r' && 7529 name[3] == 'e' && 7530 name[4] == 'a' && 7531 name[5] == 'c' && 7532 name[6] == 'h') 7533 { /* foreach */ 7534 59933 return KEY_foreach; 7535 } 7536 7537 134 goto unknown; 7538 7539 case 'g': 7540 134 if (name[1] == 'e' && 7541 name[2] == 't' && 7542 name[3] == 'p') 7543 { 7544 15 switch (name[4]) 7545 { 7546 case 'g': 7547 6 if (name[5] == 'r' && 7548 name[6] == 'p') 7549 { /* getpgrp */ 7550 6 return -KEY_getpgrp; 7551 } 7552 7553 9 goto unknown; 7554 7555 case 'p': 7556 9 if (name[5] == 'i' && 7557 name[6] == 'd') 7558 { /* getppid */ 7559 9 return -KEY_getppid; 7560 } 7561 7562 468 goto unknown; 7563 7564 default: 7565 468 goto unknown; 7566 } 7567 } 7568 7569 468 goto unknown; 7570 7571 case 'l': 7572 468 if (name[1] == 'c' && 7573 name[2] == 'f' && 7574 name[3] == 'i' && 7575 name[4] == 'r' && 7576 name[5] == 's' && 7577 name[6] == 't') 7578 { /* lcfirst */ 7579 15 return -KEY_lcfirst; 7580 } 7581 7582 1983 goto unknown; 7583 7584 case 'o': 7585 1983 if (name[1] == 'p' && 7586 name[2] == 'e' && 7587 name[3] == 'n' && 7588 name[4] == 'd' && 7589 name[5] == 'i' && 7590 name[6] == 'r') 7591 { /* opendir */ 7592 1940 return -KEY_opendir; 7593 } 7594 7595 39594 goto unknown; 7596 7597 case 'p': 7598 39594 if (name[1] == 'a' && 7599 name[2] == 'c' && 7600 name[3] == 'k' && 7601 name[4] == 'a' && 7602 name[5] == 'g' && 7603 name[6] == 'e') 7604 { /* package */ 7605 39218 return KEY_package; 7606 } 7607 7608 89663 goto unknown; 7609 7610 case 'r': 7611 89663 if (name[1] == 'e') 7612 { 7613 89252 switch (name[2]) 7614 { 7615 case 'a': 7616 2596 if (name[3] == 'd' && 7617 name[4] == 'd' && 7618 name[5] == 'i' && 7619 name[6] == 'r') 7620 { /* readdir */ 7621 2593 return -KEY_readdir; 7622 } 7623 7624 84669 goto unknown; 7625 7626 case 'q': 7627 84669 if (name[3] == 'u' && 7628 name[4] == 'i' && 7629 name[5] == 'r' && 7630 name[6] == 'e') 7631 { /* require */ 7632 84669 return KEY_require; 7633 } 7634 7635 1589 goto unknown; 7636 7637 case 'v': 7638 1589 if (name[3] == 'e' && 7639 name[4] == 'r' && 7640 name[5] == 's' && 7641 name[6] == 'e') 7642 { /* reverse */ 7643 1589 return -KEY_reverse; 7644 } 7645 7646 18744 goto unknown; 7647 7648 default: 7649 18744 goto unknown; 7650 } 7651 } 7652 7653 18744 goto unknown; 7654 7655 case 's': 7656 18744 switch (name[1]) 7657 { 7658 case 'e': 7659 27 switch (name[2]) 7660 { 7661 case 'e': 7662 4 if (name[3] == 'k' && 7663 name[4] == 'd' && 7664 name[5] == 'i' && 7665 name[6] == 'r') 7666 { /* seekdir */ 7667 4 return -KEY_seekdir; 7668 } 7669 7670 23 goto unknown; 7671 7672 case 't': 7673 23 if (name[3] == 'p' && 7674 name[4] == 'g' && 7675 name[5] == 'r' && 7676 name[6] == 'p') 7677 { /* setpgrp */ 7678 3 return -KEY_setpgrp; 7679 } 7680 7681 36 goto unknown; 7682 7683 default: 7684 36 goto unknown; 7685 } 7686 7687 case 'h': 7688 36 if (name[2] == 'm' && 7689 name[3] == 'r' && 7690 name[4] == 'e' && 7691 name[5] == 'a' && 7692 name[6] == 'd') 7693 { /* shmread */ 7694 3 return -KEY_shmread; 7695 } 7696 7697 15711 goto unknown; 7698 7699 case 'p': 7700 15711 if (name[2] == 'r' && 7701 name[3] == 'i' && 7702 name[4] == 'n' && 7703 name[5] == 't' && 7704 name[6] == 'f') 7705 { /* sprintf */ 7706 15331 return -KEY_sprintf; 7707 } 7708 7709 2318 goto unknown; 7710 7711 case 'y': 7712 2318 switch (name[2]) 7713 { 7714 case 'm': 7715 863 if (name[3] == 'l' && 7716 name[4] == 'i' && 7717 name[5] == 'n' && 7718 name[6] == 'k') 7719 { /* symlink */ 7720 26 return -KEY_symlink; 7721 } 7722 7723 1455 goto unknown; 7724 7725 case 's': 7726 1455 switch (name[3]) 7727 { 7728 case 'c': 7729 513 if (name[4] == 'a' && 7730 name[5] == 'l' && 7731 name[6] == 'l') 7732 { /* syscall */ 7733 19 return -KEY_syscall; 7734 } 7735 7736 134 goto unknown; 7737 7738 case 'o': 7739 134 if (name[4] == 'p' && 7740 name[5] == 'e' && 7741 name[6] == 'n') 7742 { /* sysopen */ 7743 134 return -KEY_sysopen; 7744 } 7745 7746 722 goto unknown; 7747 7748 case 'r': 7749 722 if (name[4] == 'e' && 7750 name[5] == 'a' && 7751 name[6] == 'd') 7752 { /* sysread */ 7753 722 return -KEY_sysread; 7754 } 7755 7756 80 goto unknown; 7757 7758 case 's': 7759 80 if (name[4] == 'e' && 7760 name[5] == 'e' && 7761 name[6] == 'k') 7762 { /* sysseek */ 7763 80 return -KEY_sysseek; 7764 } 7765 7766 432 goto unknown; 7767 7768 default: 7769 432 goto unknown; 7770 } 7771 7772 default: 7773 432 goto unknown; 7774 } 7775 7776 default: 7777 432 goto unknown; 7778 } 7779 7780 case 't': 7781 432 if (name[1] == 'e' && 7782 name[2] == 'l' && 7783 name[3] == 'l' && 7784 name[4] == 'd' && 7785 name[5] == 'i' && 7786 name[6] == 'r') 7787 { /* telldir */ 7788 6 return -KEY_telldir; 7789 } 7790 7791 7763 goto unknown; 7792 7793 case 'u': 7794 7763 switch (name[1]) 7795 { 7796 case 'c': 7797 28 if (name[2] == 'f' && 7798 name[3] == 'i' && 7799 name[4] == 'r' && 7800 name[5] == 's' && 7801 name[6] == 't') 7802 { /* ucfirst */ 7803 28 return -KEY_ucfirst; 7804 } 7805 7806 7647 goto unknown; 7807 7808 case 'n': 7809 7647 if (name[2] == 's' && 7810 name[3] == 'h' && 7811 name[4] == 'i' && 7812 name[5] == 'f' && 7813 name[6] == 't') 7814 { /* unshift */ 7815 7594 return -KEY_unshift; 7816 } 7817 7818 405 goto unknown; 7819 7820 default: 7821 405 goto unknown; 7822 } 7823 7824 case 'w': 7825 405 if (name[1] == 'a' && 7826 name[2] == 'i' && 7827 name[3] == 't' && 7828 name[4] == 'p' && 7829 name[5] == 'i' && 7830 name[6] == 'd') 7831 { /* waitpid */ 7832 86 return -KEY_waitpid; 7833 } 7834 7835 66538 goto unknown; 7836 7837 default: 7838 66538 goto unknown; 7839 } 7840 7841 case 8: /* 26 tokens of length 8 */ 7842 66538 switch (name[0]) 7843 { 7844 case 'A': 7845 735 if (name[1] == 'U' && 7846 name[2] == 'T' && 7847 name[3] == 'O' && 7848 name[4] == 'L' && 7849 name[5] == 'O' && 7850 name[6] == 'A' && 7851 name[7] == 'D') 7852 { /* AUTOLOAD */ 7853 665 return KEY_AUTOLOAD; 7854 } 7855 7856 7403 goto unknown; 7857 7858 case '_': 7859 7403 if (name[1] == '_') 7860 { 7861 504 switch (name[2]) 7862 { 7863 case 'D': 7864 128 if (name[3] == 'A' && 7865 name[4] == 'T' && 7866 name[5] == 'A' && 7867 name[6] == '_' && 7868 name[7] == '_') 7869 { /* __DATA__ */ 7870 128 return KEY___DATA__; 7871 } 7872 7873 260 goto unknown; 7874 7875 case 'F': 7876 260 if (name[3] == 'I' && 7877 name[4] == 'L' && 7878 name[5] == 'E' && 7879 name[6] == '_' && 7880 name[7] == '_') 7881 { /* __FILE__ */ 7882 260 return -KEY___FILE__; 7883 } 7884 7885 116 goto unknown; 7886 7887 case 'L': 7888 116 if (name[3] == 'I' && 7889 name[4] == 'N' && 7890 name[5] == 'E' && 7891 name[6] == '_' && 7892 name[7] == '_') 7893 { /* __LINE__ */ 7894 116 return -KEY___LINE__; 7895 } 7896 7897 4511 goto unknown; 7898 7899 default: 7900 4511 goto unknown; 7901 } 7902 } 7903 7904 4511 goto unknown; 7905 7906 case 'c': 7907 4511 switch (name[1]) 7908 { 7909 case 'l': 7910 2636 if (name[2] == 'o' && 7911 name[3] == 's' && 7912 name[4] == 'e' && 7913 name[5] == 'd' && 7914 name[6] == 'i' && 7915 name[7] == 'r') 7916 { /* closedir */ 7917 2636 return -KEY_closedir; 7918 } 7919 7920 1529 goto unknown; 7921 7922 case 'o': 7923 1529 if (name[2] == 'n' && 7924 name[3] == 't' && 7925 name[4] == 'i' && 7926 name[5] == 'n' && 7927 name[6] == 'u' && 7928 name[7] == 'e') 7929 { /* continue */ 7930 757 return -KEY_continue; 7931 } 7932 7933 1694 goto unknown; 7934 7935 default: 7936 1694 goto unknown; 7937 } 7938 7939 case 'd': 7940 1694 if (name[1] == 'b' && 7941 name[2] == 'm' && 7942 name[3] == 'c' && 7943 name[4] == 'l' && 7944 name[5] == 'o' && 7945 name[6] == 's' && 7946 name[7] == 'e') 7947 { /* dbmclose */ 7948 3 return -KEY_dbmclose; 7949 } 7950 7951 511 goto unknown; 7952 7953 case 'e': 7954 511 if (name[1] == 'n' && 7955 name[2] == 'd') 7956 { 7957 11 switch (name[3]) 7958 { 7959 case 'g': 7960 5 if (name[4] == 'r' && 7961 name[5] == 'e' && 7962 name[6] == 'n' && 7963 name[7] == 't') 7964 { /* endgrent */ 7965 5 return -KEY_endgrent; 7966 } 7967 7968 6 goto unknown; 7969 7970 case 'p': 7971 6 if (name[4] == 'w' && 7972 name[5] == 'e' && 7973 name[6] == 'n' && 7974 name[7] == 't') 7975 { /* endpwent */ 7976 6 return -KEY_endpwent; 7977 } 7978 7979 429 goto unknown; 7980 7981 default: 7982 429 goto unknown; 7983 } 7984 } 7985 7986 429 goto unknown; 7987 7988 case 'f': 7989 429 if (name[1] == 'o' && 7990 name[2] == 'r' && 7991 name[3] == 'm' && 7992 name[4] == 'l' && 7993 name[5] == 'i' && 7994 name[6] == 'n' && 7995 name[7] == 'e') 7996 { /* formline */ 7997 100 return -KEY_formline; 7998 } 7999 8000 660 goto unknown; 8001 8002 case 'g': 8003 660 if (name[1] == 'e' && 8004 name[2] == 't') 8005 { 8006 568 switch (name[3]) 8007 { 8008 case 'g': 8009 30 if (name[4] == 'r') 8010 { 8011 30 switch (name[5]) 8012 { 8013 case 'e': 8014 5 if (name[6] == 'n' && 8015 name[7] == 't') 8016 { /* getgrent */ 8017 5 return -KEY_getgrent; 8018 } 8019 8020 19 goto unknown; 8021 8022 case 'g': 8023 19 if (name[6] == 'i' && 8024 name[7] == 'd') 8025 { /* getgrgid */ 8026 19 return -KEY_getgrgid; 8027 } 8028 8029 6 goto unknown; 8030 8031 case 'n': 8032 6 if (name[6] == 'a' && 8033 name[7] == 'm') 8034 { /* getgrnam */ 8035 6 return -KEY_getgrnam; 8036 } 8037 8038 6 goto unknown; 8039 8040 default: 8041 6 goto unknown; 8042 } 8043 } 8044 8045 6 goto unknown; 8046 8047 case 'l': 8048 6 if (name[4] == 'o' && 8049 name[5] == 'g' && 8050 name[6] == 'i' && 8051 name[7] == 'n') 8052 { /* getlogin */ 8053 6 return -KEY_getlogin; 8054 } 8055 8056 244 goto unknown; 8057 8058 case 'p': 8059 244 if (name[4] == 'w') 8060 { 8061 244 switch (name[5]) 8062 { 8063 case 'e': 8064 7 if (name[6] == 'n' && 8065 name[7] == 't') 8066 { /* getpwent */ 8067 7 return -KEY_getpwent; 8068 } 8069 8070 104 goto unknown; 8071 8072 case 'n': 8073 104 if (name[6] == 'a' && 8074 name[7] == 'm') 8075 { /* getpwnam */ 8076 104 return -KEY_getpwnam; 8077 } 8078 8079 133 goto unknown; 8080 8081 case 'u': 8082 133 if (name[6] == 'i' && 8083 name[7] == 'd') 8084 { /* getpwuid */ 8085 133 return -KEY_getpwuid; 8086 } 8087 8088 1686 goto unknown; 8089 8090 default: 8091 1686 goto unknown; 8092 } 8093 } 8094 8095 1686 goto unknown; 8096 8097 default: 8098 1686 goto unknown; 8099 } 8100 } 8101 8102 1686 goto unknown; 8103 8104 case 'r': 8105 1686 if (name[1] == 'e' && 8106 name[2] == 'a' && 8107 name[3] == 'd') 8108 { 8109 937 switch (name[4]) 8110 { 8111 case 'l': 8112 918 if (name[5] == 'i' && 8113 name[6] == 'n') 8114 { 8115 918 switch (name[7]) 8116 { 8117 case 'e': 8118 { /* readline */ 8119 30 return -KEY_readline; 8120 } 8121 8122 case 'k': 8123 { /* readlink */ 8124 888 return -KEY_readlink; 8125 } 8126 8127 default: 8128 1 goto unknown; 8129 } 8130 } 8131 8132 1 goto unknown; 8133 8134 case 'p': 8135 1 if (name[5] == 'i' && 8136 name[6] == 'p' && 8137 name[7] == 'e') 8138 { /* readpipe */ 8139 1 return -KEY_readpipe; 8140 } 8141 8142 3644 goto unknown; 8143 8144 default: 8145 3644 goto unknown; 8146 } 8147 } 8148 8149 3644 goto unknown; 8150 8151 case 's': 8152 3644 switch (name[1]) 8153 { 8154 case 'e': 8155 2033 if (name[2] == 't') 8156 { 8157 1585 switch (name[3]) 8158 { 8159 case 'g': 8160 5 if (name[4] == 'r' && 8161 name[5] == 'e' && 8162 name[6] == 'n' && 8163 name[7] == 't') 8164 { /* setgrent */ 8165 5 return -KEY_setgrent; 8166 } 8167 8168 8 goto unknown; 8169 8170 case 'p': 8171 8 if (name[4] == 'w' && 8172 name[5] == 'e' && 8173 name[6] == 'n' && 8174 name[7] == 't') 8175 { /* setpwent */ 8176 8 return -KEY_setpwent; 8177 } 8178 8179 22 goto unknown; 8180 8181 default: 8182 22 goto unknown; 8183 } 8184 } 8185 8186 22 goto unknown; 8187 8188 case 'h': 8189 22 switch (name[2]) 8190 { 8191 case 'm': 8192 3 if (name[3] == 'w' && 8193 name[4] == 'r' && 8194 name[5] == 'i' && 8195 name[6] == 't' && 8196 name[7] == 'e') 8197 { /* shmwrite */ 8198 3 return -KEY_shmwrite; 8199 } 8200 8201 19 goto unknown; 8202 8203 case 'u': 8204 19 if (name[3] == 't' && 8205 name[4] == 'd' && 8206 name[5] == 'o' && 8207 name[6] == 'w' && 8208 name[7] == 'n') 8209 { /* shutdown */ 8210 19 return -KEY_shutdown; 8211 } 8212 8213 851 goto unknown; 8214 8215 default: 8216 851 goto unknown; 8217 } 8218 8219 case 'y': 8220 851 if (name[2] == 's' && 8221 name[3] == 'w' && 8222 name[4] == 'r' && 8223 name[5] == 'i' && 8224 name[6] == 't' && 8225 name[7] == 'e') 8226 { /* syswrite */ 8227 844 return -KEY_syswrite; 8228 } 8229 8230 638 goto unknown; 8231 8232 default: 8233 638 goto unknown; 8234 } 8235 8236 case 't': 8237 638 if (name[1] == 'r' && 8238 name[2] == 'u' && 8239 name[3] == 'n' && 8240 name[4] == 'c' && 8241 name[5] == 'a' && 8242 name[6] == 't' && 8243 name[7] == 'e') 8244 { /* truncate */ 8245 149 return -KEY_truncate; 8246 } 8247 8248 40140 goto unknown; 8249 8250 default: 8251 40140 goto unknown; 8252 } 8253 8254 case 9: /* 8 tokens of length 9 */ 8255 40140 switch (name[0]) 8256 { 8257 case 'e': 8258 232 if (name[1] == 'n' && 8259 name[2] == 'd' && 8260 name[3] == 'n' && 8261 name[4] == 'e' && 8262 name[5] == 't' && 8263 name[6] == 'e' && 8264 name[7] == 'n' && 8265 name[8] == 't') 8266 { /* endnetent */ 8267 2 return -KEY_endnetent; 8268 } 8269 8270 40 goto unknown; 8271 8272 case 'g': 8273 40 if (name[1] == 'e' && 8274 name[2] == 't' && 8275 name[3] == 'n' && 8276 name[4] == 'e' && 8277 name[5] == 't' && 8278 name[6] == 'e' && 8279 name[7] == 'n' && 8280 name[8] == 't') 8281 { /* getnetent */ 8282 4 return -KEY_getnetent; 8283 } 8284 8285 618 goto unknown; 8286 8287 case 'l': 8288 618 if (name[1] == 'o' && 8289 name[2] == 'c' && 8290 name[3] == 'a' && 8291 name[4] == 'l' && 8292 name[5] == 't' && 8293 name[6] == 'i' && 8294 name[7] == 'm' && 8295 name[8] == 'e') 8296 { /* localtime */ 8297 575 return -KEY_localtime; 8298 } 8299 8300 471 goto unknown; 8301 8302 case 'p': 8303 471 if (name[1] == 'r' && 8304 name[2] == 'o' && 8305 name[3] == 't' && 8306 name[4] == 'o' && 8307 name[5] == 't' && 8308 name[6] == 'y' && 8309 name[7] == 'p' && 8310 name[8] == 'e') 8311 { /* prototype */ 8312 189 return KEY_prototype; 8313 } 8314 8315 526 goto unknown; 8316 8317 case 'q': 8318 526 if (name[1] == 'u' && 8319 name[2] == 'o' && 8320 name[3] == 't' && 8321 name[4] == 'e' && 8322 name[5] == 'm' && 8323 name[6] == 'e' && 8324 name[7] == 't' && 8325 name[8] == 'a') 8326 { /* quotemeta */ 8327 507 return -KEY_quotemeta; 8328 } 8329 8330 295 goto unknown; 8331 8332 case 'r': 8333 295 if (name[1] == 'e' && 8334 name[2] == 'w' && 8335 name[3] == 'i' && 8336 name[4] == 'n' && 8337 name[5] == 'd' && 8338 name[6] == 'd' && 8339 name[7] == 'i' && 8340 name[8] == 'r') 8341 { /* rewinddir */ 8342 101 return -KEY_rewinddir; 8343 } 8344 8345 4498 goto unknown; 8346 8347 case 's': 8348 4498 if (name[1] == 'e' && 8349 name[2] == 't' && 8350 name[3] == 'n' && 8351 name[4] == 'e' && 8352 name[5] == 't' && 8353 name[6] == 'e' && 8354 name[7] == 'n' && 8355 name[8] == 't') 8356 { /* setnetent */ 8357 2 return -KEY_setnetent; 8358 } 8359 8360 6092 goto unknown; 8361 8362 case 'w': 8363 6092 if (name[1] == 'a' && 8364 name[2] == 'n' && 8365 name[3] == 't' && 8366 name[4] == 'a' && 8367 name[5] == 'r' && 8368 name[6] == 'r' && 8369 name[7] == 'a' && 8370 name[8] == 'y') 8371 { /* wantarray */ 8372 5825 return -KEY_wantarray; 8373 } 8374 8375 38256 goto unknown; 8376 8377 default: 8378 38256 goto unknown; 8379 } 8380 8381 case 10: /* 9 tokens of length 10 */ 8382 38256 switch (name[0]) 8383 { 8384 case 'e': 8385 140 if (name[1] == 'n' && 8386 name[2] == 'd') 8387 { 8388 4 switch (name[3]) 8389 { 8390 case 'h': 8391 2 if (name[4] == 'o' && 8392 name[5] == 's' && 8393 name[6] == 't' && 8394 name[7] == 'e' && 8395 name[8] == 'n' && 8396 name[9] == 't') 8397 { /* endhostent */ 8398 2 return -KEY_endhostent; 8399 } 8400 8401 2 goto unknown; 8402 8403 case 's': 8404 2 if (name[4] == 'e' && 8405 name[5] == 'r' && 8406 name[6] == 'v' && 8407 name[7] == 'e' && 8408 name[8] == 'n' && 8409 name[9] == 't') 8410 { /* endservent */ 8411 2 return -KEY_endservent; 8412 } 8413 8414 1002 goto unknown; 8415 8416 default: 8417 1002 goto unknown; 8418 } 8419 } 8420 8421 1002 goto unknown; 8422 8423 case 'g': 8424 1002 if (name[1] == 'e' && 8425 name[2] == 't') 8426 { 8427 959 switch (name[3]) 8428 { 8429 case 'h': 8430 4 if (name[4] == 'o' && 8431 name[5] == 's' && 8432 name[6] == 't' && 8433 name[7] == 'e' && 8434 name[8] == 'n' && 8435 name[9] == 't') 8436 { /* gethostent */ 8437 4 return -KEY_gethostent; 8438 } 8439 8440 32 goto unknown; 8441 8442 case 's': 8443 32 switch (name[4]) 8444 { 8445 case 'e': 8446 5 if (name[5] == 'r' && 8447 name[6] == 'v' && 8448 name[7] == 'e' && 8449 name[8] == 'n' && 8450 name[9] == 't') 8451 { /* getservent */ 8452 5 return -KEY_getservent; 8453 } 8454 8455 27 goto unknown; 8456 8457 case 'o': 8458 27 if (name[5] == 'c' && 8459 name[6] == 'k' && 8460 name[7] == 'o' && 8461 name[8] == 'p' && 8462 name[9] == 't') 8463 { /* getsockopt */ 8464 27 return -KEY_getsockopt; 8465 } 8466 8467 2182 goto unknown; 8468 8469 default: 8470 2182 goto unknown; 8471 } 8472 8473 default: 8474 2182 goto unknown; 8475 } 8476 } 8477 8478 2182 goto unknown; 8479 8480 case 's': 8481 2182 switch (name[1]) 8482 { 8483 case 'e': 8484 126 if (name[2] == 't') 8485 { 8486 126 switch (name[3]) 8487 { 8488 case 'h': 8489 2 if (name[4] == 'o' && 8490 name[5] == 's' && 8491 name[6] == 't' && 8492 name[7] == 'e' && 8493 name[8] == 'n' && 8494 name[9] == 't') 8495 { /* sethostent */ 8496 2 return -KEY_sethostent; 8497 } 8498 8499 121 goto unknown; 8500 8501 case 's': 8502 121 switch (name[4]) 8503 { 8504 case 'e': 8505 2 if (name[5] == 'r' && 8506 name[6] == 'v' && 8507 name[7] == 'e' && 8508 name[8] == 'n' && 8509 name[9] == 't') 8510 { /* setservent */ 8511 2 return -KEY_setservent; 8512 } 8513 8514 119 goto unknown; 8515 8516 case 'o': 8517 119 if (name[5] == 'c' && 8518 name[6] == 'k' && 8519 name[7] == 'o' && 8520 name[8] == 'p' && 8521 name[9] == 't') 8522 { /* setsockopt */ 8523 119 return -KEY_setsockopt; 8524 } 8525 8526 50 goto unknown; 8527 8528 default: 8529 50 goto unknown; 8530 } 8531 8532 default: 8533 50 goto unknown; 8534 } 8535 } 8536 8537 50 goto unknown; 8538 8539 case 'o': 8540 50 if (name[2] == 'c' && 8541 name[3] == 'k' && 8542 name[4] == 'e' && 8543 name[5] == 't' && 8544 name[6] == 'p' && 8545 name[7] == 'a' && 8546 name[8] == 'i' && 8547 name[9] == 'r') 8548 { /* socketpair */ 8549 17 return -KEY_socketpair; 8550 } 8551 8552 29361 goto unknown; 8553 8554 default: 8555 29361 goto unknown; 8556 } 8557 8558 default: 8559 29361 goto unknown; 8560 } 8561 8562 case 11: /* 8 tokens of length 11 */ 8563 29361 switch (name[0]) 8564 { 8565 case '_': 8566 7736 if (name[1] == '_' && 8567 name[2] == 'P' && 8568 name[3] == 'A' && 8569 name[4] == 'C' && 8570 name[5] == 'K' && 8571 name[6] == 'A' && 8572 name[7] == 'G' && 8573 name[8] == 'E' && 8574 name[9] == '_' && 8575 name[10] == '_') 8576 { /* __PACKAGE__ */ 8577 4984 return -KEY___PACKAGE__; 8578 } 8579 8580 55 goto unknown; 8581 8582 case 'e': 8583 55 if (name[1] == 'n' && 8584 name[2] == 'd' && 8585 name[3] == 'p' && 8586 name[4] == 'r' && 8587 name[5] == 'o' && 8588 name[6] == 't' && 8589 name[7] == 'o' && 8590 name[8] == 'e' && 8591 name[9] == 'n' && 8592 name[10] == 't') 8593 { /* endprotoent */ 8594 2 return -KEY_endprotoent; 8595 } 8596 8597 104 goto unknown; 8598 8599 case 'g': 8600 104 if (name[1] == 'e' && 8601 name[2] == 't') 8602 { 8603 104 switch (name[3]) 8604 { 8605 case 'p': 8606 74 switch (name[4]) 8607 { 8608 case 'e': 8609 63 if (name[5] == 'e' && 8610 name[6] == 'r' && 8611 name[7] == 'n' && 8612 name[8] == 'a' && 8613 name[9] == 'm' && 8614 name[10] == 'e') 8615 { /* getpeername */ 8616 63 return -KEY_getpeername; 8617 } 8618 8619 11 goto unknown; 8620 8621 case 'r': 8622 11 switch (name[5]) 8623 { 8624 case 'i': 8625 6 if (name[6] == 'o' && 8626 name[7] == 'r' && 8627 name[8] == 'i' && 8628 name[9] == 't' && 8629 name[10] == 'y') 8630 { /* getpriority */ 8631 6 return -KEY_getpriority; 8632 } 8633 8634 5 goto unknown; 8635 8636 case 'o': 8637 5 if (name[6] == 't' && 8638 name[7] == 'o' && 8639 name[8] == 'e' && 8640 name[9] == 'n' && 8641 name[10] == 't') 8642 { /* getprotoent */ 8643 5 return -KEY_getprotoent; 8644 } 8645 8646 19 goto unknown; 8647 8648 default: 8649 19 goto unknown; 8650 } 8651 8652 default: 8653 19 goto unknown; 8654 } 8655 8656 case 's': 8657 19 if (name[4] == 'o' && 8658 name[5] == 'c' && 8659 name[6] == 'k' && 8660 name[7] == 'n' && 8661 name[8] == 'a' && 8662 name[9] == 'm' && 8663 name[10] == 'e') 8664 { /* getsockname */ 8665 19 return -KEY_getsockname; 8666 } 8667 8668 2252 goto unknown; 8669 8670 default: 8671 2252 goto unknown; 8672 } 8673 } 8674 8675 2252 goto unknown; 8676 8677 case 's': 8678 2252 if (name[1] == 'e' && 8679 name[2] == 't' && 8680 name[3] == 'p' && 8681 name[4] == 'r') 8682 { 8683 5 switch (name[5]) 8684 { 8685 case 'i': 8686 3 if (name[6] == 'o' && 8687 name[7] == 'r' && 8688 name[8] == 'i' && 8689 name[9] == 't' && 8690 name[10] == 'y') 8691 { /* setpriority */ 8692 3 return -KEY_setpriority; 8693 } 8694 8695 2 goto unknown; 8696 8697 case 'o': 8698 2 if (name[6] == 't' && 8699 name[7] == 'o' && 8700 name[8] == 'e' && 8701 name[9] == 'n' && 8702 name[10] == 't') 8703 { /* setprotoent */ 8704 2 return -KEY_setprotoent; 8705 } 8706 8707 16297 goto unknown; 8708 8709 default: 8710 16297 goto unknown; 8711 } 8712 } 8713 8714 16297 goto unknown; 8715 8716 default: 8717 16297 goto unknown; 8718 } 8719 8720 case 12: /* 2 tokens of length 12 */ 8721 16297 if (name[0] == 'g' && 8722 name[1] == 'e' && 8723 name[2] == 't' && 8724 name[3] == 'n' && 8725 name[4] == 'e' && 8726 name[5] == 't' && 8727 name[6] == 'b' && 8728 name[7] == 'y') 8729 { 8730 10 switch (name[8]) 8731 { 8732 case 'a': 8733 4 if (name[9] == 'd' && 8734 name[10] == 'd' && 8735 name[11] == 'r') 8736 { /* getnetbyaddr */ 8737 4 return -KEY_getnetbyaddr; 8738 } 8739 8740 6 goto unknown; 8741 8742 case 'n': 8743 6 if (name[9] == 'a' && 8744 name[10] == 'm' && 8745 name[11] == 'e') 8746 { /* getnetbyname */ 8747 6 return -KEY_getnetbyname; 8748 } 8749 8750 11118 goto unknown; 8751 8752 default: 8753 11118 goto unknown; 8754 } 8755 } 8756 8757 11118 goto unknown; 8758 8759 case 13: /* 4 tokens of length 13 */ 8760 11118 if (name[0] == 'g' && 8761 name[1] == 'e' && 8762 name[2] == 't') 8763 { 8764 127 switch (name[3]) 8765 { 8766 case 'h': 8767 49 if (name[4] == 'o' && 8768 name[5] == 's' && 8769 name[6] == 't' && 8770 name[7] == 'b' && 8771 name[8] == 'y') 8772 { 8773 49 switch (name[9]) 8774 { 8775 case 'a': 8776 11 if (name[10] == 'd' && 8777 name[11] == 'd' && 8778 name[12] == 'r') 8779 { /* gethostbyaddr */ 8780 11 return -KEY_gethostbyaddr; 8781 } 8782 8783 38 goto unknown; 8784 8785 case 'n': 8786 38 if (name[10] == 'a' && 8787 name[11] == 'm' && 8788 name[12] == 'e') 8789 { /* gethostbyname */ 8790 38 return -KEY_gethostbyname; 8791 } 8792 8793 76 goto unknown; 8794 8795 default: 8796 76 goto unknown; 8797 } 8798 } 8799 8800 76 goto unknown; 8801 8802 case 's': 8803 76 if (name[4] == 'e' && 8804 name[5] == 'r' && 8805 name[6] == 'v' && 8806 name[7] == 'b' && 8807 name[8] == 'y') 8808 { 8809 76 switch (name[9]) 8810 { 8811 case 'n': 8812 71 if (name[10] == 'a' && 8813 name[11] == 'm' && 8814 name[12] == 'e') 8815 { /* getservbyname */ 8816 71 return -KEY_getservbyname; 8817 } 8818 8819 5 goto unknown; 8820 8821 case 'p': 8822 5 if (name[10] == 'o' && 8823 name[11] == 'r' && 8824 name[12] == 't') 8825 { /* getservbyport */ 8826 5 return -KEY_getservbyport; 8827 } 8828 8829 16153 goto unknown; 8830 8831 default: 8832 16153 goto unknown; 8833 } 8834 } 8835 8836 16153 goto unknown; 8837 8838 default: 8839 16153 goto unknown; 8840 } 8841 } 8842 8843 16153 goto unknown; 8844 8845 case 14: /* 1 tokens of length 14 */ 8846 16153 if (name[0] == 'g' && 8847 name[1] == 'e' && 8848 name[2] == 't' && 8849 name[3] == 'p' && 8850 name[4] == 'r' && 8851 name[5] == 'o' && 8852 name[6] == 't' && 8853 name[7] == 'o' && 8854 name[8] == 'b' && 8855 name[9] == 'y' && 8856 name[10] == 'n' && 8857 name[11] == 'a' && 8858 name[12] == 'm' && 8859 name[13] == 'e') 8860 { /* getprotobyname */ 8861 84 return -KEY_getprotobyname; 8862 } 8863 8864 8371 goto unknown; 8865 8866 case 16: /* 1 tokens of length 16 */ 8867 8371 if (name[0] == 'g' && 8868 name[1] == 'e' && 8869 name[2] == 't' && 8870 name[3] == 'p' && 8871 name[4] == 'r' && 8872 name[5] == 'o' && 8873 name[6] == 't' && 8874 name[7] == 'o' && 8875 name[8] == 'b' && 8876 name[9] == 'y' && 8877 name[10] == 'n' && 8878 name[11] == 'u' && 8879 name[12] == 'm' && 8880 name[13] == 'b' && 8881 name[14] == 'e' && 8882 name[15] == 'r') 8883 { /* getprotobynumber */ 8884 16 return -KEY_getprotobynumber; 8885 } 8886 8887 580012 goto unknown; 8888 8889 default: 8890 580012 goto unknown; 8891 } 8892 8893 unknown: 8894 580012 return 0; 8895 } 8896 8897 STATIC void 8898 S_checkcomma(pTHX_ register char *s, const char *name, const char *what) 8899 70400 { 8900 70400 const char *w; 8901 8902 70400 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ 8903 570 if (ckWARN(WARN_SYNTAX)) { 8904 105 int level = 1; 8905 4990 for (w = s+2; *w && level; w++) { 8906 4885 if (*w == '(') 8907 62 ++level; 8908 4823 else if (*w == ')') 8909 167 --level; 8910 } 8911 105 if (*w) 8912 108 for (; *w && isSPACE(*w); w++) ; 8913 105 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */ 8914 3 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 8915 "%s (...) interpreted as function",name); 8916 } 8917 } 8918 139884 while (s < PL_bufend && isSPACE(*s)) 8919 69484 s++; 8920 70400 if (*s == '(') 8921 1529 s++; 8922 70445 while (s < PL_bufend && isSPACE(*s)) 8923 45 s++; 8924 70400 if (isIDFIRST_lazy_if(s,UTF)) { 8925 27217 w = s++; 8926 128398 while (isALNUM_lazy_if(s,UTF)) 8927 101181 s++; 8928 51088 while (s < PL_bufend && isSPACE(*s)) 8929 23871 s++; 8930 27217 if (*s == ',') { 8931 ###### int kw; 8932 ###### *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */ 8933 ###### kw = keyword(w, s - w) || get_cv(w, FALSE) != 0; 8934 ###### *s = ','; 8935 ###### if (kw) 8936 ###### return; 8937 ###### Perl_croak(aTHX_ "No comma allowed after %s", what); 8938 } 8939 } 8940 } 8941 8942 /* Either returns sv, or mortalizes sv and returns a new SV*. 8943 Best used as sv=new_constant(..., sv, ...). 8944 If s, pv are NULL, calls subroutine with one argument, 8945 and type is used with error messages only. */ 8946 8947 STATIC SV * 8948 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv, 8949 const char *type) 8950 309 { 8951 309 dVAR; dSP; 8952 309 HV *table = GvHV(PL_hintgv); /* ^H */ 8953 309 SV *res; 8954 309 SV **cvp; 8955 309 SV *cv, *typesv; 8956 309 const char *why1 = "", *why2 = "", *why3 = ""; 8957 8958 309 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { 8959 ###### SV *msg; 8960 8961 ###### why2 = strEQ(key,"charnames") 8962 ? "(possibly a missing \"use charnames ...\")" 8963 : ""; 8964 ###### msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s", 8965 (type ? type: "undef"), why2); 8966 8967 /* This is convoluted and evil ("goto considered harmful") 8968 * but I do not understand the intricacies of all the different 8969 * failure modes of %^H in here. The goal here is to make 8970 * the most probable error message user-friendly. --jhi */ 8971 8972 ###### goto msgdone; 8973 8974 report: 8975 ###### msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s", 8976 (type ? type: "undef"), why1, why2, why3); 8977 msgdone: 8978 ###### yyerror(SvPVX_const(msg)); 8979 ###### SvREFCNT_dec(msg); 8980 ###### return sv; 8981 } 8982 309 cvp = hv_fetch(table, key, strlen(key), FALSE); 8983 309 if (!cvp || !SvOK(*cvp)) { 8984 ###### why1 = "$^H{"; 8985 ###### why2 = key; 8986 ###### why3 = "} is not defined"; 8987 ###### goto report; 8988 } 8989 309 sv_2mortal(sv); /* Parent created it permanently */ 8990 309 cv = *cvp; 8991 309 if (!pv && s) 8992 146 pv = sv_2mortal(newSVpvn(s, len)); 8993 309 if (type && pv) 8994 21 typesv = sv_2mortal(newSVpv(type, 0)); 8995 else 8996 288 typesv = &PL_sv_undef; 8997 8998 309 PUSHSTACKi(PERLSI_OVERLOAD); 8999 309 ENTER ; 9000 309 SAVETMPS; 9001 9002 309 PUSHMARK(SP) ; 9003 309 EXTEND(sp, 3); 9004 309 if (pv) 9005 154 PUSHs(pv); 9006 309 PUSHs(sv); 9007 309 if (pv) 9008 154 PUSHs(typesv); 9009 309 PUTBACK; 9010 309 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL)); 9011 9012 307 SPAGAIN ; 9013 9014 /* Check the eval first */ 9015 307 if (!PL_in_eval && SvTRUE(ERRSV)) { 9016 ###### sv_catpv(ERRSV, "Propagated"); 9017 ###### yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */ 9018 ###### (void)POPs; 9019 ###### res = SvREFCNT_inc(sv); 9020 } 9021 else { 9022 307 res = POPs; 9023 307 (void)SvREFCNT_inc(res); 9024 } 9025 9026 307 PUTBACK ; 9027 307 FREETMPS ; 9028 307 LEAVE ; 9029 307 POPSTACK; 9030 9031 307 if (!SvOK(res)) { 9032 ###### why1 = "Call to &{$^H{"; 9033 ###### why2 = key; 9034 ###### why3 = "}} did not return a defined value"; 9035 ###### sv = res; 9036 ###### goto report; 9037 } 9038 9039 307 return res; 9040 } 9041 9042 /* Returns a NUL terminated string, with the length of the string written to 9043 *slp 9044 */ 9045 STATIC char * 9046 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) 9047 6211533 { 9048 6211533 register char *d = dest; 9049 6211533 register char *e = d + destlen - 3; /* two-character token, ending NUL */ 9050 43221443 for (;;) { 9051 37009910 if (d >= e) 9052 ###### Perl_croak(aTHX_ ident_too_long); 9053 37009910 if (isALNUM(*s)) /* UTF handled below */ 9054 30596301 *d++ = *s++; 9055 6413609 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) { 9056 101 *d++ = ':'; 9057 101 *d++ = ':'; 9058 101 s++; 9059 } 9060 6413508 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') { 9061 201935 *d++ = *s++; 9062 201935 *d++ = *s++; 9063 } 9064 6211573 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { 9065 40 char *t = s + UTF8SKIP(s); 9066 40 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t)) 9067 ###### t += UTF8SKIP(t); 9068 40 if (d + (t - s) > e) 9069 ###### Perl_croak(aTHX_ ident_too_long); 9070 40 Copy(s, d, t - s, char); 9071 40 d += t - s; 9072 40 s = t; 9073 } 9074 else { 9075 6211533 *d = '\0'; 9076 6211533 *slp = d - dest; 9077 6211533 return s; 9078 } 9079 } 9080 } 9081 9082 STATIC char * 9083 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni) 9084 5428205 { 9085 5428205 register char *d; 9086 5428205 register char *e; 9087 5428205 char *bracket = 0; 9088 5428205 char funny = *s++; 9089 9090 5428205 if (isSPACE(*s)) 9091 2373 s = skipspace(s); 9092 5428205 d = dest; 9093 5428205 e = d + destlen - 3; /* two-character token, ending NUL */ 9094 5428205 if (isDIGIT(*s)) { 9095 110613 while (isDIGIT(*s)) { 9096 55317 if (d >= e) 9097 ###### Perl_croak(aTHX_ ident_too_long); 9098 55317 *d++ = *s++; 9099 } 9100 } 9101 else { 9102 35074533 for (;;) { 9103 29646328 if (d >= e) 9104 ###### Perl_croak(aTHX_ ident_too_long); 9105 29646328 if (isALNUM(*s)) /* UTF handled below */ 9106 24161709 *d++ = *s++; 9107 5484619 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) { 9108 365 *d++ = ':'; 9109 365 *d++ = ':'; 9110 365 s++; 9111 } 9112 5484254 else if (*s == ':' && s[1] == ':') { 9113 111327 *d++ = *s++; 9114 111327 *d++ = *s++; 9115 } 9116 5372927 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { 9117 18 char *t = s + UTF8SKIP(s); 9118 18 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t)) 9119 ###### t += UTF8SKIP(t); 9120 18 if (d + (t - s) > e) 9121 ###### Perl_croak(aTHX_ ident_too_long); 9122 18 Copy(s, d, t - s, char); 9123 18 d += t - s; 9124 18 s = t; 9125 } 9126 else 9127 5428205 break; 9128 } 9129 } 9130 5428205 *d = '\0'; 9131 5428205 d = dest; 9132 5428205 if (*d) { 9133 5031092 if (PL_lex_state != LEX_NORMAL) 9134 393134 PL_lex_state = LEX_INTERPENDMAYBE; 9135 5031092 return s; 9136 } 9137 397113 if (*s == '$' && s[1] && 9138 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) ) 9139 { 9140 111413 return s; 9141 } 9142 285700 if (*s == '{') { 9143 137765 bracket = s; 9144 137765 s++; 9145 } 9146 147935 else if (ck_uni) 9147 86 check_uni(); 9148 285700 if (s < send) 9149 285699 *d = *s++; 9150 285700 d[1] = '\0'; 9151 285700 if (*d == '^' && *s && isCONTROLVAR(*s)) { 9152 76621 *d = toCTRL(*s); 9153 76621 s++; 9154 } 9155 285700 if (bracket) { 9156 137765 if (isSPACE(s[-1])) { 9157 7113 while (s < send) { 9158 7113 const char ch = *s++; 9159 7113 if (!SPACE_OR_TAB(ch)) { 9160 7106 *d = ch; 9161 break; 9162 } 9163 } 9164 } 9165 137765 if (isIDFIRST_lazy_if(d,UTF)) { 9166 39294 d++; 9167 39294 if (UTF) { 9168 3 e = s; 9169 30 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') { 9170 27 e += UTF8SKIP(e); 9171 27 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e)) 9172 ###### e += UTF8SKIP(e); 9173 } 9174 3 Copy(s, d, e - s, char); 9175 3 d += e - s; 9176 3 s = e; 9177 } 9178 else { 9179 202077 while ((isALNUM(*s) || *s == ':') && d < e) 9180 162786 *d++ = *s++; 9181 39291 if (d >= e) 9182 ###### Perl_croak(aTHX_ ident_too_long); 9183 } 9184 39294 *d = '\0'; 9185 39878 while (s < send && SPACE_OR_TAB(*s)) s++; 9186 39294 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { 9187 5 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) { 9188 2 const char *brack = *s == '[' ? "[...]" : "{...}"; 9189 2 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), 9190 "Ambiguous use of %c{%s%s} resolved to %c%s%s", 9191 funny, dest, brack, funny, dest, brack); 9192 } 9193 5 bracket++; 9194 5 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK); 9195 5 return s; 9196 } 9197 } 9198 /* Handle extended ${^Foo} variables 9199 * 1999-02-27 mjd-perl-patch@plover.com */ 9200 98471 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */ 9201 && isALNUM(*s)) 9202 { 9203 13030 d++; 9204 163293 while (isALNUM(*s) && d < e) { 9205 150263 *d++ = *s++; 9206 } 9207 13030 if (d >= e) 9208 ###### Perl_croak(aTHX_ ident_too_long); 9209 13030 *d = '\0'; 9210 } 9211 137760 if (*s == '}') { 9212 43112 s++; 9213 43112 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) { 9214 28519 PL_lex_state = LEX_INTERPEND; 9215 28519 PL_expect = XREF; 9216 } 9217 43112 if (funny == '#') 9218 ###### funny = '@'; 9219 43112 if (PL_lex_state == LEX_NORMAL) { 9220 14593 if (ckWARN(WARN_AMBIGUOUS) && 9221 (keyword(dest, d - dest) || get_cv(dest, FALSE))) 9222 { 9223 2 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), 9224 "Ambiguous use of %c{%s} resolved to %c%s", 9225 funny, dest, funny, dest); 9226 } 9227 } 9228 } 9229 else { 9230 94648 s = bracket; /* let the parser handle it */ 9231 94648 *dest = '\0'; 9232 } 9233 } 9234 147935 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s)) 9235 29385 PL_lex_state = LEX_INTERPEND; 9236 285695 return s; 9237 } 9238 9239 void 9240 Perl_pmflag(pTHX_ U32* pmfl, int ch) 9241 146185 { 9242 146185 if (ch == 'i') 9243 34767 *pmfl |= PMf_FOLD; 9244 111418 else if (ch == 'g') 9245 29143 *pmfl |= PMf_GLOBAL; 9246 82275 else if (ch == 'c') 9247 1031 *pmfl |= PMf_CONTINUE; 9248 81244 else if (ch == 'o') 9249 1894 *pmfl |= PMf_KEEP; 9250 79350 else if (ch == 'm') 9251 18572 *pmfl |= PMf_MULTILINE; 9252 60778 else if (ch == 's') 9253 42685 *pmfl |= PMf_SINGLELINE; 9254 18093 else if (ch == 'x') 9255 18093 *pmfl |= PMf_EXTENDED; 9256 } 9257 9258 STATIC char * 9259 S_scan_pat(pTHX_ char *start, I32 type) 9260 143463 { 9261 143463 PMOP *pm; 9262 143463 char *s = scan_str(start,FALSE,FALSE); 9263 9264 143463 if (!s) { 9265 15 char *delimiter = skipspace(start); 9266 15 Perl_croak(aTHX_ *delimiter == '?' 9267 ? "Search pattern not terminated or ternary operator parsed as search pattern" 9268 : "Search pattern not terminated" ); 9269 } 9270 9271 143448 pm = (PMOP*)newPMOP(type, 0); 9272 143446 if (PL_multi_open == '?') 9273 4 pm->op_pmflags |= PMf_ONCE; 9274 143446 if(type == OP_QR) { 9275 13640 while (*s && strchr("iomsx", *s)) 9276 3988 pmflag(&pm->op_pmflags,*s++); 9277 } 9278 else { 9279 174781 while (*s && strchr("iogcmsx", *s)) 9280 40987 pmflag(&pm->op_pmflags,*s++); 9281 } 9282 /* issue a warning if /c is specified,but /g is not */ 9283 143446 if (ckWARN(WARN_REGEXP) && 9284 (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)) 9285 { 9286 1 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g); 9287 } 9288 9289 143446 pm->op_pmpermflags = pm->op_pmflags; 9290 9291 143446 PL_lex_op = (OP*)pm; 9292 143446 yylval.ival = OP_MATCH; 9293 143446 return s; 9294 } 9295 9296 STATIC char * 9297 S_scan_subst(pTHX_ char *start) 9298 77195 { 9299 dVAR; 9300 77195 register char *s; 9301 77195 register PMOP *pm; 9302 77195 I32 first_start; 9303 77195 I32 es = 0; 9304 9305 77195 yylval.ival = OP_NULL; 9306 9307 77195 s = scan_str(start,FALSE,FALSE); 9308 9309 77195 if (!s) 9310 1 Perl_croak(aTHX_ "Substitution pattern not terminated"); 9311 9312 77194 if (s[-1] == PL_multi_open) 9313 73432 s--; 9314 9315 77194 first_start = PL_multi_start; 9316 77194 s = scan_str(s,FALSE,FALSE); 9317 77194 if (!s) { 9318 4 if (PL_lex_stuff) { 9319 4 SvREFCNT_dec(PL_lex_stuff); 9320 4 PL_lex_stuff = Nullsv; 9321 } 9322 4 Perl_croak(aTHX_ "Substitution replacement not terminated"); 9323 } 9324 77190 PL_multi_start = first_start; /* so whole substitution is taken together */ 9325 9326 77190 pm = (PMOP*)newPMOP(OP_SUBST, 0); 9327 125103 while (*s) { 9328 125103 if (*s == 'e') { 9329 4836 s++; 9330 4836 es++; 9331 } 9332 120267 else if (strchr("iogcmsx", *s)) 9333 43078 pmflag(&pm->op_pmflags,*s++); 9334 else 9335 77189 break; 9336 } 9337 9338 /* /c is not meaningful with s/// */ 9339 77189 if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE)) 9340 { 9341 2 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst); 9342 } 9343 9344 77189 if (es) { 9345 4461 SV *repl; 9346 4461 PL_sublex_info.super_bufptr = s; 9347 4461 PL_sublex_info.super_bufend = PL_bufend; 9348 4461 PL_multi_end = 0; 9349 4461 pm->op_pmflags |= PMf_EVAL; 9350 4461 repl = newSVpvn("",0); 9351 9297 while (es-- > 0) 9352 4836 sv_catpv(repl, es ? "eval " : "do "); 9353 4461 sv_catpvn(repl, "{ ", 2); 9354 4461 sv_catsv(repl, PL_lex_repl); 9355 4461 sv_catpvn(repl, " };", 2); 9356 4461 SvEVALED_on(repl); 9357 4461 SvREFCNT_dec(PL_lex_repl); 9358 4461 PL_lex_repl = repl; 9359 } 9360 9361 77189 pm->op_pmpermflags = pm->op_pmflags; 9362 77189 PL_lex_op = (OP*)pm; 9363 77189 yylval.ival = OP_SUBST; 9364 77189 return s; 9365 } 9366 9367 STATIC char * 9368 S_scan_trans(pTHX_ char *start) 9369 6453 { 9370 6453 register char* s; 9371 6453 OP *o; 9372 6453 short *tbl; 9373 6453 I32 squash; 9374 6453 I32 del; 9375 6453 I32 complement; 9376 9377 6453 yylval.ival = OP_NULL; 9378 9379 6453 s = scan_str(start,FALSE,FALSE); 9380 6453 if (!s) 9381 2 Perl_croak(aTHX_ "Transliteration pattern not terminated"); 9382 6451 if (s[-1] == PL_multi_open) 9383 6393 s--; 9384 9385 6451 s = scan_str(s,FALSE,FALSE); 9386 6451 if (!s) { 9387 8 if (PL_lex_stuff) { 9388 8 SvREFCNT_dec(PL_lex_stuff); 9389 8 PL_lex_stuff = Nullsv; 9390 } 9391 8 Perl_croak(aTHX_ "Transliteration replacement not terminated"); 9392 } 9393 9394 6443 complement = del = squash = 0; 9395 7813 while (1) { 9396 7813 switch (*s) { 9397 case 'c': 9398 192 complement = OPpTRANS_COMPLEMENT; 9399 192 break; 9400 case 'd': 9401 642 del = OPpTRANS_DELETE; 9402 642 break; 9403 case 's': 9404 536 squash = OPpTRANS_SQUASH; 9405 break; 9406 default: 9407 1370 goto no_more; 9408 } 9409 1370 s++; 9410 } 9411 no_more: 9412 9413 6443 New(803, tbl, complement&&!del?258:256, short); 9414 6443 o = newPVOP(OP_TRANS, 0, (char*)tbl); 9415 6442 o->op_private &= ~OPpTRANS_ALL; 9416 6442 o->op_private |= del|squash|complement| 9417 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)| 9418 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0); 9419 9420 6442 PL_lex_op = o; 9421 6442 yylval.ival = OP_TRANS; 9422 6442 return s; 9423 } 9424 9425 STATIC char * 9426 S_scan_heredoc(pTHX_ register char *s) 9427 26511 { 9428 26511 SV *herewas; 9429 26511 I32 op_type = OP_SCALAR; 9430 26511 I32 len; 9431 26511 SV *tmpstr; 9432 26511 char term; 9433 26511 const char newline[] = "\n"; 9434 26511 const char *found_newline; 9435 26511 register char *d; 9436 26511 register char *e; 9437 26511 char *peek; 9438 26511 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR)); 9439 9440 26511 s += 2; 9441 26511 d = PL_tokenbuf; 9442 26511 e = PL_tokenbuf + sizeof PL_tokenbuf - 1; 9443 26511 if (!outer) 9444 911 *d++ = '\n'; 9445 26511 for (peek = s; SPACE_OR_TAB(*peek); peek++) ; 9446 26511 if (*peek == '`' || *peek == '\'' || *peek =='"') { 9447 19611 s = peek; 9448 19611 term = *s++; 9449 19611 s = delimcpy(d, e, s, PL_bufend, term, &len); 9450 19611 d += len; 9451 19611 if (s < PL_bufend) 9452 19611 s++; 9453 } 9454 else { 9455 6900 if (*s == '\\') 9456 2 s++, term = '\''; 9457 else 9458 6898 term = '"'; 9459 6900 if (!isALNUM_lazy_if(s,UTF)) 9460 3 deprecate_old("bare << to mean <<\"\""); 9461 86392 for (; isALNUM_lazy_if(s,UTF); s++) { 9462 39746 if (d < e) 9463 39746 *d++ = *s; 9464 } 9465 } 9466 26511 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1) 9467 ###### Perl_croak(aTHX_ "Delimiter for here document is too long"); 9468 26511 *d++ = '\n'; 9469 26511 *d = '\0'; 9470 26511 len = d - PL_tokenbuf; 9471 #ifndef PERL_STRICT_CR 9472 26511 d = strchr(s, '\r'); 9473 26511 if (d) { 9474 ###### char * const olds = s; 9475 ###### s = d; 9476 ###### while (s < PL_bufend) { 9477 ###### if (*s == '\r') { 9478 ###### *d++ = '\n'; 9479 ###### if (*++s == '\n') 9480 ###### s++; 9481 } 9482 ###### else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */ 9483 ###### *d++ = *s++; 9484 ###### s++; 9485 } 9486 else 9487 ###### *d++ = *s++; 9488 } 9489 ###### *d = '\0'; 9490 ###### PL_bufend = d; 9491 ###### SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr)); 9492 ###### s = olds; 9493 } 9494 #endif 9495 26511 if ( outer || !(found_newline = ninstr(s,PL_bufend,newline,newline+1)) ) { 9496 25601 herewas = newSVpvn(s,PL_bufend-s); 9497 } 9498 else { 9499 910 s--; 9500 910 herewas = newSVpvn(s,found_newline-s); 9501 } 9502 26511 s += SvCUR(herewas); 9503 9504 26511 tmpstr = NEWSV(87,79); 9505 26511 sv_upgrade(tmpstr, SVt_PVIV); 9506 26511 if (term == '\'') { 9507 15481 op_type = OP_CONST; 9508 15481 SvIV_set(tmpstr, -1); 9509 } 9510 11030 else if (term == '`') { 9511 1 op_type = OP_BACKTICK; 9512 1 SvIV_set(tmpstr, '\\'); 9513 } 9514 9515 26511 CLINE; 9516 26511 PL_multi_start = CopLINE(PL_curcop); 9517 26511 PL_multi_open = PL_multi_close = '<'; 9518 26511 term = *PL_tokenbuf; 9519 26511 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) { 9520 1 char *bufptr = PL_sublex_info.super_bufptr; 9521 1 char *bufend = PL_sublex_info.super_bufend; 9522 1 char * const olds = s - SvCUR(herewas); 9523 1 s = strchr(bufptr, '\n'); 9524 1 if (!s) 9525 ###### s = bufend; 9526 1 d = s; 9527 17 while (s < bufend && 9528 (*s != term || memNE(s,PL_tokenbuf,len)) ) { 9529 16 if (*s++ == '\n') 9530 1 CopLINE_inc(PL_curcop); 9531 } 9532 1 if (s >= bufend) { 9533 ###### CopLINE_set(PL_curcop, (line_t)PL_multi_start); 9534 ###### missingterm(PL_tokenbuf); 9535 } 9536 1 sv_setpvn(herewas,bufptr,d-bufptr+1); 9537 1 sv_setpvn(tmpstr,d+1,s-d); 9538 1 s += len - 1; 9539 1 sv_catpvn(herewas,s,bufend-s); 9540 1 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char); 9541 9542 1 s = olds; 9543 1 goto retval; 9544 } 9545 26510 else if (!outer) { 9546 910 d = s; 9547 370509 while (s < PL_bufend && 9548 (*s != term || memNE(s,PL_tokenbuf,len)) ) { 9549 369599 if (*s++ == '\n') 9550 11261 CopLINE_inc(PL_curcop); 9551 } 9552 910 if (s >= PL_bufend) { 9553 ###### CopLINE_set(PL_curcop, (line_t)PL_multi_start); 9554 ###### missingterm(PL_tokenbuf); 9555 } 9556 910 sv_setpvn(tmpstr,d+1,s-d); 9557 910 s += len - 1; 9558 910 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */ 9559 9560 910 sv_catpvn(herewas,s,PL_bufend-s); 9561 910 sv_setsv(PL_linestr,herewas); 9562 910 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr); 9563 910 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 9564 910 PL_last_lop = PL_last_uni = Nullch; 9565 } 9566 else 9567 25600 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */ 9568 1461602 while (s >= PL_bufend) { /* multiple line string? */ 9569 1435092 if (!outer || 9570 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) { 9571 ###### CopLINE_set(PL_curcop, (line_t)PL_multi_start); 9572 ###### missingterm(PL_tokenbuf); 9573 } 9574 1435092 CopLINE_inc(PL_curcop); 9575 1435092 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 9576 1435092 PL_last_lop = PL_last_uni = Nullch; 9577 #ifndef PERL_STRICT_CR 9578 1435092 if (PL_bufend - PL_linestart >= 2) { 9579 1416891 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') || 9580 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r')) 9581 { 9582 ###### PL_bufend[-2] = '\n'; 9583 ###### PL_bufend--; 9584 ###### SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr)); 9585 } 9586 1416891 else if (PL_bufend[-1] == '\r') 9587 ###### PL_bufend[-1] = '\n'; 9588 } 9589 18201 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r') 9590 ###### PL_bufend[-1] = '\n'; 9591 #endif 9592 1435092 if (PERLDB_LINE && PL_curstash != PL_debstash) { 9593 ###### SV *sv = NEWSV(88,0); 9594 9595 ###### sv_upgrade(sv, SVt_PVMG); 9596 ###### sv_setsv(sv,PL_linestr); 9597 ###### (void)SvIOK_on(sv); 9598 ###### SvIV_set(sv, 0); 9599 ###### av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv); 9600 } 9601 1435092 if (*s == term && memEQ(s,PL_tokenbuf,len)) { 9602 25600 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr); 9603 25600 *(SvPVX(PL_linestr) + off ) = ' '; 9604 25600 sv_catsv(PL_linestr,herewas); 9605 25600 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 9606 25600 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */ 9607 } 9608 else { 9609 1409492 s = PL_bufend; 9610 1409492 sv_catsv(tmpstr,PL_linestr); 9611 } 9612 } 9613 26510 s++; 9614 retval: 9615 26511 PL_multi_end = CopLINE(PL_curcop); 9616 26511 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) { 9617 12526 SvPV_shrink_to_cur(tmpstr); 9618 } 9619 26511 SvREFCNT_dec(herewas); 9620 26511 if (!IN_BYTES) { 9621 26509 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr))) 9622 5 SvUTF8_on(tmpstr); 9623 26504 else if (PL_encoding) 9624 ###### sv_recode_to_utf8(tmpstr, PL_encoding); 9625 } 9626 26511 PL_lex_stuff = tmpstr; 9627 26511 yylval.ival = op_type; 9628 26511 return s; 9629 } 9630 9631 /* scan_inputsymbol 9632 takes: current position in input buffer 9633 returns: new position in input buffer 9634 side-effects: yylval and lex_op are set. 9635 9636 This code handles: 9637 9638 <> read from ARGV 9639 read from filehandle 9640 read from package qualified filehandle 9641 read from package qualified filehandle 9642 <$fh> read from filehandle in $fh 9643 <*.h> filename glob 9644 9645 */ 9646 9647 STATIC char * 9648 S_scan_inputsymbol(pTHX_ char *start) 9649 6800 { 9650 6800 register char *s = start; /* current position in buffer */ 9651 6800 register char *d; 9652 6800 const char *e; 9653 6800 char *end; 9654 6800 I32 len; 9655 9656 6800 d = PL_tokenbuf; /* start of temp holding space */ 9657 6800 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */ 9658 6800 end = strchr(s, '\n'); 9659 6800 if (!end) 9660 2 end = PL_bufend; 9661 6800 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */ 9662 9663 /* die if we didn't have space for the contents of the <>, 9664 or if it didn't end, or if we see a newline 9665 */ 9666 9667 6800 if (len >= sizeof PL_tokenbuf) 9668 ###### Perl_croak(aTHX_ "Excessively long <> operator"); 9669 6800 if (s >= end) 9670 2 Perl_croak(aTHX_ "Unterminated <> operator"); 9671 9672 6798 s++; 9673 9674 /* check for <$fh> 9675 Remember, only scalar variables are interpreted as filehandles by 9676 this code. Anything more complex (e.g., <$fh{$num}>) will be 9677 treated as a glob() call. 9678 This code makes use of the fact that except for the $ at the front, 9679 a scalar variable and a filehandle look the same. 9680 */ 9681 6798 if (*d == '$' && d[1]) d++; 9682 9683 /* allow or */ 9684 29737 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':')) 9685 22939 d++; 9686 9687 /* If we've tried to read what we allow filehandles to look like, and 9688 there's still text left, then it must be a glob() and not a getline. 9689 Use scan_str to pull out the stuff between the <> and treat it 9690 as nothing more than a string. 9691 */ 9692 9693 6798 if (d - PL_tokenbuf != len) { 9694 129 yylval.ival = OP_GLOB; 9695 129 set_csh(); 9696 129 s = scan_str(start,FALSE,FALSE); 9697 129 if (!s) 9698 ###### Perl_croak(aTHX_ "Glob not terminated"); 9699 129 return s; 9700 } 9701 else { 9702 6669 bool readline_overriden = FALSE; 9703 6669 GV *gv_readline = Nullgv; 9704 6669 GV **gvp; 9705 /* we're in a filehandle read situation */ 9706 6669 d = PL_tokenbuf; 9707 9708 /* turn <> into */ 9709 6669 if (!len) 9710 469 Copy("ARGV",d,5,char); 9711 9712 /* Check whether readline() is overriden */ 9713 6669 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV)) 9714 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)) 9715 || 9716 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE)) 9717 && (gv_readline = *gvp) != (GV*)&PL_sv_undef 9718 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))) 9719 6 readline_overriden = TRUE; 9720 9721 /* if <$fh>, create the ops to turn the variable into a 9722 filehandle 9723 */ 9724 6669 if (*d == '$') { 9725 1693 I32 tmp; 9726 9727 /* try to find it in the pad for this block, otherwise find 9728 add symbol table ops 9729 */ 9730 1693 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) { 9731 1272 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) { 9732 2 HV *stash = PAD_COMPNAME_OURSTASH(tmp); 9733 2 HEK *stashname = HvNAME_HEK(stash); 9734 2 SV *sym = sv_2mortal(newSVhek(stashname)); 9735 2 sv_catpvn(sym, "::", 2); 9736 2 sv_catpv(sym, d+1); 9737 2 d = SvPVX(sym); 9738 2 goto intro_sym; 9739 } 9740 else { 9741 1270 OP *o = newOP(OP_PADSV, 0); 9742 1270 o->op_targ = tmp; 9743 1270 PL_lex_op = readline_overriden 9744 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, 9745 append_elem(OP_LIST, o, 9746 newCVREF(0, newGVOP(OP_GV,0,gv_readline)))) 9747 : (OP*)newUNOP(OP_READLINE, 0, o); 9748 } 9749 } 9750 else { 9751 421 GV *gv; 9752 421 ++d; 9753 intro_sym: 9754 423 gv = gv_fetchpv(d, 9755 (PL_in_eval 9756 ? (GV_ADDMULTI | GV_ADDINEVAL) 9757 : GV_ADDMULTI), 9758 SVt_PV); 9759 423 PL_lex_op = readline_overriden 9760 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, 9761 append_elem(OP_LIST, 9762 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)), 9763 newCVREF(0, newGVOP(OP_GV, 0, gv_readline)))) 9764 : (OP*)newUNOP(OP_READLINE, 0, 9765 newUNOP(OP_RV2SV, 0, 9766 newGVOP(OP_GV, 0, gv))); 9767 } 9768 1693 if (!readline_overriden) 9769 1689 PL_lex_op->op_flags |= OPf_SPECIAL; 9770 /* we created the ops in PL_lex_op, so make yylval.ival a null op */ 9771 1693 yylval.ival = OP_NULL; 9772 } 9773 9774 /* If it's none of the above, it must be a literal filehandle 9775 ( or ) so build a simple readline OP */ 9776 else { 9777 4976 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO); 9778 4976 PL_lex_op = readline_overriden 9779 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, 9780 append_elem(OP_LIST, 9781 newGVOP(OP_GV, 0, gv), 9782 newCVREF(0, newGVOP(OP_GV, 0, gv_readline)))) 9783 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv)); 9784 4975 yylval.ival = OP_NULL; 9785 } 9786 } 9787 9788 6668 return s; 9789 } 9790 9791 9792 /* scan_str 9793 takes: start position in buffer 9794 keep_quoted preserve \ on the embedded delimiter(s) 9795 keep_delims preserve the delimiters around the string 9796 returns: position to continue reading from buffer 9797 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and 9798 updates the read buffer. 9799 9800 This subroutine pulls a string out of the input. It is called for: 9801 q single quotes q(literal text) 9802 ' single quotes 'literal text' 9803 qq double quotes qq(interpolate $here please) 9804 " double quotes "interpolate $here please" 9805 qx backticks qx(/bin/ls -l) 9806 ` backticks `/bin/ls -l` 9807 qw quote words @EXPORT_OK = qw( func() $spam ) 9808 m// regexp match m/this/ 9809 s/// regexp substitute s/this/that/ 9810 tr/// string transliterate tr/this/that/ 9811 y/// string transliterate y/this/that/ 9812 ($*@) sub prototypes sub foo ($) 9813 (stuff) sub attr parameters sub foo : attr(stuff) 9814 <> readline or globs , <>, <$fh>, or <*.c> 9815 9816 In most of these cases (all but <>, patterns and transliterate) 9817 yylex() calls scan_str(). m// makes yylex() call scan_pat() which 9818 calls scan_str(). s/// makes yylex() call scan_subst() which calls 9819 scan_str(). tr/// and y/// make yylex() call scan_trans() which 9820 calls scan_str(). 9821 9822 It skips whitespace before the string starts, and treats the first 9823 character as the delimiter. If the delimiter is one of ([{< then 9824 the corresponding "close" character )]}> is used as the closing 9825 delimiter. It allows quoting of delimiters, and if the string has 9826 balanced delimiters ([{<>}]) it allows nesting. 9827 9828 On success, the SV with the resulting string is put into lex_stuff or, 9829 if that is already non-NULL, into lex_repl. The second case occurs only 9830 when parsing the RHS of the special constructs s/// and tr/// (y///). 9831 For convenience, the terminating delimiter character is stuffed into 9832 SvIVX of the SV. 9833 */ 9834 9835 STATIC char * 9836 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) 9837 2167113 { 9838 2167113 SV *sv; /* scalar value: string */ 9839 2167113 char *tmps; /* temp string, used for delimiter matching */ 9840 2167113 register char *s = start; /* current position in the buffer */ 9841 2167113 register char term; /* terminating character */ 9842 2167113 register char *to; /* current position in the sv's data */ 9843 2167113 I32 brackets = 1; /* bracket nesting level */ 9844 2167113 bool has_utf8 = FALSE; /* is there any utf8 content? */ 9845 2167113 I32 termcode; /* terminating char. code */ 9846 2167113 U8 termstr[UTF8_MAXBYTES]; /* terminating string */ 9847 2167113 STRLEN termlen; /* length of terminating string */ 9848 2167113 char *last = NULL; /* last position for nesting bracket */ 9849 9850 /* skip space before the delimiter */ 9851 2167113 if (isSPACE(*s)) 9852 2860 s = skipspace(s); 9853 9854 /* mark where we are, in case we need to report errors */ 9855 2167113 CLINE; 9856 9857 /* after skipping whitespace, the next character is the terminator */ 9858 2167113 term = *s; 9859 2167113 if (!UTF) { 9860 2166010 termcode = termstr[0] = term; 9861 2166010 termlen = 1; 9862 } 9863 else { 9864 1103 termcode = utf8_to_uvchr((U8*)s, &termlen); 9865 1103 Copy(s, termstr, termlen, U8); 9866 1103 if (!UTF8_IS_INVARIANT(term)) 9867 2 has_utf8 = TRUE; 9868 } 9869 9870 /* mark where we are */ 9871 2167113 PL_multi_start = CopLINE(PL_curcop); 9872 2167113 PL_multi_open = term; 9873 9874 /* find corresponding closing delimiter */ 9875 2167113 if (term && (tmps = strchr("([{< )]}> )]}>",term))) 9876 112496 termcode = termstr[0] = term = tmps[5]; 9877 9878 2167113 PL_multi_close = term; 9879 9880 /* create a new SV to hold the contents. 87 is leak category, I'm 9881 assuming. 79 is the SV's initial length. What a random number. */ 9882 2167113 sv = NEWSV(87,79); 9883 2167113 sv_upgrade(sv, SVt_PVIV); 9884 2167113 SvIV_set(sv, termcode); 9885 2167113 (void)SvPOK_only(sv); /* validate pointer */ 9886 9887 /* move past delimiter and try to read a complete string */ 9888 2167113 if (keep_delims) 9889 60 sv_catpvn(sv, s, termlen); 9890 2167113 s += termlen; 9891 2501763 for (;;) { 9892 2334438 if (PL_encoding && !UTF) { 9893 298 bool cont = TRUE; 9894 9895 596 while (cont) { 9896 298 int offset = s - SvPVX_const(PL_linestr); 9897 298 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr, 9898 298 &offset, (char*)termstr, termlen); 9899 298 const char *ns = SvPVX_const(PL_linestr) + offset; 9900 298 char *svlast = SvEND(sv) - 1; 9901 9902 7686 for (; s < ns; s++) { 9903 3694 if (*s == '\n' && !PL_rsfp) 9904 ###### CopLINE_inc(PL_curcop); 9905 } 9906 298 if (!found) 9907 ###### goto read_more_line; 9908 else { 9909 /* handle quoted delimiters */ 9910 298 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') { 9911 ###### const char *t; 9912 ###### for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';) 9913 ###### t--; 9914 ###### if ((svlast-1 - t) % 2) { 9915 ###### if (!keep_quoted) { 9916 ###### *(svlast-1) = term; 9917 ###### *svlast = '\0'; 9918 ###### SvCUR_set(sv, SvCUR(sv) - 1); 9919 } 9920 ###### continue; 9921 } 9922 } 9923 298 if (PL_multi_open == PL_multi_close) { 9924 276 cont = FALSE; 9925 } 9926 else { 9927 22 const char *t; 9928 22 char *w; 9929 22 if (!last) 9930 22 last = SvPVX(sv); 9931 433 for (t = w = last; t < svlast; w++, t++) { 9932 /* At here, all closes are "was quoted" one, 9933 so we don't check PL_multi_close. */ 9934 411 if (*t == '\\') { 9935 10 if (!keep_quoted && *(t+1) == PL_multi_open) 9936 ###### t++; 9937 else 9938 10 *w++ = *t++; 9939 } 9940 401 else if (*t == PL_multi_open) 9941 ###### brackets++; 9942 9943 411 *w = *t; 9944 } 9945 22 if (w < t) { 9946 ###### *w++ = term; 9947 ###### *w = '\0'; 9948 ###### SvCUR_set(sv, w - SvPVX_const(sv)); 9949 } 9950 22 last = w; 9951 22 if (--brackets <= 0) 9952 22 cont = FALSE; 9953 } 9954 } 9955 } 9956 298 if (!keep_delims) { 9957 298 SvCUR_set(sv, SvCUR(sv) - 1); 9958 298 *SvEND(sv) = '\0'; 9959 } 9960 298 break; 9961 } 9962 9963 /* extend sv if need be */ 9964 2334140 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1); 9965 /* set 'to' to the next character in the sv's string */ 9966 2334140 to = SvPVX(sv)+SvCUR(sv); 9967 9968 /* if open delimiter is the close delimiter read unbridle */ 9969 2334140 if (PL_multi_open == PL_multi_close) { 9970 53664990 for (; s < PL_bufend; s++,to++) { 9971 /* embedded newlines increment the current line number */ 9972 27846375 if (*s == '\n' && !PL_rsfp) 9973 1862 CopLINE_inc(PL_curcop); 9974 /* handle quoted delimiters */ 9975 27846375 if (*s == '\\' && s+1 < PL_bufend && term != '\\') { 9976 3020524 if (!keep_quoted && s[1] == term) 9977 25557 s++; 9978 /* any other quotes are simply copied straight through */ 9979 else 9980 2994967 *to++ = *s++; 9981 } 9982 /* terminate when run out of buffer (the for() condition), or 9983 have found the terminator */ 9984 24825851 else if (*s == term) { 9985 2054307 if (termlen == 1) 9986 2054305 break; 9987 2 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen)) 9988 2 break; 9989 } 9990 22771544 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) 9991 70 has_utf8 = TRUE; 9992 25792068 *to = *s; 9993 } 9994 } 9995 9996 /* if the terminator isn't the same as the start character (e.g., 9997 matched brackets), we have to allow more in the quoting, and 9998 be prepared for nested brackets. 9999 */ 10000 else { 10001 /* read until we run out of string, or we find the terminator */ 10002 10119518 for (; s < PL_bufend; s++,to++) { 10003 /* embedded newlines increment the line count */ 10004 5045586 if (*s == '\n' && !PL_rsfp) 10005 23 CopLINE_inc(PL_curcop); 10006 /* backslashes can escape the open or closing characters */ 10007 5045586 if (*s == '\\' && s+1 < PL_bufend) { 10008 42892 if (!keep_quoted && 10009 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))) 10010 74 s++; 10011 else 10012 42818 *to++ = *s++; 10013 } 10014 /* allow nested opens and closes */ 10015 5002694 else if (*s == PL_multi_close && --brackets <= 0) 10016 112470 break; 10017 4890224 else if (*s == PL_multi_open) 10018 5742 brackets++; 10019 4884482 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) 10020 1 has_utf8 = TRUE; 10021 4933116 *to = *s; 10022 } 10023 } 10024 /* terminate the copied string and update the sv's end-of-string */ 10025 2334140 *to = '\0'; 10026 2334140 SvCUR_set(sv, to - SvPVX_const(sv)); 10027 10028 /* 10029 * this next chunk reads more into the buffer if we're not done yet 10030 */ 10031 10032 2334140 if (s < PL_bufend) 10033 2166777 break; /* handle case where we are done yet :-) */ 10034 10035 #ifndef PERL_STRICT_CR 10036 167363 if (to - SvPVX_const(sv) >= 2) { 10037 156200 if ((to[-2] == '\r' && to[-1] == '\n') || 10038 (to[-2] == '\n' && to[-1] == '\r')) 10039 { 10040 ###### to[-2] = '\n'; 10041 ###### to--; 10042 ###### SvCUR_set(sv, to - SvPVX_const(sv)); 10043 } 10044 156200 else if (to[-1] == '\r') 10045 ###### to[-1] = '\n'; 10046 } 10047 11163 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r') 10048 ###### to[-1] = '\n'; 10049 #endif 10050 10051 read_more_line: 10052 /* if we're out of file, or a read fails, bail and reset the current 10053 line marker so we can report where the unterminated string began 10054 */ 10055 167363 if (!PL_rsfp || 10056 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) { 10057 38 sv_free(sv); 10058 38 CopLINE_set(PL_curcop, (line_t)PL_multi_start); 10059 38 return Nullch; 10060 } 10061 /* we read a line, so increment our line counter */ 10062 167325 CopLINE_inc(PL_curcop); 10063 10064 /* update debugger info */ 10065 167325 if (PERLDB_LINE && PL_curstash != PL_debstash) { 10066 ###### SV *sv = NEWSV(88,0); 10067 10068 ###### sv_upgrade(sv, SVt_PVMG); 10069 ###### sv_setsv(sv,PL_linestr); 10070 ###### (void)SvIOK_on(sv); 10071 ###### SvIV_set(sv, 0); 10072 ###### av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv); 10073 } 10074 10075 /* having changed the buffer, we must update PL_bufend */ 10076 167325 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 10077 167325 PL_last_lop = PL_last_uni = Nullch; 10078 } 10079 10080 /* at this point, we have successfully read the delimited string */ 10081 10082 2167075 if (!PL_encoding || UTF) { 10083 2166777 if (keep_delims) 10084 56 sv_catpvn(sv, s, termlen); 10085 2166777 s += termlen; 10086 } 10087 2167075 if (has_utf8 || PL_encoding) 10088 371 SvUTF8_on(sv); 10089 10090 2167075 PL_multi_end = CopLINE(PL_curcop); 10091 10092 /* if we allocated too much space, give some back */ 10093 2167075 if (SvCUR(sv) + 5 < SvLEN(sv)) { 10094 2160721 SvLEN_set(sv, SvCUR(sv) + 1); 10095 2160721 SvPV_renew(sv, SvLEN(sv)); 10096 } 10097 10098 /* decide whether this is the first or second quoted string we've read 10099 for this op 10100 */ 10101 10102 2167075 if (PL_lex_stuff) 10103 83637 PL_lex_repl = sv; 10104 else 10105 2083438 PL_lex_stuff = sv; 10106 2167075 return s; 10107 } 10108 10109 /* 10110 scan_num 10111 takes: pointer to position in buffer 10112 returns: pointer to new position in buffer 10113 side-effects: builds ops for the constant in yylval.op 10114 10115 Read a number in any of the formats that Perl accepts: 10116 10117 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12. 10118 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34 10119 0b[01](_?[01])* 10120 0[0-7](_?[0-7])* 10121 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* 10122 10123 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the 10124 thing it reads. 10125 10126 If it reads a number without a decimal point or an exponent, it will 10127 try converting the number to an integer and see if it can do so 10128 without loss of precision. 10129 */ 10130 10131 char * 10132 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) 10133 874111 { 10134 874111 register const char *s = start; /* current position in buffer */ 10135 874111 register char *d; /* destination in temp buffer */ 10136 874111 register char *e; /* end of temp buffer */ 10137 874111 NV nv; /* number read, as a double */ 10138 874111 SV *sv = Nullsv; /* place to put the converted number */ 10139 874111 bool floatit; /* boolean: int or float? */ 10140 874111 const char *lastub = 0; /* position of last underbar */ 10141 874111 static char const number_too_long[] = "Number too long"; 10142 10143 /* We use the first character to decide what type of number this is */ 10144 10145 874111 switch (*s) { 10146 default: 10147 ###### Perl_croak(aTHX_ "panic: scan_num"); 10148 10149 /* if it starts with a 0, it could be an octal number, a decimal in 10150 0.13 disguise, or a hexadecimal number, or a binary number. */ 10151 case '0': 10152 { 10153 /* variables: 10154 u holds the "number so far" 10155 shift the power of 2 of the base 10156 (hex == 4, octal == 3, binary == 1) 10157 overflowed was the number more than we can hold? 10158 10159 Shift is used when we add a digit. It also serves as an "are 10160 we in octal/hex/binary?" indicator to disallow hex characters 10161 when in octal mode. 10162 */ 10163 312993 NV n = 0.0; 10164 312993 UV u = 0; 10165 312993 I32 shift; 10166 312993 bool overflowed = FALSE; 10167 312993 bool just_zero = TRUE; /* just plain 0 or binary number? */ 10168 312993 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 }; 10169 static const char* const bases[5] = 10170 312993 { "", "binary", "", "octal", "hexadecimal" }; 10171 static const char* const Bases[5] = 10172 312993 { "", "Binary", "", "Octal", "Hexadecimal" }; 10173 static const char* const maxima[5] = 10174 { "", 10175 "0b11111111111111111111111111111111", 10176 "", 10177 "037777777777", 10178 312993 "0xffffffff" }; 10179 312993 const char *base, *Base, *max; 10180 10181 /* check for hex */ 10182 312993 if (s[1] == 'x') { 10183 15084 shift = 4; 10184 15084 s += 2; 10185 15084 just_zero = FALSE; 10186 297909 } else if (s[1] == 'b') { 10187 28 shift = 1; 10188 28 s += 2; 10189 28 just_zero = FALSE; 10190 } 10191 /* check for a decimal in disguise */ 10192 297881 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E') 10193 291975 goto decimal; 10194 /* so it must be octal */ 10195 else { 10196 291975 shift = 3; 10197 291975 s++; 10198 } 10199 10200 307087 if (*s == '_') { 10201 4 if (ckWARN(WARN_SYNTAX)) 10202 ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 10203 "Misplaced _ in number"); 10204 4 lastub = s++; 10205 } 10206 10207 307087 base = bases[shift]; 10208 307087 Base = Bases[shift]; 10209 307087 max = maxima[shift]; 10210 10211 /* read the rest of the number */ 10212 418122 for (;;) { 10213 /* x is used in the overflow test, 10214 b is the digit we're adding on. */ 10215 418010 UV x, b; 10216 10217 418010 switch (*s) { 10218 10219 /* if we don't mention it, we're done */ 10220 default: 10221 12 goto out; 10222 10223 /* _ are ignored -- but warned about if consecutive */ 10224 case '_': 10225 12 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) 10226 ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 10227 "Misplaced _ in number"); 10228 12 lastub = s++; 10229 12 break; 10230 10231 /* 8 and 9 are not octal */ 10232 case '8': case '9': 10233 1290 if (shift == 3) 10234 ###### yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s)); 10235 /* FALL THROUGH */ 10236 10237 /* octal digits */ 10238 case '2': case '3': case '4': 10239 case '5': case '6': case '7': 10240 25568 if (shift == 1) 10241 1 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s)); 10242 /* FALL THROUGH */ 10243 10244 case '0': case '1': 10245 105670 b = *s++ & 15; /* ASCII digit -> value of digit */ 10246 105670 goto digit; 10247 10248 /* hex digits */ 10249 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': 10250 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': 10251 /* make sure they said 0x */ 10252 5241 if (shift != 4) 10253 ###### goto out; 10254 5241 b = (*s++ & 7) + 9; 10255 10256 /* Prepare to put the digit we have onto the end 10257 of the number so far. We check for overflows. 10258 */ 10259 10260 digit: 10261 110911 just_zero = FALSE; 10262 110911 if (!overflowed) { 10263 110811 x = u << shift; /* make room for the digit */ 10264 10265 110811 if ((x >> shift) != u 10266 && !(PL_hints & HINT_NEW_BINARY)) { 10267 12 overflowed = TRUE; 10268 12 n = (NV) u; 10269 12 if (ckWARN_d(WARN_OVERFLOW)) 10270 3 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), 10271 "Integer overflow in %s number", 10272 base); 10273 } else 10274 110799 u = x | b; /* add the digit to the end */ 10275 } 10276 110911 if (overflowed) { 10277 112 n *= nvshift[shift]; 10278 /* If an NV has not enough bits in its 10279 * mantissa to represent an UV this summing of 10280 * small low-order numbers is a waste of time 10281 * (because the NV cannot preserve the 10282 * low-order bits anyway): we could just 10283 * remember when did we overflow and in the 10284 * end just multiply n by the right 10285 * amount. */ 10286 112 n += (NV) b; 10287 } 10288 112 break; 10289 } 10290 } 10291 10292 /* if we get here, we had success: make a scalar value from 10293 the number. 10294 */ 10295 out: 10296 10297 /* final misplaced underbar check */ 10298 307086 if (s[-1] == '_') { 10299 ###### if (ckWARN(WARN_SYNTAX)) 10300 ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); 10301 } 10302 10303 307086 sv = NEWSV(92,0); 10304 307086 if (overflowed) { 10305 12 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0) 10306 3 Perl_warner(aTHX_ packWARN(WARN_PORTABLE), 10307 "%s number > %s non-portable", 10308 Base, max); 10309 12 sv_setnv(sv, n); 10310 } 10311 else { 10312 #if UVSIZE > 4 10313 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff) 10314 Perl_warner(aTHX_ packWARN(WARN_PORTABLE), 10315 "%s number > %s non-portable", 10316 Base, max); 10317 #endif 10318 307074 sv_setuv(sv, u); 10319 } 10320 307086 if (just_zero && (PL_hints & HINT_NEW_INTEGER)) 10321 1 sv = new_constant(start, s - start, "integer", 10322 sv, Nullsv, NULL); 10323 307085 else if (PL_hints & HINT_NEW_BINARY) 10324 2 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL); 10325 } 10326 2 break; 10327 10328 /* 10329 handle decimal numbers. 10330 we're also sent here when we read a 0 as the first digit 10331 */ 10332 case '1': case '2': case '3': case '4': case '5': 10333 case '6': case '7': case '8': case '9': case '.': 10334 decimal: 10335 565414 d = PL_tokenbuf; 10336 565414 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */ 10337 565414 floatit = FALSE; 10338 10339 /* read next group of digits and _ and copy into d */ 10340 1321479 while (isDIGIT(*s) || *s == '_') { 10341 /* skip underscores, checking for misplaced ones 10342 if -w is on 10343 */ 10344 756065 if (*s == '_') { 10345 292 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) 10346 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 10347 "Misplaced _ in number"); 10348 292 lastub = s++; 10349 } 10350 else { 10351 /* check for end of fixed-length buffer */ 10352 755773 if (d >= e) 10353 ###### Perl_croak(aTHX_ number_too_long); 10354 /* if we're ok, copy the character */ 10355 755773 *d++ = *s++; 10356 } 10357 } 10358 10359 /* final misplaced underbar check */ 10360 565414 if (lastub && s == lastub + 1) { 10361 6 if (ckWARN(WARN_SYNTAX)) 10362 3 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); 10363 } 10364 10365 /* read a decimal portion if there is one. avoid 10366 3..5 being interpreted as the number 3. followed 10367 by .5 10368 */ 10369 565414 if (*s == '.' && s[1] != '.') { 10370 20396 floatit = TRUE; 10371 20396 *d++ = *s++; 10372 10373 20396 if (*s == '_') { 10374 6 if (ckWARN(WARN_SYNTAX)) 10375 3 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 10376 "Misplaced _ in number"); 10377 6 lastub = s; 10378 } 10379 10380 /* copy, ignoring underbars, until we run out of digits. 10381 */ 10382 154842 for (; isDIGIT(*s) || *s == '_'; s++) { 10383 /* fixed length buffer check */ 10384 67223 if (d >= e) 10385 ###### Perl_croak(aTHX_ number_too_long); 10386 67223 if (*s == '_') { 10387 1712 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) 10388 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 10389 "Misplaced _ in number"); 10390 1712 lastub = s; 10391 } 10392 else 10393 65511 *d++ = *s; 10394 } 10395 /* fractional part ending in underbar? */ 10396 20396 if (s[-1] == '_') { 10397 6 if (ckWARN(WARN_SYNTAX)) 10398 3 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 10399 "Misplaced _ in number"); 10400 } 10401 20396 if (*s == '.' && isDIGIT(s[1])) { 10402 /* oops, it's really a v-string, but without the "v" */ 10403 80 s = start; 10404 80 goto vstring; 10405 } 10406 } 10407 10408 /* read exponent part, if present */ 10409 565334 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) { 10410 746 floatit = TRUE; 10411 746 s++; 10412 10413 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */ 10414 746 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */ 10415 10416 /* stray preinitial _ */ 10417 746 if (*s == '_') { 10418 6 if (ckWARN(WARN_SYNTAX)) 10419 3 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 10420 "Misplaced _ in number"); 10421 6 lastub = s++; 10422 } 10423 10424 /* allow positive or negative exponent */ 10425 746 if (*s == '+' || *s == '-') 10426 628 *d++ = *s++; 10427 10428 /* stray initial _ */ 10429 746 if (*s == '_') { 10430 4 if (ckWARN(WARN_SYNTAX)) 10431 2 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 10432 "Misplaced _ in number"); 10433 4 lastub = s++; 10434 } 10435 10436 /* read digits of exponent */ 10437 2183 while (isDIGIT(*s) || *s == '_') { 10438 1437 if (isDIGIT(*s)) { 10439 1421 if (d >= e) 10440 ###### Perl_croak(aTHX_ number_too_long); 10441 1421 *d++ = *s++; 10442 } 10443 else { 10444 16 if (ckWARN(WARN_SYNTAX) && 10445 ((lastub && s == lastub + 1) || 10446 (!isDIGIT(s[1]) && s[1] != '_'))) 10447 4 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 10448 "Misplaced _ in number"); 10449 16 lastub = s++; 10450 } 10451 } 10452 } 10453 10454 10455 /* make an sv from the string */ 10456 565334 sv = NEWSV(92,0); 10457 10458 /* 10459 We try to do an integer conversion first if no characters 10460 indicating "float" have been found. 10461 */ 10462 10463 565334 if (!floatit) { 10464 544307 UV uv; 10465 544307 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv); 10466 10467 544307 if (flags == IS_NUMBER_IN_UV) { 10468 544205 if (uv <= IV_MAX) 10469 544012 sv_setiv(sv, uv); /* Prefer IVs over UVs. */ 10470 else 10471 193 sv_setuv(sv, uv); 10472 102 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) { 10473 ###### if (uv <= (UV) IV_MIN) 10474 ###### sv_setiv(sv, -(IV)uv); 10475 else 10476 ###### floatit = TRUE; 10477 } else 10478 102 floatit = TRUE; 10479 } 10480 565334 if (floatit) { 10481 /* terminate the string */ 10482 21129 *d = '\0'; 10483 21129 nv = Atof(PL_tokenbuf); 10484 21129 sv_setnv(sv, nv); 10485 } 10486 10487 565334 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : 10488 (PL_hints & HINT_NEW_INTEGER) ) 10489 130 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf, 10490 (floatit ? "float" : "integer"), 10491 sv, Nullsv, NULL); 10492 130 break; 10493 10494 /* if it starts with a v, it could be a v-string */ 10495 case 'v': 10496 vstring: 10497 1690 sv = NEWSV(92,5); /* preallocate storage space */ 10498 1690 s = scan_vstring(s,sv); 10499 874110 break; 10500 } 10501 10502 /* make the op for the constant and return */ 10503 10504 874110 if (sv) 10505 874110 lvalp->opval = newSVOP(OP_CONST, 0, sv); 10506 else 10507 ###### lvalp->opval = Nullop; 10508 10509 874109 return (char *)s; 10510 } 10511 10512 STATIC char * 10513 S_scan_formline(pTHX_ register char *s) 10514 265 { 10515 265 register char *eol; 10516 265 register char *t; 10517 265 SV *stuff = newSVpvn("",0); 10518 265 bool needargs = FALSE; 10519 265 bool eofmt = FALSE; 10520 10521 450 while (!needargs) { 10522 308 if (*s == '.') { 10523 #ifdef PERL_STRICT_CR 10524 for (t = s+1;SPACE_OR_TAB(*t); t++) ; 10525 #else 10526 120 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ; 10527 #endif 10528 120 if (*t == '\n' || t == PL_bufend) { 10529 120 eofmt = TRUE; 10530 120 break; 10531 } 10532 } 10533 188 if (PL_in_eval && !PL_rsfp) { 10534 55 eol = (char *) memchr(s,'\n',PL_bufend-s); 10535 55 if (!eol++) 10536 3 eol = PL_bufend; 10537 } 10538 else 10539 133 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 10540 188 if (*s != '#') { 10541 6217 for (t = s; t < eol; t++) { 10542 6030 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) { 10543 1 needargs = FALSE; 10544 1 goto enough; /* ~~ must be first line in formline */ 10545 } 10546 6029 if (*t == '@' || *t == '^') 10547 314 needargs = TRUE; 10548 } 10549 187 if (eol > s) { 10550 185 sv_catpvn(stuff, s, eol-s); 10551 #ifndef PERL_STRICT_CR 10552 185 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') { 10553 ###### char *end = SvPVX(stuff) + SvCUR(stuff); 10554 ###### end[-2] = '\n'; 10555 ###### end[-1] = '\0'; 10556 ###### SvCUR_set(stuff, SvCUR(stuff) - 1); 10557 } 10558 #endif 10559 } 10560 else 10561 185 break; 10562 } 10563 185 s = (char*)eol; 10564 185 if (PL_rsfp) { 10565 133 s = filter_gets(PL_linestr, PL_rsfp, 0); 10566 133 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); 10567 133 PL_bufend = PL_bufptr + SvCUR(PL_linestr); 10568 133 PL_last_lop = PL_last_uni = Nullch; 10569 133 if (!s) { 10570 ###### s = PL_bufptr; 10571 ###### break; 10572 } 10573 } 10574 185 incline(s); 10575 } 10576 enough: 10577 265 if (SvCUR(stuff)) { 10578 176 PL_expect = XTERM; 10579 176 if (needargs) { 10580 142 PL_lex_state = LEX_NORMAL; 10581 142 PL_nextval[PL_nexttoke].ival = 0; 10582 142 force_next(','); 10583 } 10584 else 10585 34 PL_lex_state = LEX_FORMLINE; 10586 176 if (!IN_BYTES) { 10587 176 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff))) 10588 6 SvUTF8_on(stuff); 10589 170 else if (PL_encoding) 10590 ###### sv_recode_to_utf8(stuff, PL_encoding); 10591 } 10592 176 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff); 10593 176 force_next(THING); 10594 176 PL_nextval[PL_nexttoke].ival = OP_FORMLINE; 10595 176 force_next(LSTOP); 10596 } 10597 else { 10598 89 SvREFCNT_dec(stuff); 10599 89 if (eofmt) 10600 88 PL_lex_formbrack = 0; 10601 89 PL_bufptr = s; 10602 } 10603 265 return s; 10604 } 10605 10606 STATIC void 10607 S_set_csh(pTHX) 10608 4081 { 10609 #ifdef CSH 10610 4081 if (!PL_cshlen) 10611 1008 PL_cshlen = strlen(PL_cshname); 10612 #endif 10613 } 10614 10615 I32 10616 Perl_start_subparse(pTHX_ I32 is_format, U32 flags) 10617 405652 { 10618 405652 const I32 oldsavestack_ix = PL_savestack_ix; 10619 405652 CV* outsidecv = PL_compcv; 10620 10621 405652 if (PL_compcv) { 10622 405478 assert(SvTYPE(PL_compcv) == SVt_PVCV); 10623 } 10624 405652 SAVEI32(PL_subline); 10625 405652 save_item(PL_subname); 10626 405652 SAVESPTR(PL_compcv); 10627 10628 405652 PL_compcv = (CV*)NEWSV(1104,0); 10629 405652 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV); 10630 405652 CvFLAGS(PL_compcv) |= flags; 10631 10632 405652 PL_subline = CopLINE(PL_curcop); 10633 405652 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB); 10634 405652 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv); 10635 405652 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax; 10636 10637 405652 return oldsavestack_ix; 10638 } 10639 10640 #ifdef __SC__ 10641 #pragma segment Perl_yylex 10642 #endif 10643 int 10644 Perl_yywarn(pTHX_ const char *s) 10645 15 { 10646 15 PL_in_eval |= EVAL_WARNONLY; 10647 15 yyerror(s); 10648 15 PL_in_eval &= ~EVAL_WARNONLY; 10649 15 return 0; 10650 } 10651 10652 int 10653 Perl_yyerror(pTHX_ const char *s) 10654 193 { 10655 193 const char *where = NULL; 10656 193 const char *context = NULL; 10657 193 int contlen = -1; 10658 193 SV *msg; 10659 10660 193 if (!yychar || (yychar == ';' && !PL_rsfp)) 10661 60 where = "at EOF"; 10662 133 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr && 10663 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr && 10664 PL_oldbufptr != PL_bufptr) { 10665 /* 10666 Only for NetWare: 10667 The code below is removed for NetWare because it abends/crashes on NetWare 10668 when the script has error such as not having the closing quotes like: 10669 if ($var eq "value) 10670 Checking of white spaces is anyway done in NetWare code. 10671 */ 10672 #ifndef NETWARE 10673 126 while (isSPACE(*PL_oldoldbufptr)) 10674 10 PL_oldoldbufptr++; 10675 #endif 10676 116 context = PL_oldoldbufptr; 10677 116 contlen = PL_bufptr - PL_oldoldbufptr; 10678 } 10679 17 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr && 10680 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) { 10681 /* 10682 Only for NetWare: 10683 The code below is removed for NetWare because it abends/crashes on NetWare 10684 when the script has error such as not having the closing quotes like: 10685 if ($var eq "value) 10686 Checking of white spaces is anyway done in NetWare code. 10687 */ 10688 #ifndef NETWARE 10689 2 while (isSPACE(*PL_oldbufptr)) 10690 1 PL_oldbufptr++; 10691 #endif 10692 1 context = PL_oldbufptr; 10693 1 contlen = PL_bufptr - PL_oldbufptr; 10694 } 10695 16 else if (yychar > 255) 10696 1 where = "next token ???"; 10697 15 else if (yychar == -2) { /* YYEMPTY */ 10698 14 if (PL_lex_state == LEX_NORMAL || 10699 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL)) 10700 11 where = "at end of line"; 10701 3 else if (PL_lex_inpat) 10702 ###### where = "within pattern"; 10703 else 10704 3 where = "within string"; 10705 } 10706 else { 10707 1 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10)); 10708 1 if (yychar < 32) 10709 ###### Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar)); 10710 1 else if (isPRINT_LC(yychar)) 10711 1 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar); 10712 else 10713 ###### Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255); 10714 1 where = SvPVX_const(where_sv); 10715 } 10716 193 msg = sv_2mortal(newSVpv(s, 0)); 10717 193 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ", 10718 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 10719 193 if (context) 10720 117 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context); 10721 else 10722 76 Perl_sv_catpvf(aTHX_ msg, "%s\n", where); 10723 193 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) { 10724 ###### Perl_sv_catpvf(aTHX_ msg, 10725 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n", 10726 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start); 10727 ###### PL_multi_end = 0; 10728 } 10729 193 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX)) 10730 14 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg); 10731 else 10732 179 qerror(msg); 10733 193 if (PL_error_count >= 10) { 10734 1 if (PL_in_eval && SvCUR(ERRSV)) 10735 1 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n", 10736 ERRSV, OutCopFILE(PL_curcop)); 10737 else 10738 ###### Perl_croak(aTHX_ "%s has too many errors.\n", 10739 OutCopFILE(PL_curcop)); 10740 } 10741 192 PL_in_my = 0; 10742 192 PL_in_my_stash = Nullhv; 10743 192 return 0; 10744 } 10745 #ifdef __SC__ 10746 #pragma segment Main 10747 #endif 10748 10749 STATIC char* 10750 S_swallow_bom(pTHX_ U8 *s) 10751 1685 { 10752 1685 const STRLEN slen = SvCUR(PL_linestr); 10753 1685 switch (s[0]) { 10754 case 0xFF: 10755 4 if (s[1] == 0xFE) { 10756 /* UTF-16 little-endian? (or UTF32-LE?) */ 10757 4 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */ 10758 ###### Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE"); 10759 #ifndef PERL_NO_UTF16_FILTER 10760 4 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n"); 10761 4 s += 2; 10762 utf16le: 10763 7 if (PL_bufend > (char*)s) { 10764 7 U8 *news; 10765 7 I32 newlen; 10766 10767 7 filter_add(utf16rev_textfilter, NULL); 10768 7 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); 10769 7 utf16_to_utf8_reversed(s, news, 10770 PL_bufend - (char*)s - 1, 10771 &newlen); 10772 7 sv_setpvn(PL_linestr, (const char*)news, newlen); 10773 7 Safefree(news); 10774 7 SvUTF8_on(PL_linestr); 10775 7 s = (U8*)SvPVX(PL_linestr); 10776 7 PL_bufend = SvPVX(PL_linestr) + newlen; 10777 } 10778 #else 10779 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE"); 10780 #endif 10781 } 10782 7 break; 10783 case 0xFE: 10784 4 if (s[1] == 0xFF) { /* UTF-16 big-endian? */ 10785 #ifndef PERL_NO_UTF16_FILTER 10786 4 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n"); 10787 4 s += 2; 10788 utf16be: 10789 7 if (PL_bufend > (char *)s) { 10790 7 U8 *news; 10791 7 I32 newlen; 10792 10793 7 filter_add(utf16_textfilter, NULL); 10794 7 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); 10795 7 utf16_to_utf8(s, news, 10796 PL_bufend - (char*)s, 10797 &newlen); 10798 7 sv_setpvn(PL_linestr, (const char*)news, newlen); 10799 7 Safefree(news); 10800 7 SvUTF8_on(PL_linestr); 10801 7 s = (U8*)SvPVX(PL_linestr); 10802 7 PL_bufend = SvPVX(PL_linestr) + newlen; 10803 } 10804 #else 10805 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE"); 10806 #endif 10807 } 10808 7 break; 10809 case 0xEF: 10810 4 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) { 10811 4 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n"); 10812 4 s += 3; /* UTF-8 */ 10813 } 10814 4 break; 10815 case 0: 10816 3 if (slen > 3) { 10817 3 if (s[1] == 0) { 10818 ###### if (s[2] == 0xFE && s[3] == 0xFF) { 10819 /* UTF-32 big-endian */ 10820 ###### Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE"); 10821 } 10822 } 10823 3 else if (s[2] == 0 && s[3] != 0) { 10824 /* Leading bytes 10825 * 00 xx 00 xx 10826 * are a good indicator of UTF-16BE. */ 10827 3 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n"); 10828 ###### goto utf16be; 10829 } 10830 } 10831 default: 10832 1670 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) { 10833 /* Leading bytes 10834 * xx 00 xx 00 10835 * are a good indicator of UTF-16LE. */ 10836 3 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n"); 10837 ###### goto utf16le; 10838 } 10839 } 10840 1685 return (char*)s; 10841 } 10842 10843 /* 10844 * restore_rsfp 10845 * Restore a source filter. 10846 */ 10847 10848 static void 10849 restore_rsfp(pTHX_ void *f) 10850 106270 { 10851 106270 PerlIO *fp = (PerlIO*)f; 10852 10853 106270 if (PL_rsfp == PerlIO_stdin()) 10854 ###### PerlIO_clearerr(PL_rsfp); 10855 106270 else if (PL_rsfp && (PL_rsfp != fp)) 10856 90 PerlIO_close(PL_rsfp); 10857 106270 PL_rsfp = fp; 10858 } 10859 10860 #ifndef PERL_NO_UTF16_FILTER 10861 static I32 10862 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) 10863 7 { 10864 7 const STRLEN old = SvCUR(sv); 10865 7 const I32 count = FILTER_READ(idx+1, sv, maxlen); 10866 DEBUG_P(PerlIO_printf(Perl_debug_log, 10867 "utf16_textfilter(%p): %d %d (%d)\n", 10868 7 utf16_textfilter, idx, maxlen, (int) count)); 10869 7 if (count) { 10870 ###### U8* tmps; 10871 ###### I32 newlen; 10872 ###### New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); 10873 ###### Copy(SvPVX_const(sv), tmps, old, char); 10874 ###### utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old, 10875 SvCUR(sv) - old, &newlen); 10876 ###### sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old); 10877 } 10878 7 DEBUG_P({sv_dump(sv);}); 10879 7 return SvCUR(sv); 10880 } 10881 10882 static I32 10883 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen) 10884 14 { 10885 14 const STRLEN old = SvCUR(sv); 10886 14 const I32 count = FILTER_READ(idx+1, sv, maxlen); 10887 DEBUG_P(PerlIO_printf(Perl_debug_log, 10888 "utf16rev_textfilter(%p): %d %d (%d)\n", 10889 14 utf16rev_textfilter, idx, maxlen, (int) count)); 10890 14 if (count) { 10891 7 U8* tmps; 10892 7 I32 newlen; 10893 7 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); 10894 7 Copy(SvPVX_const(sv), tmps, old, char); 10895 7 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old, 10896 SvCUR(sv) - old, &newlen); 10897 7 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old); 10898 } 10899 14 DEBUG_P({ sv_dump(sv); }); 10900 14 return count; 10901 } 10902 #endif 10903 10904 /* 10905 Returns a pointer to the next character after the parsed 10906 vstring, as well as updating the passed in sv. 10907 10908 Function must be called like 10909 10910 sv = NEWSV(92,5); 10911 s = scan_vstring(s,sv); 10912 10913 The sv should already be large enough to store the vstring 10914 passed in, for performance reasons. 10915 10916 */ 10917 10918 char * 10919 Perl_scan_vstring(pTHX_ const char *s, SV *sv) 10920 1690 { 10921 1690 const char *pos = s; 10922 1690 const char *start = s; 10923 1690 if (*pos == 'v') pos++; /* get past 'v' */ 10924 3796 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_')) 10925 2106 pos++; 10926 1690 if ( *pos != '.') { 10927 /* this may not be a v-string if followed by => */ 10928 29 const char *next = pos; 10929 38 while (next < PL_bufend && isSPACE(*next)) 10930 9 ++next; 10931 29 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) { 10932 /* return string not v-string */ 10933 1 sv_setpvn(sv,(char *)s,pos-s); 10934 1 return (char *)pos; 10935 } 10936 } 10937 10938 1689 if (!isALPHA(*pos)) { 10939 1689 UV rev; 10940 1689 U8 tmpbuf[UTF8_MAXBYTES+1]; 10941 1689 U8 *tmpend; 10942 10943 1689 if (*s == 'v') s++; /* get past 'v' */ 10944 10945 1689 sv_setpvn(sv, "", 0); 10946 10947 6980 for (;;) { 10948 5291 rev = 0; 10949 { 10950 /* this is atoi() that tolerates underscores */ 10951 5291 const char *end = pos; 10952 5291 UV mult = 1; 10953 12594 while (--end >= s) { 10954 7303 UV orev; 10955 7303 if (*end == '_') 10956 1 continue; 10957 7302 orev = rev; 10958 7302 rev += (*end - '0') * mult; 10959 7302 mult *= 10; 10960 7302 if (orev > rev && ckWARN_d(WARN_OVERFLOW)) 10961 ###### Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), 10962 "Integer overflow in decimal number"); 10963 } 10964 } 10965 #ifdef EBCDIC 10966 if (rev > 0x7FFFFFFF) 10967 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647"); 10968 #endif 10969 /* Append native character for the rev point */ 10970 5291 tmpend = uvchr_to_utf8(tmpbuf, rev); 10971 5291 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); 10972 5291 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev))) 10973 648 SvUTF8_on(sv); 10974 5291 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1])) 10975 3602 s = ++pos; 10976 else { 10977 1689 s = pos; 10978 1689 break; 10979 } 10980 8801 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_')) 10981 5199 pos++; 10982 } 10983 1689 SvPOK_on(sv); 10984 1689 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start); 10985 1689 SvRMAGICAL_on(sv); 10986 } 10987 1689 return (char *)s; 10988 } 10989 10990 /* 10991 * Local variables: 10992 * c-indentation-style: bsd 10993 * c-basic-offset: 4 10994 * indent-tabs-mode: t 10995 * End: 10996 * 10997 * ex: set ts=8 sts=4 sw=4 noet: 10998 */