1 /* toke.c 2 * 3 * Copyright (c) 1991-2001, Larry Wall 4 * 5 * You may distribute under the terms of either the GNU General Public 6 * License or the Artistic License, as specified in the README file. 7 * 8 */ 9 10 /* 11 * "It all comes from here, the stench and the peril." --Frodo 12 */ 13 14 /* 15 * This file is the lexer for Perl. It's closely linked to the 16 * parser, perly.y. 17 * 18 * The main routine is yylex(), which returns the next token. 19 */ 20 21 #include "EXTERN.h" 22 #define PERL_IN_TOKE_C 23 #include "perl.h" 24 25 #define yychar PL_yychar 26 #define yylval PL_yylval 27 28 static char ident_too_long[] = "Identifier too long"; 29 30 static void restore_rsfp(pTHXo_ void *f); 31 #ifndef PERL_NO_UTF16_FILTER 32 static I32 utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen); 33 static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen); 34 #endif 35 36 #define XFAKEBRACK 128 37 #define XENUMMASK 127 38 39 /*#define UTF (SvUTF8(PL_linestr) && !(PL_hints & HINT_BYTE))*/ 40 #define UTF (PL_hints & HINT_UTF8) 41 42 /* In variables name $^X, these are the legal values for X. 43 * 1999-02-27 mjd-perl-patch@plover.com */ 44 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x))) 45 46 /* On MacOS, respect nonbreaking spaces */ 47 #ifdef MACOS_TRADITIONAL 48 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t') 49 #else 50 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t') 51 #endif 52 53 /* LEX_* are values for PL_lex_state, the state of the lexer. 54 * They are arranged oddly so that the guard on the switch statement 55 * can get by with a single comparison (if the compiler is smart enough). 56 */ 57 58 /* #define LEX_NOTPARSING 11 is done in perl.h. */ 59 60 #define LEX_NORMAL 10 61 #define LEX_INTERPNORMAL 9 62 #define LEX_INTERPCASEMOD 8 63 #define LEX_INTERPPUSH 7 64 #define LEX_INTERPSTART 6 65 #define LEX_INTERPEND 5 66 #define LEX_INTERPENDMAYBE 4 67 #define LEX_INTERPCONCAT 3 68 #define LEX_INTERPCONST 2 69 #define LEX_FORMLINE 1 70 #define LEX_KNOWNEXT 0 71 72 #ifdef ff_next 73 #undef ff_next 74 #endif 75 76 #ifdef USE_PURE_BISON 77 # ifndef YYMAXLEVEL 78 # define YYMAXLEVEL 100 79 # endif 80 YYSTYPE* yylval_pointer[YYMAXLEVEL]; 81 int* yychar_pointer[YYMAXLEVEL]; 82 int yyactlevel = -1; 83 # undef yylval 84 # undef yychar 85 # define yylval (*yylval_pointer[yyactlevel]) 86 # define yychar (*yychar_pointer[yyactlevel]) 87 # define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel] 88 # undef yylex 89 # define yylex() Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]) 90 #endif 91 92 #include "keywords.h" 93 94 /* CLINE is a macro that ensures PL_copline has a sane value */ 95 96 #ifdef CLINE 97 #undef CLINE 98 #endif 99 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline)) 100 101 /* 102 * Convenience functions to return different tokens and prime the 103 * lexer for the next token. They all take an argument. 104 * 105 * TOKEN : generic token (used for '(', DOLSHARP, etc) 106 * OPERATOR : generic operator 107 * AOPERATOR : assignment operator 108 * PREBLOCK : beginning the block after an if, while, foreach, ... 109 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref) 110 * PREREF : *EXPR where EXPR is not a simple identifier 111 * TERM : expression term 112 * LOOPX : loop exiting command (goto, last, dump, etc) 113 * FTST : file test operator 114 * FUN0 : zero-argument function 115 * FUN1 : not used, except for not, which isn't a UNIOP 116 * BOop : bitwise or or xor 117 * BAop : bitwise and 118 * SHop : shift operator 119 * PWop : power operator 120 * PMop : pattern-matching operator 121 * Aop : addition-level operator 122 * Mop : multiplication-level operator 123 * Eop : equality-testing operator 124 * Rop : relational operator <= != gt 125 * 126 * Also see LOP and lop() below. 127 */ 128 129 #define TOKEN(retval) return (PL_bufptr = s,(int)retval) 130 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval) 131 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval)) 132 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval) 133 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval) 134 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval) 135 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval) 136 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX) 137 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP) 138 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0) 139 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1) 140 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP)) 141 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP)) 142 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP)) 143 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP)) 144 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP) 145 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP)) 146 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP)) 147 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP) 148 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP) 149 150 /* This bit of chicanery makes a unary function followed by 151 * a parenthesis into a function with one argument, highest precedence. 152 */ 153 #define UNI(f) return(yylval.ival = f, \ 154 PL_expect = XTERM, \ 155 PL_bufptr = s, \ 156 PL_last_uni = PL_oldbufptr, \ 157 PL_last_lop_op = f, \ 158 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) ) 159 160 #define UNIBRACK(f) return(yylval.ival = f, \ 161 PL_bufptr = s, \ 162 PL_last_uni = PL_oldbufptr, \ 163 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) ) 164 165 /* grandfather return to old style */ 166 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP) 167 168 /* 169 * S_ao 170 * 171 * This subroutine detects &&= and ||= and turns an ANDAND or OROR 172 * into an OP_ANDASSIGN or OP_ORASSIGN 173 */ 174 175 STATIC int 176 S_ao(pTHX_ int toketype) 177 { 178 if (*PL_bufptr == '=') { 179 PL_bufptr++; 180 if (toketype == ANDAND) 181 yylval.ival = OP_ANDASSIGN; 182 else if (toketype == OROR) 183 yylval.ival = OP_ORASSIGN; 184 toketype = ASSIGNOP; 185 } 186 return toketype; 187 } 188 189 /* 190 * S_no_op 191 * When Perl expects an operator and finds something else, no_op 192 * prints the warning. It always prints "<something> found where 193 * operator expected. It prints "Missing semicolon on previous line?" 194 * if the surprise occurs at the start of the line. "do you need to 195 * predeclare ..." is printed out for code like "sub bar; foo bar $x" 196 * where the compiler doesn't know if foo is a method call or a function. 197 * It prints "Missing operator before end of line" if there's nothing 198 * after the missing operator, or "... before <...>" if there is something 199 * after the missing operator. 200 */ 201 202 STATIC void 203 S_no_op(pTHX_ char *what, char *s) 204 { 205 char *oldbp = PL_bufptr; 206 bool is_first = (PL_oldbufptr == PL_linestart); 207 208 if (!s) 209 s = oldbp; 210 else 211 PL_bufptr = s; 212 yywarn(Perl_form(aTHX_ "%s found where operator expected", what)); 213 if (is_first) 214 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n"); 215 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) { 216 char *t; 217 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ; 218 if (t < PL_bufptr && isSPACE(*t)) 219 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n", 220 t - PL_oldoldbufptr, PL_oldoldbufptr); 221 } 222 else { 223 assert(s >= oldbp); 224 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp); 225 } 226 PL_bufptr = oldbp; 227 } 228 229 /* 230 * S_missingterm 231 * Complain about missing quote/regexp/heredoc terminator. 232 * If it's called with (char *)NULL then it cauterizes the line buffer. 233 * If we're in a delimited string and the delimiter is a control 234 * character, it's reformatted into a two-char sequence like ^C. 235 * This is fatal. 236 */ 237 238 STATIC void 239 S_missingterm(pTHX_ char *s) 240 { 241 char tmpbuf[3]; 242 char q; 243 if (s) { 244 char *nl = strrchr(s,'\n'); 245 if (nl) 246 *nl = '\0'; 247 } 248 else if ( 249 #ifdef EBCDIC 250 iscntrl(PL_multi_close) 251 #else 252 PL_multi_close < 32 || PL_multi_close == 127 253 #endif 254 ) { 255 *tmpbuf = '^'; 256 tmpbuf[1] = toCTRL(PL_multi_close); 257 s = "\\n"; 258 tmpbuf[2] = '\0'; 259 s = tmpbuf; 260 } 261 else { 262 *tmpbuf = PL_multi_close; 263 tmpbuf[1] = '\0'; 264 s = tmpbuf; 265 } 266 q = strchr(s,'"') ? '\'' : '"'; 267 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q); 268 } 269 270 /* 271 * Perl_deprecate 272 */ 273 274 void 275 Perl_deprecate(pTHX_ char *s) 276 { 277 if (ckWARN(WARN_DEPRECATED)) 278 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s); 279 } 280 281 /* 282 * depcom 283 * Deprecate a comma-less variable list. 284 */ 285 286 STATIC void 287 S_depcom(pTHX) 288 { 289 deprecate("comma-less variable list"); 290 } 291 292 /* 293 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and 294 * utf16-to-utf8-reversed. 295 */ 296 297 #ifdef PERL_CR_FILTER 298 static void 299 strip_return(SV *sv) 300 { 301 register char *s = SvPVX(sv); 302 register char *e = s + SvCUR(sv); 303 /* outer loop optimized to do nothing if there are no CR-LFs */ 304 while (s < e) { 305 if (*s++ == '\r' && *s == '\n') { 306 /* hit a CR-LF, need to copy the rest */ 307 register char *d = s - 1; 308 *d++ = *s++; 309 while (s < e) { 310 if (*s == '\r' && s[1] == '\n') 311 s++; 312 *d++ = *s++; 313 } 314 SvCUR(sv) -= s - d; 315 return; 316 } 317 } 318 } 319 320 STATIC I32 321 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) 322 { 323 I32 count = FILTER_READ(idx+1, sv, maxlen); 324 if (count > 0 && !maxlen) 325 strip_return(sv); 326 return count; 327 } 328 #endif 329 330 /* 331 * Perl_lex_start 332 * Initialize variables. Uses the Perl save_stack to save its state (for 333 * recursive calls to the parser). 334 */ 335 336 void 337 Perl_lex_start(pTHX_ SV *line) 338 { 339 char *s; 340 STRLEN len; 341 342 SAVEI32(PL_lex_dojoin); 343 SAVEI32(PL_lex_brackets); 344 SAVEI32(PL_lex_casemods); 345 SAVEI32(PL_lex_starts); 346 SAVEI32(PL_lex_state); 347 SAVEVPTR(PL_lex_inpat); 348 SAVEI32(PL_lex_inwhat); 349 if (PL_lex_state == LEX_KNOWNEXT) { 350 I32 toke = PL_nexttoke; 351 while (--toke >= 0) { 352 SAVEI32(PL_nexttype[toke]); 353 SAVEVPTR(PL_nextval[toke]); 354 } 355 SAVEI32(PL_nexttoke); 356 } 357 SAVECOPLINE(PL_curcop); 358 SAVEPPTR(PL_bufptr); 359 SAVEPPTR(PL_bufend); 360 SAVEPPTR(PL_oldbufptr); 361 SAVEPPTR(PL_oldoldbufptr); 362 SAVEPPTR(PL_last_lop); 363 SAVEPPTR(PL_last_uni); 364 SAVEPPTR(PL_linestart); 365 SAVESPTR(PL_linestr); 366 SAVEPPTR(PL_lex_brackstack); 367 SAVEPPTR(PL_lex_casestack); 368 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp); 369 SAVESPTR(PL_lex_stuff); 370 SAVEI32(PL_lex_defer); 371 SAVEI32(PL_sublex_info.sub_inwhat); 372 SAVESPTR(PL_lex_repl); 373 SAVEINT(PL_expect); 374 SAVEINT(PL_lex_expect); 375 376 PL_lex_state = LEX_NORMAL; 377 PL_lex_defer = 0; 378 PL_expect = XSTATE; 379 PL_lex_brackets = 0; 380 New(899, PL_lex_brackstack, 120, char); 381 New(899, PL_lex_casestack, 12, char); 382 SAVEFREEPV(PL_lex_brackstack); 383 SAVEFREEPV(PL_lex_casestack); 384 PL_lex_casemods = 0; 385 *PL_lex_casestack = '\0'; 386 PL_lex_dojoin = 0; 387 PL_lex_starts = 0; 388 PL_lex_stuff = Nullsv; 389 PL_lex_repl = Nullsv; 390 PL_lex_inpat = 0; 391 PL_nexttoke = 0; 392 PL_lex_inwhat = 0; 393 PL_sublex_info.sub_inwhat = 0; 394 PL_linestr = line; 395 if (SvREADONLY(PL_linestr)) 396 PL_linestr = sv_2mortal(newSVsv(PL_linestr)); 397 s = SvPV(PL_linestr, len); 398 if (len && s[len-1] != ';') { 399 if (!(SvFLAGS(PL_linestr) & SVs_TEMP)) 400 PL_linestr = sv_2mortal(newSVsv(PL_linestr)); 401 sv_catpvn(PL_linestr, "\n;", 2); 402 } 403 SvTEMP_off(PL_linestr); 404 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); 405 PL_bufend = PL_bufptr + SvCUR(PL_linestr); 406 PL_last_lop = PL_last_uni = Nullch; 407 SvREFCNT_dec(PL_rs); 408 PL_rs = newSVpvn("\n", 1); 409 PL_rsfp = 0; 410 } 411 412 /* 413 * Perl_lex_end 414 * Finalizer for lexing operations. Must be called when the parser is 415 * done with the lexer. 416 */ 417 418 void 419 Perl_lex_end(pTHX) 420 { 421 PL_doextract = FALSE; 422 } 423 424 /* 425 * S_incline 426 * This subroutine has nothing to do with tilting, whether at windmills 427 * or pinball tables. Its name is short for "increment line". It 428 * increments the current line number in CopLINE(PL_curcop) and checks 429 * to see whether the line starts with a comment of the form 430 * # line 500 "foo.pm" 431 * If so, it sets the current line number and file to the values in the comment. 432 */ 433 434 STATIC void 435 S_incline(pTHX_ char *s) 436 { 437 char *t; 438 char *n; 439 char *e; 440 char ch; 441 442 CopLINE_inc(PL_curcop); 443 if (*s++ != '#') 444 return; 445 while (SPACE_OR_TAB(*s)) s++; 446 if (strnEQ(s, "line", 4)) 447 s += 4; 448 else 449 return; 450 if (SPACE_OR_TAB(*s)) 451 s++; 452 else 453 return; 454 while (SPACE_OR_TAB(*s)) s++; 455 if (!isDIGIT(*s)) 456 return; 457 n = s; 458 while (isDIGIT(*s)) 459 s++; 460 while (SPACE_OR_TAB(*s)) 461 s++; 462 if (*s == '"' && (t = strchr(s+1, '"'))) { 463 s++; 464 e = t + 1; 465 } 466 else { 467 for (t = s; !isSPACE(*t); t++) ; 468 e = t; 469 } 470 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f') 471 e++; 472 if (*e != '\n' && *e != '\0') 473 return; /* false alarm */ 474 475 ch = *t; 476 *t = '\0'; 477 if (t - s > 0) { 478 #ifdef USE_ITHREADS 479 Safefree(CopFILE(PL_curcop)); 480 #else 481 SvREFCNT_dec(CopFILEGV(PL_curcop)); 482 #endif 483 CopFILE_set(PL_curcop, s); 484 } 485 *t = ch; 486 CopLINE_set(PL_curcop, atoi(n)-1); 487 } 488 489 /* 490 * S_skipspace 491 * Called to gobble the appropriate amount and type of whitespace. 492 * Skips comments as well. 493 */ 494 495 STATIC char * 496 S_skipspace(pTHX_ register char *s) 497 { 498 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { 499 while (s < PL_bufend && SPACE_OR_TAB(*s)) 500 s++; 501 return s; 502 } 503 for (;;) { 504 STRLEN prevlen; 505 SSize_t oldprevlen, oldoldprevlen; 506 SSize_t oldloplen, oldunilen; 507 while (s < PL_bufend && isSPACE(*s)) { 508 if (*s++ == '\n' && PL_in_eval && !PL_rsfp) 509 incline(s); 510 } 511 512 /* comment */ 513 if (s < PL_bufend && *s == '#') { 514 while (s < PL_bufend && *s != '\n') 515 s++; 516 if (s < PL_bufend) { 517 s++; 518 if (PL_in_eval && !PL_rsfp) { 519 incline(s); 520 continue; 521 } 522 } 523 } 524 525 /* only continue to recharge the buffer if we're at the end 526 * of the buffer, we're not reading from a source filter, and 527 * we're in normal lexing mode 528 */ 529 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat || 530 PL_lex_state == LEX_FORMLINE) 531 return s; 532 533 /* try to recharge the buffer */ 534 if ((s = filter_gets(PL_linestr, PL_rsfp, 535 (prevlen = SvCUR(PL_linestr)))) == Nullch) 536 { 537 /* end of file. Add on the -p or -n magic */ 538 if (PL_minus_n || PL_minus_p) { 539 sv_setpv(PL_linestr,PL_minus_p ? 540 ";}continue{print or die qq(-p destination: $!\\n)" : 541 ""); 542 sv_catpv(PL_linestr,";}"); 543 PL_minus_n = PL_minus_p = 0; 544 } 545 else 546 sv_setpv(PL_linestr,";"); 547 548 /* reset variables for next time we lex */ 549 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart 550 = SvPVX(PL_linestr); 551 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 552 PL_last_lop = PL_last_uni = Nullch; 553 554 /* Close the filehandle. Could be from -P preprocessor, 555 * STDIN, or a regular file. If we were reading code from 556 * STDIN (because the commandline held no -e or filename) 557 * then we don't close it, we reset it so the code can 558 * read from STDIN too. 559 */ 560 561 if (PL_preprocess && !PL_in_eval) 562 (void)PerlProc_pclose(PL_rsfp); 563 else if ((PerlIO*)PL_rsfp == PerlIO_stdin()) 564 PerlIO_clearerr(PL_rsfp); 565 else 566 (void)PerlIO_close(PL_rsfp); 567 PL_rsfp = Nullfp; 568 return s; 569 } 570 571 /* not at end of file, so we only read another line */ 572 /* make corresponding updates to old pointers, for yyerror() */ 573 oldprevlen = PL_oldbufptr - PL_bufend; 574 oldoldprevlen = PL_oldoldbufptr - PL_bufend; 575 if (PL_last_uni) 576 oldunilen = PL_last_uni - PL_bufend; 577 if (PL_last_lop) 578 oldloplen = PL_last_lop - PL_bufend; 579 PL_linestart = PL_bufptr = s + prevlen; 580 PL_bufend = s + SvCUR(PL_linestr); 581 s = PL_bufptr; 582 PL_oldbufptr = s + oldprevlen; 583 PL_oldoldbufptr = s + oldoldprevlen; 584 if (PL_last_uni) 585 PL_last_uni = s + oldunilen; 586 if (PL_last_lop) 587 PL_last_lop = s + oldloplen; 588 incline(s); 589 590 /* debugger active and we're not compiling the debugger code, 591 * so store the line into the debugger's array of lines 592 */ 593 if (PERLDB_LINE && PL_curstash != PL_debstash) { 594 SV *sv = NEWSV(85,0); 595 596 sv_upgrade(sv, SVt_PVMG); 597 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr); 598 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); 599 } 600 } 601 } 602 603 /* 604 * S_check_uni 605 * Check the unary operators to ensure there's no ambiguity in how they're 606 * used. An ambiguous piece of code would be: 607 * rand + 5 608 * This doesn't mean rand() + 5. Because rand() is a unary operator, 609 * the +5 is its argument. 610 */ 611 612 STATIC void 613 S_check_uni(pTHX) 614 { 615 char *s; 616 char *t; 617 618 if (PL_oldoldbufptr != PL_last_uni) 619 return; 620 while (isSPACE(*PL_last_uni)) 621 PL_last_uni++; 622 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ; 623 if ((t = strchr(s, '(')) && t < PL_bufptr) 624 return; 625 if (ckWARN_d(WARN_AMBIGUOUS)){ 626 char ch = *s; 627 *s = '\0'; 628 Perl_warner(aTHX_ WARN_AMBIGUOUS, 629 "Warning: Use of \"%s\" without parens is ambiguous", 630 PL_last_uni); 631 *s = ch; 632 } 633 } 634 635 /* workaround to replace the UNI() macro with a function. Only the 636 * hints/uts.sh file mentions this. Other comments elsewhere in the 637 * source indicate Microport Unix might need it too. 638 */ 639 640 #ifdef CRIPPLED_CC 641 642 #undef UNI 643 #define UNI(f) return uni(f,s) 644 645 STATIC int 646 S_uni(pTHX_ I32 f, char *s) 647 { 648 yylval.ival = f; 649 PL_expect = XTERM; 650 PL_bufptr = s; 651 PL_last_uni = PL_oldbufptr; 652 PL_last_lop_op = f; 653 if (*s == '(') 654 return FUNC1; 655 s = skipspace(s); 656 if (*s == '(') 657 return FUNC1; 658 else 659 return UNIOP; 660 } 661 662 #endif /* CRIPPLED_CC */ 663 664 /* 665 * LOP : macro to build a list operator. Its behaviour has been replaced 666 * with a subroutine, S_lop() for which LOP is just another name. 667 */ 668 669 #define LOP(f,x) return lop(f,x,s) 670 671 /* 672 * S_lop 673 * Build a list operator (or something that might be one). The rules: 674 * - if we have a next token, then it's a list operator [why?] 675 * - if the next thing is an opening paren, then it's a function 676 * - else it's a list operator 677 */ 678 679 STATIC I32 680 S_lop(pTHX_ I32 f, int x, char *s) 681 { 682 yylval.ival = f; 683 CLINE; 684 PL_expect = x; 685 PL_bufptr = s; 686 PL_last_lop = PL_oldbufptr; 687 PL_last_lop_op = f; 688 if (PL_nexttoke) 689 return LSTOP; 690 if (*s == '(') 691 return FUNC; 692 s = skipspace(s); 693 if (*s == '(') 694 return FUNC; 695 else 696 return LSTOP; 697 } 698 699 /* 700 * S_force_next 701 * When the lexer realizes it knows the next token (for instance, 702 * it is reordering tokens for the parser) then it can call S_force_next 703 * to know what token to return the next time the lexer is called. Caller 704 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer 705 * handles the token correctly. 706 */ 707 708 STATIC void 709 S_force_next(pTHX_ I32 type) 710 { 711 PL_nexttype[PL_nexttoke] = type; 712 PL_nexttoke++; 713 if (PL_lex_state != LEX_KNOWNEXT) { 714 PL_lex_defer = PL_lex_state; 715 PL_lex_expect = PL_expect; 716 PL_lex_state = LEX_KNOWNEXT; 717 } 718 } 719 720 /* 721 * S_force_word 722 * When the lexer knows the next thing is a word (for instance, it has 723 * just seen -> and it knows that the next char is a word char, then 724 * it calls S_force_word to stick the next word into the PL_next lookahead. 725 * 726 * Arguments: 727 * char *start : buffer position (must be within PL_linestr) 728 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD) 729 * int check_keyword : if true, Perl checks to make sure the word isn't 730 * a keyword (do this if the word is a label, e.g. goto FOO) 731 * int allow_pack : if true, : characters will also be allowed (require, 732 * use, etc. do this) 733 * int allow_initial_tick : used by the "sub" lexer only. 734 */ 735 736 STATIC char * 737 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick) 738 { 739 register char *s; 740 STRLEN len; 741 742 start = skipspace(start); 743 s = start; 744 if (isIDFIRST_lazy_if(s,UTF) || 745 (allow_pack && *s == ':') || 746 (allow_initial_tick && *s == '\'') ) 747 { 748 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len); 749 if (check_keyword && keyword(PL_tokenbuf, len)) 750 return start; 751 if (token == METHOD) { 752 s = skipspace(s); 753 if (*s == '(') 754 PL_expect = XTERM; 755 else { 756 PL_expect = XOPERATOR; 757 } 758 } 759 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0)); 760 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE; 761 force_next(token); 762 } 763 return s; 764 } 765 766 /* 767 * S_force_ident 768 * Called when the lexer wants $foo *foo &foo etc, but the program 769 * text only contains the "foo" portion. The first argument is a pointer 770 * to the "foo", and the second argument is the type symbol to prefix. 771 * Forces the next token to be a "WORD". 772 * Creates the symbol if it didn't already exist (via gv_fetchpv()). 773 */ 774 775 STATIC void 776 S_force_ident(pTHX_ register char *s, int kind) 777 { 778 if (s && *s) { 779 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0)); 780 PL_nextval[PL_nexttoke].opval = o; 781 force_next(WORD); 782 if (kind) { 783 o->op_private = OPpCONST_ENTERED; 784 /* XXX see note in pp_entereval() for why we forgo typo 785 warnings if the symbol must be introduced in an eval. 786 GSAR 96-10-12 */ 787 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE, 788 kind == '$' ? SVt_PV : 789 kind == '@' ? SVt_PVAV : 790 kind == '%' ? SVt_PVHV : 791 SVt_PVGV 792 ); 793 } 794 } 795 } 796 797 NV 798 Perl_str_to_version(pTHX_ SV *sv) 799 { 800 NV retval = 0.0; 801 NV nshift = 1.0; 802 STRLEN len; 803 char *start = SvPVx(sv,len); 804 bool utf = SvUTF8(sv) ? TRUE : FALSE; 805 char *end = start + len; 806 while (start < end) { 807 STRLEN skip; 808 UV n; 809 if (utf) 810 n = utf8_to_uv((U8*)start, len, &skip, 0); 811 else { 812 n = *(U8*)start; 813 skip = 1; 814 } 815 retval += ((NV)n)/nshift; 816 start += skip; 817 nshift *= 1000; 818 } 819 return retval; 820 } 821 822 /* 823 * S_force_version 824 * Forces the next token to be a version number. 825 */ 826 827 STATIC char * 828 S_force_version(pTHX_ char *s) 829 { 830 OP *version = Nullop; 831 char *d; 832 833 s = skipspace(s); 834 835 d = s; 836 if (*d == 'v') 837 d++; 838 if (isDIGIT(*d)) { 839 for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++); 840 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) { 841 SV *ver; 842 s = scan_num(s, &yylval); 843 version = yylval.opval; 844 ver = cSVOPx(version)->op_sv; 845 if (SvPOK(ver) && !SvNIOK(ver)) { 846 (void)SvUPGRADE(ver, SVt_PVNV); 847 SvNVX(ver) = str_to_version(ver); 848 SvNOK_on(ver); /* hint that it is a version */ 849 } 850 } 851 } 852 853 /* NOTE: The parser sees the package name and the VERSION swapped */ 854 PL_nextval[PL_nexttoke].opval = version; 855 force_next(WORD); 856 857 return (s); 858 } 859 860 /* 861 * S_tokeq 862 * Tokenize a quoted string passed in as an SV. It finds the next 863 * chunk, up to end of string or a backslash. It may make a new 864 * SV containing that chunk (if HINT_NEW_STRING is on). It also 865 * turns \\ into \. 866 */ 867 868 STATIC SV * 869 S_tokeq(pTHX_ SV *sv) 870 { 871 register char *s; 872 register char *send; 873 register char *d; 874 STRLEN len = 0; 875 SV *pv = sv; 876 877 if (!SvLEN(sv)) 878 goto finish; 879 880 s = SvPV_force(sv, len); 881 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) 882 goto finish; 883 send = s + len; 884 while (s < send && *s != '\\') 885 s++; 886 if (s == send) 887 goto finish; 888 d = s; 889 if ( PL_hints & HINT_NEW_STRING ) 890 pv = sv_2mortal(newSVpvn(SvPVX(pv), len)); 891 while (s < send) { 892 if (*s == '\\') { 893 if (s + 1 < send && (s[1] == '\\')) 894 s++; /* all that, just for this */ 895 } 896 *d++ = *s++; 897 } 898 *d = '\0'; 899 SvCUR_set(sv, d - SvPVX(sv)); 900 finish: 901 if ( PL_hints & HINT_NEW_STRING ) 902 return new_constant(NULL, 0, "q", sv, pv, "q"); 903 return sv; 904 } 905 906 /* 907 * Now come three functions related to double-quote context, 908 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when 909 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They 910 * interact with PL_lex_state, and create fake ( ... ) argument lists 911 * to handle functions and concatenation. 912 * They assume that whoever calls them will be setting up a fake 913 * join call, because each subthing puts a ',' after it. This lets 914 * "lower \luPpEr" 915 * become 916 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,) 917 * 918 * (I'm not sure whether the spurious commas at the end of lcfirst's 919 * arguments and join's arguments are created or not). 920 */ 921 922 /* 923 * S_sublex_start 924 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST). 925 * 926 * Pattern matching will set PL_lex_op to the pattern-matching op to 927 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise). 928 * 929 * OP_CONST and OP_READLINE are easy--just make the new op and return. 930 * 931 * Everything else becomes a FUNC. 932 * 933 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we 934 * had an OP_CONST or OP_READLINE). This just sets us up for a 935 * call to S_sublex_push(). 936 */ 937 938 STATIC I32 939 S_sublex_start(pTHX) 940 { 941 register I32 op_type = yylval.ival; 942 943 if (op_type == OP_NULL) { 944 yylval.opval = PL_lex_op; 945 PL_lex_op = Nullop; 946 return THING; 947 } 948 if (op_type == OP_CONST || op_type == OP_READLINE) { 949 SV *sv = tokeq(PL_lex_stuff); 950 951 if (SvTYPE(sv) == SVt_PVIV) { 952 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */ 953 STRLEN len; 954 char *p; 955 SV *nsv; 956 957 p = SvPV(sv, len); 958 nsv = newSVpvn(p, len); 959 if (SvUTF8(sv)) 960 SvUTF8_on(nsv); 961 SvREFCNT_dec(sv); 962 sv = nsv; 963 } 964 yylval.opval = (OP*)newSVOP(op_type, 0, sv); 965 PL_lex_stuff = Nullsv; 966 return THING; 967 } 968 969 PL_sublex_info.super_state = PL_lex_state; 970 PL_sublex_info.sub_inwhat = op_type; 971 PL_sublex_info.sub_op = PL_lex_op; 972 PL_lex_state = LEX_INTERPPUSH; 973 974 PL_expect = XTERM; 975 if (PL_lex_op) { 976 yylval.opval = PL_lex_op; 977 PL_lex_op = Nullop; 978 return PMFUNC; 979 } 980 else 981 return FUNC; 982 } 983 984 /* 985 * S_sublex_push 986 * Create a new scope to save the lexing state. The scope will be 987 * ended in S_sublex_done. Returns a '(', starting the function arguments 988 * to the uc, lc, etc. found before. 989 * Sets PL_lex_state to LEX_INTERPCONCAT. 990 */ 991 992 STATIC I32 993 S_sublex_push(pTHX) 994 { 995 ENTER; 996 997 PL_lex_state = PL_sublex_info.super_state; 998 SAVEI32(PL_lex_dojoin); 999 SAVEI32(PL_lex_brackets); 1000 SAVEI32(PL_lex_casemods); 1001 SAVEI32(PL_lex_starts); 1002 SAVEI32(PL_lex_state); 1003 SAVEVPTR(PL_lex_inpat); 1004 SAVEI32(PL_lex_inwhat); 1005 SAVECOPLINE(PL_curcop); 1006 SAVEPPTR(PL_bufptr); 1007 SAVEPPTR(PL_oldbufptr); 1008 SAVEPPTR(PL_oldoldbufptr); 1009 SAVEPPTR(PL_last_lop); 1010 SAVEPPTR(PL_last_uni); 1011 SAVEPPTR(PL_linestart); 1012 SAVESPTR(PL_linestr); 1013 SAVEPPTR(PL_lex_brackstack); 1014 SAVEPPTR(PL_lex_casestack); 1015 1016 PL_linestr = PL_lex_stuff; 1017 PL_lex_stuff = Nullsv; 1018 1019 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart 1020 = SvPVX(PL_linestr); 1021 PL_bufend += SvCUR(PL_linestr); 1022 PL_last_lop = PL_last_uni = Nullch; 1023 SAVEFREESV(PL_linestr); 1024 1025 PL_lex_dojoin = FALSE; 1026 PL_lex_brackets = 0; 1027 New(899, PL_lex_brackstack, 120, char); 1028 New(899, PL_lex_casestack, 12, char); 1029 SAVEFREEPV(PL_lex_brackstack); 1030 SAVEFREEPV(PL_lex_casestack); 1031 PL_lex_casemods = 0; 1032 *PL_lex_casestack = '\0'; 1033 PL_lex_starts = 0; 1034 PL_lex_state = LEX_INTERPCONCAT; 1035 CopLINE_set(PL_curcop, PL_multi_start); 1036 1037 PL_lex_inwhat = PL_sublex_info.sub_inwhat; 1038 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST) 1039 PL_lex_inpat = PL_sublex_info.sub_op; 1040 else 1041 PL_lex_inpat = Nullop; 1042 1043 return '('; 1044 } 1045 1046 /* 1047 * S_sublex_done 1048 * Restores lexer state after a S_sublex_push. 1049 */ 1050 1051 STATIC I32 1052 S_sublex_done(pTHX) 1053 { 1054 if (!PL_lex_starts++) { 1055 SV *sv = newSVpvn("",0); 1056 if (SvUTF8(PL_linestr)) 1057 SvUTF8_on(sv); 1058 PL_expect = XOPERATOR; 1059 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); 1060 return THING; 1061 } 1062 1063 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */ 1064 PL_lex_state = LEX_INTERPCASEMOD; 1065 return yylex(); 1066 } 1067 1068 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */ 1069 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) { 1070 PL_linestr = PL_lex_repl; 1071 PL_lex_inpat = 0; 1072 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); 1073 PL_bufend += SvCUR(PL_linestr); 1074 PL_last_lop = PL_last_uni = Nullch; 1075 SAVEFREESV(PL_linestr); 1076 PL_lex_dojoin = FALSE; 1077 PL_lex_brackets = 0; 1078 PL_lex_casemods = 0; 1079 *PL_lex_casestack = '\0'; 1080 PL_lex_starts = 0; 1081 if (SvEVALED(PL_lex_repl)) { 1082 PL_lex_state = LEX_INTERPNORMAL; 1083 PL_lex_starts++; 1084 /* we don't clear PL_lex_repl here, so that we can check later 1085 whether this is an evalled subst; that means we rely on the 1086 logic to ensure sublex_done() is called again only via the 1087 branch (in yylex()) that clears PL_lex_repl, else we'll loop */ 1088 } 1089 else { 1090 PL_lex_state = LEX_INTERPCONCAT; 1091 PL_lex_repl = Nullsv; 1092 } 1093 return ','; 1094 } 1095 else { 1096 LEAVE; 1097 PL_bufend = SvPVX(PL_linestr); 1098 PL_bufend += SvCUR(PL_linestr); 1099 PL_expect = XOPERATOR; 1100 PL_sublex_info.sub_inwhat = 0; 1101 return ')'; 1102 } 1103 } 1104 1105 /* 1106 scan_const 1107 1108 Extracts a pattern, double-quoted string, or transliteration. This 1109 is terrifying code. 1110 1111 It looks at lex_inwhat and PL_lex_inpat to find out whether it's 1112 processing a pattern (PL_lex_inpat is true), a transliteration 1113 (lex_inwhat & OP_TRANS is true), or a double-quoted string. 1114 1115 Returns a pointer to the character scanned up to. Iff this is 1116 advanced from the start pointer supplied (ie if anything was 1117 successfully parsed), will leave an OP for the substring scanned 1118 in yylval. Caller must intuit reason for not parsing further 1119 by looking at the next characters herself. 1120 1121 In patterns: 1122 backslashes: 1123 double-quoted style: \r and \n 1124 regexp special ones: \D \s 1125 constants: \x3 1126 backrefs: \1 (deprecated in substitution replacements) 1127 case and quoting: \U \Q \E 1128 stops on @ and $, but not for $ as tail anchor 1129 1130 In transliterations: 1131 characters are VERY literal, except for - not at the start or end 1132 of the string, which indicates a range. scan_const expands the 1133 range to the full set of intermediate characters. 1134 1135 In double-quoted strings: 1136 backslashes: 1137 double-quoted style: \r and \n 1138 constants: \x3 1139 backrefs: \1 (deprecated) 1140 case and quoting: \U \Q \E 1141 stops on @ and $ 1142 1143 scan_const does *not* construct ops to handle interpolated strings. 1144 It stops processing as soon as it finds an embedded $ or @ variable 1145 and leaves it to the caller to work out what's going on. 1146 1147 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo. 1148 1149 $ in pattern could be $foo or could be tail anchor. Assumption: 1150 it's a tail anchor if $ is the last thing in the string, or if it's 1151 followed by one of ")| \n\t" 1152 1153 \1 (backreferences) are turned into $1 1154 1155 The structure of the code is 1156 while (there's a character to process) { 1157 handle transliteration ranges 1158 skip regexp comments 1159 skip # initiated comments in //x patterns 1160 check for embedded @foo 1161 check for embedded scalars 1162 if (backslash) { 1163 leave intact backslashes from leave (below) 1164 deprecate \1 in strings and sub replacements 1165 handle string-changing backslashes \l \U \Q \E, etc. 1166 switch (what was escaped) { 1167 handle - in a transliteration (becomes a literal -) 1168 handle \132 octal characters 1169 handle 0x15 hex characters 1170 handle \cV (control V) 1171 handle printf backslashes (\f, \r, \n, etc) 1172 } (end switch) 1173 } (end if backslash) 1174 } (end while character to read) 1175 1176 */ 1177 1178 STATIC char * 1179 S_scan_const(pTHX_ char *start) 1180 { 1181 register char *send = PL_bufend; /* end of the constant */ 1182 SV *sv = NEWSV(93, send - start); /* sv for the constant */ 1183 register char *s = start; /* start of the constant */ 1184 register char *d = SvPVX(sv); /* destination for copies */ 1185 bool dorange = FALSE; /* are we in a translit range? */ 1186 bool has_utf8 = FALSE; /* embedded \x{} */ 1187 UV uv; 1188 1189 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) 1190 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) 1191 : UTF; 1192 I32 this_utf8 = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) 1193 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? 1194 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF)) 1195 : UTF; 1196 const char *leaveit = /* set of acceptably-backslashed characters */ 1197 PL_lex_inpat 1198 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#" 1199 : ""; 1200 1201 while (s < send || dorange) { 1202 /* get transliterations out of the way (they're most literal) */ 1203 if (PL_lex_inwhat == OP_TRANS) { 1204 /* expand a range A-Z to the full set of characters. AIE! */ 1205 if (dorange) { 1206 I32 i; /* current expanded character */ 1207 I32 min; /* first character in range */ 1208 I32 max; /* last character in range */ 1209 1210 i = d - SvPVX(sv); /* remember current offset */ 1211 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */ 1212 d = SvPVX(sv) + i; /* refresh d after realloc */ 1213 d -= 2; /* eat the first char and the - */ 1214 1215 min = (U8)*d; /* first char in range */ 1216 max = (U8)d[1]; /* last char in range */ 1217 1218 #ifndef ASCIIish 1219 if ((isLOWER(min) && isLOWER(max)) || 1220 (isUPPER(min) && isUPPER(max))) { 1221 if (isLOWER(min)) { 1222 for (i = min; i <= max; i++) 1223 if (isLOWER(i)) 1224 *d++ = i; 1225 } else { 1226 for (i = min; i <= max; i++) 1227 if (isUPPER(i)) 1228 *d++ = i; 1229 } 1230 } 1231 else 1232 #endif 1233 for (i = min; i <= max; i++) 1234 *d++ = i; 1235 1236 /* mark the range as done, and continue */ 1237 dorange = FALSE; 1238 continue; 1239 } 1240 1241 /* range begins (ignore - as first or last char) */ 1242 else if (*s == '-' && s+1 < send && s != start) { 1243 if (utf) { 1244 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */ 1245 s++; 1246 continue; 1247 } 1248 dorange = TRUE; 1249 s++; 1250 } 1251 } 1252 1253 /* if we get here, we're not doing a transliteration */ 1254 1255 /* skip for regexp comments /(?#comment)/ and code /(?{code})/, 1256 except for the last char, which will be done separately. */ 1257 else if (*s == '(' && PL_lex_inpat && s[1] == '?') { 1258 if (s[2] == '#') { 1259 while (s < send && *s != ')') 1260 *d++ = *s++; 1261 } 1262 else if (s[2] == '{' /* This should match regcomp.c */ 1263 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{')) 1264 { 1265 I32 count = 1; 1266 char *regparse = s + (s[2] == '{' ? 3 : 4); 1267 char c; 1268 1269 while (count && (c = *regparse)) { 1270 if (c == '\\' && regparse[1]) 1271 regparse++; 1272 else if (c == '{') 1273 count++; 1274 else if (c == '}') 1275 count--; 1276 regparse++; 1277 } 1278 if (*regparse != ')') { 1279 regparse--; /* Leave one char for continuation. */ 1280 yyerror("Sequence (?{...}) not terminated or not {}-balanced"); 1281 } 1282 while (s < regparse) 1283 *d++ = *s++; 1284 } 1285 } 1286 1287 /* likewise skip #-initiated comments in //x patterns */ 1288 else if (*s == '#' && PL_lex_inpat && 1289 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) { 1290 while (s+1 < send && *s != '\n') 1291 *d++ = *s++; 1292 } 1293 1294 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */ 1295 else if (*s == '@' && s[1] 1296 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$", s[1]))) 1297 break; 1298 1299 /* check for embedded scalars. only stop if we're sure it's a 1300 variable. 1301 */ 1302 else if (*s == '$') { 1303 if (!PL_lex_inpat) /* not a regexp, so $ must be var */ 1304 break; 1305 if (s + 1 < send && !strchr("()| \n\t", s[1])) 1306 break; /* in regexp, $ might be tail anchor */ 1307 } 1308 1309 /* backslashes */ 1310 if (*s == '\\' && s+1 < send) { 1311 bool to_be_utf8 = FALSE; 1312 1313 s++; 1314 1315 /* some backslashes we leave behind */ 1316 if (*leaveit && *s && strchr(leaveit, *s)) { 1317 *d++ = '\\'; 1318 *d++ = *s++; 1319 continue; 1320 } 1321 1322 /* deprecate \1 in strings and substitution replacements */ 1323 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat && 1324 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) 1325 { 1326 if (ckWARN(WARN_SYNTAX)) 1327 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s); 1328 *--s = '$'; 1329 break; 1330 } 1331 1332 /* string-change backslash escapes */ 1333 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) { 1334 --s; 1335 break; 1336 } 1337 1338 /* if we get here, it's either a quoted -, or a digit */ 1339 switch (*s) { 1340 1341 /* quoted - in transliterations */ 1342 case '-': 1343 if (PL_lex_inwhat == OP_TRANS) { 1344 *d++ = *s++; 1345 continue; 1346 } 1347 /* FALL THROUGH */ 1348 default: 1349 { 1350 if (ckWARN(WARN_MISC) && isALPHA(*s)) 1351 Perl_warner(aTHX_ WARN_MISC, 1352 "Unrecognized escape \\%c passed through", 1353 *s); 1354 /* default action is to copy the quoted character */ 1355 goto default_action; 1356 } 1357 1358 /* \132 indicates an octal constant */ 1359 case '0': case '1': case '2': case '3': 1360 case '4': case '5': case '6': case '7': 1361 { 1362 STRLEN len = 0; /* disallow underscores */ 1363 uv = (UV)scan_oct(s, 3, &len); 1364 s += len; 1365 } 1366 goto NUM_ESCAPE_INSERT; 1367 1368 /* \x24 indicates a hex constant */ 1369 case 'x': 1370 ++s; 1371 if (*s == '{') { 1372 char* e = strchr(s, '}'); 1373 if (!e) { 1374 yyerror("Missing right brace on \\x{}"); 1375 e = s; 1376 } 1377 else { 1378 STRLEN len = 1; /* allow underscores */ 1379 uv = (UV)scan_hex(s + 1, e - s - 1, &len); 1380 to_be_utf8 = TRUE; 1381 } 1382 s = e + 1; 1383 } 1384 else { 1385 { 1386 STRLEN len = 0; /* disallow underscores */ 1387 uv = (UV)scan_hex(s, 2, &len); 1388 s += len; 1389 } 1390 } 1391 1392 NUM_ESCAPE_INSERT: 1393 /* Insert oct or hex escaped character. 1394 * There will always enough room in sv since such 1395 * escapes will be longer than any UT-F8 sequence 1396 * they can end up as. */ 1397 1398 /* This spot is wrong for EBCDIC. Characters like 1399 * the lowercase letters and digits are >127 in EBCDIC, 1400 * so here they would need to be mapped to the Unicode 1401 * repertoire. --jhi */ 1402 1403 if (uv > 127) { 1404 if (!has_utf8 && (to_be_utf8 || uv > 255)) { 1405 /* Might need to recode whatever we have 1406 * accumulated so far if it contains any 1407 * hibit chars. 1408 * 1409 * (Can't we keep track of that and avoid 1410 * this rescan? --jhi) 1411 */ 1412 int hicount = 0; 1413 char *c; 1414 1415 for (c = SvPVX(sv); c < d; c++) { 1416 if (UTF8_IS_CONTINUED(*c)) 1417 hicount++; 1418 } 1419 if (hicount) { 1420 char *old_pvx = SvPVX(sv); 1421 char *src, *dst; 1422 1423 d = SvGROW(sv, 1424 SvCUR(sv) + hicount + 1) + 1425 (d - old_pvx); 1426 1427 src = d - 1; 1428 d += hicount; 1429 dst = d - 1; 1430 1431 while (src < dst) { 1432 if (UTF8_IS_CONTINUED(*src)) { 1433 *dst-- = UTF8_EIGHT_BIT_LO(*src); 1434 *dst-- = UTF8_EIGHT_BIT_HI(*src--); 1435 } 1436 else { 1437 *dst-- = *src--; 1438 } 1439 } 1440 } 1441 } 1442 1443 if (to_be_utf8 || has_utf8 || uv > 255) { 1444 d = (char*)uv_to_utf8((U8*)d, uv); 1445 has_utf8 = TRUE; 1446 if (PL_lex_inwhat == OP_TRANS && 1447 PL_sublex_info.sub_op) { 1448 PL_sublex_info.sub_op->op_private |= 1449 (PL_lex_repl ? OPpTRANS_FROM_UTF 1450 : OPpTRANS_TO_UTF); 1451 utf = TRUE; 1452 } 1453 } 1454 else { 1455 *d++ = (char)uv; 1456 } 1457 } 1458 else { 1459 *d++ = (char)uv; 1460 } 1461 continue; 1462 1463 /* \N{latin small letter a} is a named character */ 1464 case 'N': 1465 ++s; 1466 if (*s == '{') { 1467 char* e = strchr(s, '}'); 1468 SV *res; 1469 STRLEN len; 1470 char *str; 1471 1472 if (!e) { 1473 yyerror("Missing right brace on \\N{}"); 1474 e = s - 1; 1475 goto cont_scan; 1476 } 1477 res = newSVpvn(s + 1, e - s - 1); 1478 res = new_constant( Nullch, 0, "charnames", 1479 res, Nullsv, "\\N{...}" ); 1480 if (has_utf8) 1481 sv_utf8_upgrade(res); 1482 str = SvPV(res,len); 1483 if (!has_utf8 && SvUTF8(res)) { 1484 char *ostart = SvPVX(sv); 1485 SvCUR_set(sv, d - ostart); 1486 SvPOK_on(sv); 1487 *d = '\0'; 1488 sv_utf8_upgrade(sv); 1489 /* this just broke our allocation above... */ 1490 SvGROW(sv, send - start); 1491 d = SvPVX(sv) + SvCUR(sv); 1492 has_utf8 = TRUE; 1493 } 1494 if (len > e - s + 4) { 1495 char *odest = SvPVX(sv); 1496 1497 SvGROW(sv, (SvCUR(sv) + len - (e - s + 4))); 1498 d = SvPVX(sv) + (d - odest); 1499 } 1500 Copy(str, d, len, char); 1501 d += len; 1502 SvREFCNT_dec(res); 1503 cont_scan: 1504 s = e + 1; 1505 } 1506 else 1507 yyerror("Missing braces on \\N{}"); 1508 continue; 1509 1510 /* \c is a control character */ 1511 case 'c': 1512 s++; 1513 #ifdef EBCDIC 1514 *d = *s++; 1515 if (isLOWER(*d)) 1516 *d = toUPPER(*d); 1517 *d = toCTRL(*d); 1518 d++; 1519 #else 1520 { 1521 U8 c = *s++; 1522 *d++ = toCTRL(c); 1523 } 1524 #endif 1525 continue; 1526 1527 /* printf-style backslashes, formfeeds, newlines, etc */ 1528 case 'b': 1529 *d++ = '\b'; 1530 break; 1531 case 'n': 1532 *d++ = '\n'; 1533 break; 1534 case 'r': 1535 *d++ = '\r'; 1536 break; 1537 case 'f': 1538 *d++ = '\f'; 1539 break; 1540 case 't': 1541 *d++ = '\t'; 1542 break; 1543 #ifdef EBCDIC 1544 case 'e': 1545 *d++ = '\047'; /* CP 1047 */ 1546 break; 1547 case 'a': 1548 *d++ = '\057'; /* CP 1047 */ 1549 break; 1550 #else 1551 case 'e': 1552 *d++ = '\033'; 1553 break; 1554 case 'a': 1555 *d++ = '\007'; 1556 break; 1557 #endif 1558 } /* end switch */ 1559 1560 s++; 1561 continue; 1562 } /* end if (backslash) */ 1563 1564 default_action: 1565 if (UTF8_IS_CONTINUED(*s) && (this_utf8 || has_utf8)) { 1566 STRLEN len = (STRLEN) -1; 1567 UV uv; 1568 if (this_utf8) { 1569 uv = utf8_to_uv((U8*)s, send - s, &len, 0); 1570 } 1571 if (len == (STRLEN)-1) { 1572 /* Illegal UTF8 (a high-bit byte), make it valid. */ 1573 char *old_pvx = SvPVX(sv); 1574 /* need space for one extra char (NOTE: SvCUR() not set here) */ 1575 d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx); 1576 d = (char*)uv_to_utf8((U8*)d, (U8)*s++); 1577 } 1578 else { 1579 while (len--) 1580 *d++ = *s++; 1581 } 1582 has_utf8 = TRUE; 1583 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { 1584 PL_sublex_info.sub_op->op_private |= 1585 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF); 1586 utf = TRUE; 1587 } 1588 continue; 1589 } 1590 1591 *d++ = *s++; 1592 } /* while loop to process each character */ 1593 1594 /* terminate the string and set up the sv */ 1595 *d = '\0'; 1596 SvCUR_set(sv, d - SvPVX(sv)); 1597 SvPOK_on(sv); 1598 if (has_utf8) 1599 SvUTF8_on(sv); 1600 1601 /* shrink the sv if we allocated more than we used */ 1602 if (SvCUR(sv) + 5 < SvLEN(sv)) { 1603 SvLEN_set(sv, SvCUR(sv) + 1); 1604 Renew(SvPVX(sv), SvLEN(sv), char); 1605 } 1606 1607 /* return the substring (via yylval) only if we parsed anything */ 1608 if (s > PL_bufptr) { 1609 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) 1610 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"), 1611 sv, Nullsv, 1612 ( PL_lex_inwhat == OP_TRANS 1613 ? "tr" 1614 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) 1615 ? "s" 1616 : "qq"))); 1617 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); 1618 } else 1619 SvREFCNT_dec(sv); 1620 return s; 1621 } 1622 1623 /* S_intuit_more 1624 * Returns TRUE if there's more to the expression (e.g., a subscript), 1625 * FALSE otherwise. 1626 * 1627 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/ 1628 * 1629 * ->[ and ->{ return TRUE 1630 * { and [ outside a pattern are always subscripts, so return TRUE 1631 * if we're outside a pattern and it's not { or [, then return FALSE 1632 * if we're in a pattern and the first char is a { 1633 * {4,5} (any digits around the comma) returns FALSE 1634 * if we're in a pattern and the first char is a [ 1635 * [] returns FALSE 1636 * [SOMETHING] has a funky algorithm to decide whether it's a 1637 * character class or not. It has to deal with things like 1638 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/ 1639 * anything else returns TRUE 1640 */ 1641 1642 /* This is the one truly awful dwimmer necessary to conflate C and sed. */ 1643 1644 STATIC int 1645 S_intuit_more(pTHX_ register char *s) 1646 { 1647 if (PL_lex_brackets) 1648 return TRUE; 1649 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{')) 1650 return TRUE; 1651 if (*s != '{' && *s != '[') 1652 return FALSE; 1653 if (!PL_lex_inpat) 1654 return TRUE; 1655 1656 /* In a pattern, so maybe we have {n,m}. */ 1657 if (*s == '{') { 1658 s++; 1659 if (!isDIGIT(*s)) 1660 return TRUE; 1661 while (isDIGIT(*s)) 1662 s++; 1663 if (*s == ',') 1664 s++; 1665 while (isDIGIT(*s)) 1666 s++; 1667 if (*s == '}') 1668 return FALSE; 1669 return TRUE; 1670 1671 } 1672 1673 /* On the other hand, maybe we have a character class */ 1674 1675 s++; 1676 if (*s == ']' || *s == '^') 1677 return FALSE; 1678 else { 1679 /* this is terrifying, and it works */ 1680 int weight = 2; /* let's weigh the evidence */ 1681 char seen[256]; 1682 unsigned char un_char = 255, last_un_char; 1683 char *send = strchr(s,']'); 1684 char tmpbuf[sizeof PL_tokenbuf * 4]; 1685 1686 if (!send) /* has to be an expression */ 1687 return TRUE; 1688 1689 Zero(seen,256,char); 1690 if (*s == '$') 1691 weight -= 3; 1692 else if (isDIGIT(*s)) { 1693 if (s[1] != ']') { 1694 if (isDIGIT(s[1]) && s[2] == ']') 1695 weight -= 10; 1696 } 1697 else 1698 weight -= 100; 1699 } 1700 for (; s < send; s++) { 1701 last_un_char = un_char; 1702 un_char = (unsigned char)*s; 1703 switch (*s) { 1704 case '@': 1705 case '&': 1706 case '$': 1707 weight -= seen[un_char] * 10; 1708 if (isALNUM_lazy_if(s+1,UTF)) { 1709 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE); 1710 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV)) 1711 weight -= 100; 1712 else 1713 weight -= 10; 1714 } 1715 else if (*s == '$' && s[1] && 1716 strchr("[#!%*<>()-=",s[1])) { 1717 if (/*{*/ strchr("])} =",s[2])) 1718 weight -= 10; 1719 else 1720 weight -= 1; 1721 } 1722 break; 1723 case '\\': 1724 un_char = 254; 1725 if (s[1]) { 1726 if (strchr("wds]",s[1])) 1727 weight += 100; 1728 else if (seen['\''] || seen['"']) 1729 weight += 1; 1730 else if (strchr("rnftbxcav",s[1])) 1731 weight += 40; 1732 else if (isDIGIT(s[1])) { 1733 weight += 40; 1734 while (s[1] && isDIGIT(s[1])) 1735 s++; 1736 } 1737 } 1738 else 1739 weight += 100; 1740 break; 1741 case '-': 1742 if (s[1] == '\\') 1743 weight += 50; 1744 if (strchr("aA01! ",last_un_char)) 1745 weight += 30; 1746 if (strchr("zZ79~",s[1])) 1747 weight += 30; 1748 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$')) 1749 weight -= 5; /* cope with negative subscript */ 1750 break; 1751 default: 1752 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) && 1753 isALPHA(*s) && s[1] && isALPHA(s[1])) { 1754 char *d = tmpbuf; 1755 while (isALPHA(*s)) 1756 *d++ = *s++; 1757 *d = '\0'; 1758 if (keyword(tmpbuf, d - tmpbuf)) 1759 weight -= 150; 1760 } 1761 if (un_char == last_un_char + 1) 1762 weight += 5; 1763 weight -= seen[un_char]; 1764 break; 1765 } 1766 seen[un_char]++; 1767 } 1768 if (weight >= 0) /* probably a character class */ 1769 return FALSE; 1770 } 1771 1772 return TRUE; 1773 } 1774 1775 /* 1776 * S_intuit_method 1777 * 1778 * Does all the checking to disambiguate 1779 * foo bar 1780 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise 1781 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args). 1782 * 1783 * First argument is the stuff after the first token, e.g. "bar". 1784 * 1785 * Not a method if bar is a filehandle. 1786 * Not a method if foo is a subroutine prototyped to take a filehandle. 1787 * Not a method if it's really "Foo $bar" 1788 * Method if it's "foo $bar" 1789 * Not a method if it's really "print foo $bar" 1790 * Method if it's really "foo package::" (interpreted as package->foo) 1791 * Not a method if bar is known to be a subroutne ("sub bar; foo bar") 1792 * Not a method if bar is a filehandle or package, but is quoted with 1793 * => 1794 */ 1795 1796 STATIC int 1797 S_intuit_method(pTHX_ char *start, GV *gv) 1798 { 1799 char *s = start + (*start == '$'); 1800 char tmpbuf[sizeof PL_tokenbuf]; 1801 STRLEN len; 1802 GV* indirgv; 1803 1804 if (gv) { 1805 CV *cv; 1806 if (GvIO(gv)) 1807 return 0; 1808 if ((cv = GvCVu(gv))) { 1809 char *proto = SvPVX(cv); 1810 if (proto) { 1811 if (*proto == ';') 1812 proto++; 1813 if (*proto == '*') 1814 return 0; 1815 } 1816 } else 1817 gv = 0; 1818 } 1819 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); 1820 /* start is the beginning of the possible filehandle/object, 1821 * and s is the end of it 1822 * tmpbuf is a copy of it 1823 */ 1824 1825 if (*start == '$') { 1826 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf)) 1827 return 0; 1828 s = skipspace(s); 1829 PL_bufptr = start; 1830 PL_expect = XREF; 1831 return *s == '(' ? FUNCMETH : METHOD; 1832 } 1833 if (!keyword(tmpbuf, len)) { 1834 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') { 1835 len -= 2; 1836 tmpbuf[len] = '\0'; 1837 goto bare_package; 1838 } 1839 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV); 1840 if (indirgv && GvCVu(indirgv)) 1841 return 0; 1842 /* filehandle or package name makes it a method */ 1843 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) { 1844 s = skipspace(s); 1845 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>') 1846 return 0; /* no assumptions -- "=>" quotes bearword */ 1847 bare_package: 1848 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, 1849 newSVpvn(tmpbuf,len)); 1850 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE; 1851 PL_expect = XTERM; 1852 force_next(WORD); 1853 PL_bufptr = s; 1854 return *s == '(' ? FUNCMETH : METHOD; 1855 } 1856 } 1857 return 0; 1858 } 1859 1860 /* 1861 * S_incl_perldb 1862 * Return a string of Perl code to load the debugger. If PERL5DB 1863 * is set, it will return the contents of that, otherwise a 1864 * compile-time require of perl5db.pl. 1865 */ 1866 1867 STATIC char* 1868 S_incl_perldb(pTHX) 1869 { 1870 if (PL_perldb) { 1871 char *pdb = PerlEnv_getenv("PERL5DB"); 1872 1873 if (pdb) 1874 return pdb; 1875 SETERRNO(0,SS$_NORMAL); 1876 return "BEGIN { require 'perl5db.pl' }"; 1877 } 1878 return ""; 1879 } 1880 1881 1882 /* Encoded script support. filter_add() effectively inserts a 1883 * 'pre-processing' function into the current source input stream. 1884 * Note that the filter function only applies to the current source file 1885 * (e.g., it will not affect files 'require'd or 'use'd by this one). 1886 * 1887 * The datasv parameter (which may be NULL) can be used to pass 1888 * private data to this instance of the filter. The filter function 1889 * can recover the SV using the FILTER_DATA macro and use it to 1890 * store private buffers and state information. 1891 * 1892 * The supplied datasv parameter is upgraded to a PVIO type 1893 * and the IoDIRP/IoANY field is used to store the function pointer, 1894 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such. 1895 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for 1896 * private use must be set using malloc'd pointers. 1897 */ 1898 1899 SV * 1900 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) 1901 { 1902 if (!funcp) 1903 return Nullsv; 1904 1905 if (!PL_rsfp_filters) 1906 PL_rsfp_filters = newAV(); 1907 if (!datasv) 1908 datasv = NEWSV(255,0); 1909 if (!SvUPGRADE(datasv, SVt_PVIO)) 1910 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO"); 1911 IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */ 1912 IoFLAGS(datasv) |= IOf_FAKE_DIRP; 1913 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n", 1914 funcp, SvPV_nolen(datasv))); 1915 av_unshift(PL_rsfp_filters, 1); 1916 av_store(PL_rsfp_filters, 0, datasv) ; 1917 return(datasv); 1918 } 1919 1920 1921 /* Delete most recently added instance of this filter function. */ 1922 void 1923 Perl_filter_del(pTHX_ filter_t funcp) 1924 { 1925 SV *datasv; 1926 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp)); 1927 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0) 1928 return; 1929 /* if filter is on top of stack (usual case) just pop it off */ 1930 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters)); 1931 if (IoANY(datasv) == (void *)funcp) { 1932 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP; 1933 IoANY(datasv) = (void *)NULL; 1934 sv_free(av_pop(PL_rsfp_filters)); 1935 1936 return; 1937 } 1938 /* we need to search for the correct entry and clear it */ 1939 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)"); 1940 } 1941 1942 1943 /* Invoke the n'th filter function for the current rsfp. */ 1944 I32 1945 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) 1946 1947 1948 /* 0 = read one text line */ 1949 { 1950 filter_t funcp; 1951 SV *datasv = NULL; 1952 1953 if (!PL_rsfp_filters) 1954 return -1; 1955 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */ 1956 /* Provide a default input filter to make life easy. */ 1957 /* Note that we append to the line. This is handy. */ 1958 DEBUG_P(PerlIO_printf(Perl_debug_log, 1959 "filter_read %d: from rsfp\n", idx)); 1960 if (maxlen) { 1961 /* Want a block */ 1962 int len ; 1963 int old_len = SvCUR(buf_sv) ; 1964 1965 /* ensure buf_sv is large enough */ 1966 SvGROW(buf_sv, old_len + maxlen) ; 1967 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){ 1968 if (PerlIO_error(PL_rsfp)) 1969 return -1; /* error */ 1970 else 1971 return 0 ; /* end of file */ 1972 } 1973 SvCUR_set(buf_sv, old_len + len) ; 1974 } else { 1975 /* Want a line */ 1976 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) { 1977 if (PerlIO_error(PL_rsfp)) 1978 return -1; /* error */ 1979 else 1980 return 0 ; /* end of file */ 1981 } 1982 } 1983 return SvCUR(buf_sv); 1984 } 1985 /* Skip this filter slot if filter has been deleted */ 1986 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){ 1987 DEBUG_P(PerlIO_printf(Perl_debug_log, 1988 "filter_read %d: skipped (filter deleted)\n", 1989 idx)); 1990 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */ 1991 } 1992 /* Get function pointer hidden within datasv */ 1993 funcp = (filter_t)IoANY(datasv); 1994 DEBUG_P(PerlIO_printf(Perl_debug_log, 1995 "filter_read %d: via function %p (%s)\n", 1996 idx, funcp, SvPV_nolen(datasv))); 1997 /* Call function. The function is expected to */ 1998 /* call "FILTER_READ(idx+1, buf_sv)" first. */ 1999 /* Return: <0:error, =0:eof, >0:not eof */ 2000 return (*funcp)(aTHXo_ idx, buf_sv, maxlen); 2001 } 2002 2003 STATIC char * 2004 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) 2005 { 2006 #ifdef PERL_CR_FILTER 2007 if (!PL_rsfp_filters) { 2008 filter_add(S_cr_textfilter,NULL); 2009 } 2010 #endif 2011 if (PL_rsfp_filters) { 2012 2013 if (!append) 2014 SvCUR_set(sv, 0); /* start with empty line */ 2015 if (FILTER_READ(0, sv, 0) > 0) 2016 return ( SvPVX(sv) ) ; 2017 else 2018 return Nullch ; 2019 } 2020 else 2021 return (sv_gets(sv, fp, append)); 2022 } 2023 2024 STATIC HV * 2025 S_find_in_my_stash(pTHX_ char *pkgname, I32 len) 2026 { 2027 GV *gv; 2028 2029 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__")) 2030 return PL_curstash; 2031 2032 if (len > 2 && 2033 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') && 2034 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV))) 2035 { 2036 return GvHV(gv); /* Foo:: */ 2037 } 2038 2039 /* use constant CLASS => 'MyClass' */ 2040 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) { 2041 SV *sv; 2042 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) { 2043 pkgname = SvPV_nolen(sv); 2044 } 2045 } 2046 2047 return gv_stashpv(pkgname, FALSE); 2048 } 2049 2050 #ifdef DEBUGGING 2051 static char* exp_name[] = 2052 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK", 2053 "ATTRTERM", "TERMBLOCK" 2054 }; 2055 #endif 2056 2057 /* 2058 yylex 2059 2060 Works out what to call the token just pulled out of the input 2061 stream. The yacc parser takes care of taking the ops we return and 2062 stitching them into a tree. 2063 2064 Returns: 2065 PRIVATEREF 2066 2067 Structure: 2068 if read an identifier 2069 if we're in a my declaration 2070 croak if they tried to say my($foo::bar) 2071 build the ops for a my() declaration 2072 if it's an access to a my() variable 2073 are we in a sort block? 2074 croak if my($a); $a <=> $b 2075 build ops for access to a my() variable 2076 if in a dq string, and they've said @foo and we can't find @foo 2077 croak 2078 build ops for a bareword 2079 if we already built the token before, use it. 2080 */ 2081 2082 #ifdef USE_PURE_BISON 2083 int 2084 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp) 2085 { 2086 int r; 2087 2088 yyactlevel++; 2089 yylval_pointer[yyactlevel] = lvalp; 2090 yychar_pointer[yyactlevel] = lcharp; 2091 if (yyactlevel >= YYMAXLEVEL) 2092 Perl_croak(aTHX_ "panic: YYMAXLEVEL"); 2093 2094 r = Perl_yylex(aTHX); 2095 2096 yyactlevel--; 2097 2098 return r; 2099 } 2100 #endif 2101 2102 #ifdef __SC__ 2103 #pragma segment Perl_yylex 2104 #endif 2105 int 2106 Perl_yylex(pTHX) 2107 { 2108 register char *s; 2109 register char *d; 2110 register I32 tmp; 2111 STRLEN len; 2112 GV *gv = Nullgv; 2113 GV **gvp = 0; 2114 bool bof = FALSE; 2115 2116 /* check if there's an identifier for us to look at */ 2117 if (PL_pending_ident) { 2118 /* pit holds the identifier we read and pending_ident is reset */ 2119 char pit = PL_pending_ident; 2120 PL_pending_ident = 0; 2121 2122 DEBUG_T({ PerlIO_printf(Perl_debug_log, 2123 "### Tokener saw identifier '%s'\n", PL_tokenbuf); }) 2124 2125 /* if we're in a my(), we can't allow dynamics here. 2126 $foo'bar has already been turned into $foo::bar, so 2127 just check for colons. 2128 2129 if it's a legal name, the OP is a PADANY. 2130 */ 2131 if (PL_in_my) { 2132 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */ 2133 if (strchr(PL_tokenbuf,':')) 2134 yyerror(Perl_form(aTHX_ "No package name allowed for " 2135 "variable %s in \"our\"", 2136 PL_tokenbuf)); 2137 tmp = pad_allocmy(PL_tokenbuf); 2138 } 2139 else { 2140 if (strchr(PL_tokenbuf,':')) 2141 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf)); 2142 2143 yylval.opval = newOP(OP_PADANY, 0); 2144 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf); 2145 return PRIVATEREF; 2146 } 2147 } 2148 2149 /* 2150 build the ops for accesses to a my() variable. 2151 2152 Deny my($a) or my($b) in a sort block, *if* $a or $b is 2153 then used in a comparison. This catches most, but not 2154 all cases. For instance, it catches 2155 sort { my($a); $a <=> $b } 2156 but not 2157 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; } 2158 (although why you'd do that is anyone's guess). 2159 */ 2160 2161 if (!strchr(PL_tokenbuf,':')) { 2162 #ifdef USE_THREADS 2163 /* Check for single character per-thread SVs */ 2164 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0' 2165 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */ 2166 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD) 2167 { 2168 yylval.opval = newOP(OP_THREADSV, 0); 2169 yylval.opval->op_targ = tmp; 2170 return PRIVATEREF; 2171 } 2172 #endif /* USE_THREADS */ 2173 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) { 2174 SV *namesv = AvARRAY(PL_comppad_name)[tmp]; 2175 /* might be an "our" variable" */ 2176 if (SvFLAGS(namesv) & SVpad_OUR) { 2177 /* build ops for a bareword */ 2178 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0); 2179 sv_catpvn(sym, "::", 2); 2180 sv_catpv(sym, PL_tokenbuf+1); 2181 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym); 2182 yylval.opval->op_private = OPpCONST_ENTERED; 2183 gv_fetchpv(SvPVX(sym), 2184 (PL_in_eval 2185 ? (GV_ADDMULTI | GV_ADDINEVAL) 2186 : TRUE 2187 ), 2188 ((PL_tokenbuf[0] == '$') ? SVt_PV 2189 : (PL_tokenbuf[0] == '@') ? SVt_PVAV 2190 : SVt_PVHV)); 2191 return WORD; 2192 } 2193 2194 /* if it's a sort block and they're naming $a or $b */ 2195 if (PL_last_lop_op == OP_SORT && 2196 PL_tokenbuf[0] == '$' && 2197 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b') 2198 && !PL_tokenbuf[2]) 2199 { 2200 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart; 2201 d < PL_bufend && *d != '\n'; 2202 d++) 2203 { 2204 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) { 2205 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison", 2206 PL_tokenbuf); 2207 } 2208 } 2209 } 2210 2211 yylval.opval = newOP(OP_PADANY, 0); 2212 yylval.opval->op_targ = tmp; 2213 return PRIVATEREF; 2214 } 2215 } 2216 2217 /* 2218 Whine if they've said @foo in a doublequoted string, 2219 and @foo isn't a variable we can find in the symbol 2220 table. 2221 */ 2222 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) { 2223 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV); 2224 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) 2225 && ckWARN(WARN_AMBIGUOUS)) 2226 { 2227 /* Downgraded from fatal to warning 20000522 mjd */ 2228 Perl_warner(aTHX_ WARN_AMBIGUOUS, 2229 "Possible unintended interpolation of %s in string", 2230 PL_tokenbuf); 2231 } 2232 } 2233 2234 /* build ops for a bareword */ 2235 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0)); 2236 yylval.opval->op_private = OPpCONST_ENTERED; 2237 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE, 2238 ((PL_tokenbuf[0] == '$') ? SVt_PV 2239 : (PL_tokenbuf[0] == '@') ? SVt_PVAV 2240 : SVt_PVHV)); 2241 return WORD; 2242 } 2243 2244 /* no identifier pending identification */ 2245 2246 switch (PL_lex_state) { 2247 #ifdef COMMENTARY 2248 case LEX_NORMAL: /* Some compilers will produce faster */ 2249 case LEX_INTERPNORMAL: /* code if we comment these out. */ 2250 break; 2251 #endif 2252 2253 /* when we've already built the next token, just pull it out of the queue */ 2254 case LEX_KNOWNEXT: 2255 PL_nexttoke--; 2256 yylval = PL_nextval[PL_nexttoke]; 2257 if (!PL_nexttoke) { 2258 PL_lex_state = PL_lex_defer; 2259 PL_expect = PL_lex_expect; 2260 PL_lex_defer = LEX_NORMAL; 2261 } 2262 DEBUG_T({ PerlIO_printf(Perl_debug_log, 2263 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr, 2264 (IV)PL_nexttype[PL_nexttoke]); }) 2265 2266 return(PL_nexttype[PL_nexttoke]); 2267 2268 /* interpolated case modifiers like \L \U, including \Q and \E. 2269 when we get here, PL_bufptr is at the \ 2270 */ 2271 case LEX_INTERPCASEMOD: 2272 #ifdef DEBUGGING 2273 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\') 2274 Perl_croak(aTHX_ "panic: INTERPCASEMOD"); 2275 #endif 2276 /* handle \E or end of string */ 2277 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') { 2278 char oldmod; 2279 2280 /* if at a \E */ 2281 if (PL_lex_casemods) { 2282 oldmod = PL_lex_casestack[--PL_lex_casemods]; 2283 PL_lex_casestack[PL_lex_casemods] = '\0'; 2284 2285 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) { 2286 PL_bufptr += 2; 2287 PL_lex_state = LEX_INTERPCONCAT; 2288 } 2289 return ')'; 2290 } 2291 if (PL_bufptr != PL_bufend) 2292 PL_bufptr += 2; 2293 PL_lex_state = LEX_INTERPCONCAT; 2294 return yylex(); 2295 } 2296 else { 2297 DEBUG_T({ PerlIO_printf(Perl_debug_log, 2298 "### Saw case modifier at '%s'\n", PL_bufptr); }) 2299 s = PL_bufptr + 1; 2300 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) 2301 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */ 2302 if (strchr("LU", *s) && 2303 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) 2304 { 2305 PL_lex_casestack[--PL_lex_casemods] = '\0'; 2306 return ')'; 2307 } 2308 if (PL_lex_casemods > 10) { 2309 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char); 2310 if (newlb != PL_lex_casestack) { 2311 SAVEFREEPV(newlb); 2312 PL_lex_casestack = newlb; 2313 } 2314 } 2315 PL_lex_casestack[PL_lex_casemods++] = *s; 2316 PL_lex_casestack[PL_lex_casemods] = '\0'; 2317 PL_lex_state = LEX_INTERPCONCAT; 2318 PL_nextval[PL_nexttoke].ival = 0; 2319 force_next('('); 2320 if (*s == 'l') 2321 PL_nextval[PL_nexttoke].ival = OP_LCFIRST; 2322 else if (*s == 'u') 2323 PL_nextval[PL_nexttoke].ival = OP_UCFIRST; 2324 else if (*s == 'L') 2325 PL_nextval[PL_nexttoke].ival = OP_LC; 2326 else if (*s == 'U') 2327 PL_nextval[PL_nexttoke].ival = OP_UC; 2328 else if (*s == 'Q') 2329 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA; 2330 else 2331 Perl_croak(aTHX_ "panic: yylex"); 2332 PL_bufptr = s + 1; 2333 force_next(FUNC); 2334 if (PL_lex_starts) { 2335 s = PL_bufptr; 2336 PL_lex_starts = 0; 2337 Aop(OP_CONCAT); 2338 } 2339 else 2340 return yylex(); 2341 } 2342 2343 case LEX_INTERPPUSH: 2344 return sublex_push(); 2345 2346 case LEX_INTERPSTART: 2347 if (PL_bufptr == PL_bufend) 2348 return sublex_done(); 2349 DEBUG_T({ PerlIO_printf(Perl_debug_log, 2350 "### Interpolated variable at '%s'\n", PL_bufptr); }) 2351 PL_expect = XTERM; 2352 PL_lex_dojoin = (*PL_bufptr == '@'); 2353 PL_lex_state = LEX_INTERPNORMAL; 2354 if (PL_lex_dojoin) { 2355 PL_nextval[PL_nexttoke].ival = 0; 2356 force_next(','); 2357 #ifdef USE_THREADS 2358 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0); 2359 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\""); 2360 force_next(PRIVATEREF); 2361 #else 2362 force_ident("\"", '$'); 2363 #endif /* USE_THREADS */ 2364 PL_nextval[PL_nexttoke].ival = 0; 2365 force_next('$'); 2366 PL_nextval[PL_nexttoke].ival = 0; 2367 force_next('('); 2368 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */ 2369 force_next(FUNC); 2370 } 2371 if (PL_lex_starts++) { 2372 s = PL_bufptr; 2373 Aop(OP_CONCAT); 2374 } 2375 return yylex(); 2376 2377 case LEX_INTERPENDMAYBE: 2378 if (intuit_more(PL_bufptr)) { 2379 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */ 2380 break; 2381 } 2382 /* FALL THROUGH */ 2383 2384 case LEX_INTERPEND: 2385 if (PL_lex_dojoin) { 2386 PL_lex_dojoin = FALSE; 2387 PL_lex_state = LEX_INTERPCONCAT; 2388 return ')'; 2389 } 2390 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl 2391 && SvEVALED(PL_lex_repl)) 2392 { 2393 if (PL_bufptr != PL_bufend) 2394 Perl_croak(aTHX_ "Bad evalled substitution pattern"); 2395 PL_lex_repl = Nullsv; 2396 } 2397 /* FALLTHROUGH */ 2398 case LEX_INTERPCONCAT: 2399 #ifdef DEBUGGING 2400 if (PL_lex_brackets) 2401 Perl_croak(aTHX_ "panic: INTERPCONCAT"); 2402 #endif 2403 if (PL_bufptr == PL_bufend) 2404 return sublex_done(); 2405 2406 if (SvIVX(PL_linestr) == '\'') { 2407 SV *sv = newSVsv(PL_linestr); 2408 if (!PL_lex_inpat) 2409 sv = tokeq(sv); 2410 else if ( PL_hints & HINT_NEW_RE ) 2411 sv = new_constant(NULL, 0, "qr", sv, sv, "q"); 2412 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); 2413 s = PL_bufend; 2414 } 2415 else { 2416 s = scan_const(PL_bufptr); 2417 if (*s == '\\') 2418 PL_lex_state = LEX_INTERPCASEMOD; 2419 else 2420 PL_lex_state = LEX_INTERPSTART; 2421 } 2422 2423 if (s != PL_bufptr) { 2424 PL_nextval[PL_nexttoke] = yylval; 2425 PL_expect = XTERM; 2426 force_next(THING); 2427 if (PL_lex_starts++) 2428 Aop(OP_CONCAT); 2429 else { 2430 PL_bufptr = s; 2431 return yylex(); 2432 } 2433 } 2434 2435 return yylex(); 2436 case LEX_FORMLINE: 2437 PL_lex_state = LEX_NORMAL; 2438 s = scan_formline(PL_bufptr); 2439 if (!PL_lex_formbrack) 2440 goto rightbracket; 2441 OPERATOR(';'); 2442 } 2443 2444 s = PL_bufptr; 2445 PL_oldoldbufptr = PL_oldbufptr; 2446 PL_oldbufptr = s; 2447 DEBUG_T( { 2448 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n", 2449 exp_name[PL_expect], s); 2450 } ) 2451 2452 retry: 2453 switch (*s) { 2454 default: 2455 if (isIDFIRST_lazy_if(s,UTF)) 2456 goto keylookup; 2457 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255); 2458 case 4: 2459 case 26: 2460 goto fake_eof; /* emulate EOF on ^D or ^Z */ 2461 case 0: 2462 if (!PL_rsfp) { 2463 PL_last_uni = 0; 2464 PL_last_lop = 0; 2465 if (PL_lex_brackets) 2466 yyerror("Missing right curly or square bracket"); 2467 DEBUG_T( { PerlIO_printf(Perl_debug_log, 2468 "### Tokener got EOF\n"); 2469 } ) 2470 TOKEN(0); 2471 } 2472 if (s++ < PL_bufend) 2473 goto retry; /* ignore stray nulls */ 2474 PL_last_uni = 0; 2475 PL_last_lop = 0; 2476 if (!PL_in_eval && !PL_preambled) { 2477 PL_preambled = TRUE; 2478 sv_setpv(PL_linestr,incl_perldb()); 2479 if (SvCUR(PL_linestr)) 2480 sv_catpv(PL_linestr,";"); 2481 if (PL_preambleav){ 2482 while(AvFILLp(PL_preambleav) >= 0) { 2483 SV *tmpsv = av_shift(PL_preambleav); 2484 sv_catsv(PL_linestr, tmpsv); 2485 sv_catpv(PL_linestr, ";"); 2486 sv_free(tmpsv); 2487 } 2488 sv_free((SV*)PL_preambleav); 2489 PL_preambleav = NULL; 2490 } 2491 if (PL_minus_n || PL_minus_p) { 2492 sv_catpv(PL_linestr, "LINE: while (<>) {"); 2493 if (PL_minus_l) 2494 sv_catpv(PL_linestr,"chomp;"); 2495 if (PL_minus_a) { 2496 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV); 2497 if (gv) 2498 GvIMPORTED_AV_on(gv); 2499 if (PL_minus_F) { 2500 if (strchr("/'\"", *PL_splitstr) 2501 && strchr(PL_splitstr + 1, *PL_splitstr)) 2502 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr); 2503 else { 2504 char delim; 2505 s = "'~#\200\1'"; /* surely one char is unused...*/ 2506 while (s[1] && strchr(PL_splitstr, *s)) s++; 2507 delim = *s; 2508 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c", 2509 "q" + (delim == '\''), delim); 2510 for (s = PL_splitstr; *s; s++) { 2511 if (*s == '\\') 2512 sv_catpvn(PL_linestr, "\\", 1); 2513 sv_catpvn(PL_linestr, s, 1); 2514 } 2515 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim); 2516 } 2517 } 2518 else 2519 sv_catpv(PL_linestr,"@F=split(' ');"); 2520 } 2521 } 2522 sv_catpv(PL_linestr, "\n"); 2523 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); 2524 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 2525 PL_last_lop = PL_last_uni = Nullch; 2526 if (PERLDB_LINE && PL_curstash != PL_debstash) { 2527 SV *sv = NEWSV(85,0); 2528 2529 sv_upgrade(sv, SVt_PVMG); 2530 sv_setsv(sv,PL_linestr); 2531 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); 2532 } 2533 goto retry; 2534 } 2535 do { 2536 bof = PL_rsfp ? TRUE : FALSE; 2537 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { 2538 fake_eof: 2539 if (PL_rsfp) { 2540 if (PL_preprocess && !PL_in_eval) 2541 (void)PerlProc_pclose(PL_rsfp); 2542 else if ((PerlIO *)PL_rsfp == PerlIO_stdin()) 2543 PerlIO_clearerr(PL_rsfp); 2544 else 2545 (void)PerlIO_close(PL_rsfp); 2546 PL_rsfp = Nullfp; 2547 PL_doextract = FALSE; 2548 } 2549 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) { 2550 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : ""); 2551 sv_catpv(PL_linestr,";}"); 2552 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); 2553 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 2554 PL_last_lop = PL_last_uni = Nullch; 2555 PL_minus_n = PL_minus_p = 0; 2556 goto retry; 2557 } 2558 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); 2559 PL_last_lop = PL_last_uni = Nullch; 2560 sv_setpv(PL_linestr,""); 2561 TOKEN(';'); /* not infinite loop because rsfp is NULL now */ 2562 } 2563 /* if it looks like the start of a BOM, check if it in fact is */ 2564 else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) { 2565 #ifdef PERLIO_IS_STDIO 2566 # ifdef __GNU_LIBRARY__ 2567 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */ 2568 # define FTELL_FOR_PIPE_IS_BROKEN 2569 # endif 2570 # else 2571 # ifdef __GLIBC__ 2572 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */ 2573 # define FTELL_FOR_PIPE_IS_BROKEN 2574 # endif 2575 # endif 2576 # endif 2577 #endif 2578 #ifdef FTELL_FOR_PIPE_IS_BROKEN 2579 /* This loses the possibility to detect the bof 2580 * situation on perl -P when the libc5 is being used. 2581 * Workaround? Maybe attach some extra state to PL_rsfp? 2582 */ 2583 if (!PL_preprocess) 2584 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr); 2585 #else 2586 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr); 2587 #endif 2588 if (bof) { 2589 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 2590 s = swallow_bom((U8*)s); 2591 } 2592 } 2593 if (PL_doextract) { 2594 if (*s == '#' && s[1] == '!' && instr(s,"perl")) 2595 PL_doextract = FALSE; 2596 2597 /* Incest with pod. */ 2598 if (*s == '=' && strnEQ(s, "=cut", 4)) { 2599 sv_setpv(PL_linestr, ""); 2600 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); 2601 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 2602 PL_last_lop = PL_last_uni = Nullch; 2603 PL_doextract = FALSE; 2604 } 2605 } 2606 incline(s); 2607 } while (PL_doextract); 2608 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; 2609 if (PERLDB_LINE && PL_curstash != PL_debstash) { 2610 SV *sv = NEWSV(85,0); 2611 2612 sv_upgrade(sv, SVt_PVMG); 2613 sv_setsv(sv,PL_linestr); 2614 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); 2615 } 2616 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 2617 PL_last_lop = PL_last_uni = Nullch; 2618 if (CopLINE(PL_curcop) == 1) { 2619 while (s < PL_bufend && isSPACE(*s)) 2620 s++; 2621 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */ 2622 s++; 2623 d = Nullch; 2624 if (!PL_in_eval) { 2625 if (*s == '#' && *(s+1) == '!') 2626 d = s + 2; 2627 #ifdef ALTERNATE_SHEBANG 2628 else { 2629 static char as[] = ALTERNATE_SHEBANG; 2630 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1)) 2631 d = s + (sizeof(as) - 1); 2632 } 2633 #endif /* ALTERNATE_SHEBANG */ 2634 } 2635 if (d) { 2636 char *ipath; 2637 char *ipathend; 2638 2639 while (isSPACE(*d)) 2640 d++; 2641 ipath = d; 2642 while (*d && !isSPACE(*d)) 2643 d++; 2644 ipathend = d; 2645 2646 #ifdef ARG_ZERO_IS_SCRIPT 2647 if (ipathend > ipath) { 2648 /* 2649 * HP-UX (at least) sets argv[0] to the script name, 2650 * which makes $^X incorrect. And Digital UNIX and Linux, 2651 * at least, set argv[0] to the basename of the Perl 2652 * interpreter. So, having found "#!", we'll set it right. 2653 */ 2654 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); 2655 assert(SvPOK(x) || SvGMAGICAL(x)); 2656 if (sv_eq(x, CopFILESV(PL_curcop))) { 2657 sv_setpvn(x, ipath, ipathend - ipath); 2658 SvSETMAGIC(x); 2659 } 2660 TAINT_NOT; /* $^X is always tainted, but that's OK */ 2661 } 2662 #endif /* ARG_ZERO_IS_SCRIPT */ 2663 2664 /* 2665 * Look for options. 2666 */ 2667 d = instr(s,"perl -"); 2668 if (!d) { 2669 d = instr(s,"perl"); 2670 #if defined(DOSISH) 2671 /* avoid getting into infinite loops when shebang 2672 * line contains "Perl" rather than "perl" */ 2673 if (!d) { 2674 for (d = ipathend-4; d >= ipath; --d) { 2675 if ((*d == 'p' || *d == 'P') 2676 && !ibcmp(d, "perl", 4)) 2677 { 2678 break; 2679 } 2680 } 2681 if (d < ipath) 2682 d = Nullch; 2683 } 2684 #endif 2685 } 2686 #ifdef ALTERNATE_SHEBANG 2687 /* 2688 * If the ALTERNATE_SHEBANG on this system starts with a 2689 * character that can be part of a Perl expression, then if 2690 * we see it but not "perl", we're probably looking at the 2691 * start of Perl code, not a request to hand off to some 2692 * other interpreter. Similarly, if "perl" is there, but 2693 * not in the first 'word' of the line, we assume the line 2694 * contains the start of the Perl program. 2695 */ 2696 if (d && *s != '#') { 2697 char *c = ipath; 2698 while (*c && !strchr("; \t\r\n\f\v#", *c)) 2699 c++; 2700 if (c < d) 2701 d = Nullch; /* "perl" not in first word; ignore */ 2702 else 2703 *s = '#'; /* Don't try to parse shebang line */ 2704 } 2705 #endif /* ALTERNATE_SHEBANG */ 2706 #ifndef MACOS_TRADITIONAL 2707 if (!d && 2708 *s == '#' && 2709 ipathend > ipath && 2710 !PL_minus_c && 2711 !instr(s,"indir") && 2712 instr(PL_origargv[0],"perl")) 2713 { 2714 char **newargv; 2715 2716 *ipathend = '\0'; 2717 s = ipathend + 1; 2718 while (s < PL_bufend && isSPACE(*s)) 2719 s++; 2720 if (s < PL_bufend) { 2721 Newz(899,newargv,PL_origargc+3,char*); 2722 newargv[1] = s; 2723 while (s < PL_bufend && !isSPACE(*s)) 2724 s++; 2725 *s = '\0'; 2726 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*); 2727 } 2728 else 2729 newargv = PL_origargv; 2730 newargv[0] = ipath; 2731 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv)); 2732 Perl_croak(aTHX_ "Can't exec %s", ipath); 2733 } 2734 #endif 2735 if (d) { 2736 U32 oldpdb = PL_perldb; 2737 bool oldn = PL_minus_n; 2738 bool oldp = PL_minus_p; 2739 2740 while (*d && !isSPACE(*d)) d++; 2741 while (SPACE_OR_TAB(*d)) d++; 2742 2743 if (*d++ == '-') { 2744 do { 2745 if (*d == 'M' || *d == 'm') { 2746 char *m = d; 2747 while (*d && !isSPACE(*d)) d++; 2748 Perl_croak(aTHX_ "Too late for \"-%.*s\" option", 2749 (int)(d - m), m); 2750 } 2751 d = moreswitches(d); 2752 } while (d); 2753 if ((PERLDB_LINE && !oldpdb) || 2754 ((PL_minus_n || PL_minus_p) && !(oldn || oldp))) 2755 /* if we have already added "LINE: while (<>) {", 2756 we must not do it again */ 2757 { 2758 sv_setpv(PL_linestr, ""); 2759 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); 2760 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 2761 PL_last_lop = PL_last_uni = Nullch; 2762 PL_preambled = FALSE; 2763 if (PERLDB_LINE) 2764 (void)gv_fetchfile(PL_origfilename); 2765 goto retry; 2766 } 2767 } 2768 } 2769 } 2770 } 2771 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { 2772 PL_bufptr = s; 2773 PL_lex_state = LEX_FORMLINE; 2774 return yylex(); 2775 } 2776 goto retry; 2777 case '\r': 2778 #ifdef PERL_STRICT_CR 2779 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r'); 2780 Perl_croak(aTHX_ 2781 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n"); 2782 #endif 2783 case ' ': case '\t': case '\f': case 013: 2784 #ifdef MACOS_TRADITIONAL 2785 case '\312': 2786 #endif 2787 s++; 2788 goto retry; 2789 case '#': 2790 case '\n': 2791 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) { 2792 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) { 2793 /* handle eval qq[#line 1 "foo"\n ...] */ 2794 CopLINE_dec(PL_curcop); 2795 incline(s); 2796 } 2797 d = PL_bufend; 2798 while (s < d && *s != '\n') 2799 s++; 2800 if (s < d) 2801 s++; 2802 incline(s); 2803 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { 2804 PL_bufptr = s; 2805 PL_lex_state = LEX_FORMLINE; 2806 return yylex(); 2807 } 2808 } 2809 else { 2810 *s = '\0'; 2811 PL_bufend = s; 2812 } 2813 goto retry; 2814 case '-': 2815 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) { 2816 I32 ftst = 0; 2817 2818 s++; 2819 PL_bufptr = s; 2820 tmp = *s++; 2821 2822 while (s < PL_bufend && SPACE_OR_TAB(*s)) 2823 s++; 2824 2825 if (strnEQ(s,"=>",2)) { 2826 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE); 2827 DEBUG_T( { PerlIO_printf(Perl_debug_log, 2828 "### Saw unary minus before =>, forcing word '%s'\n", s); 2829 } ) 2830 OPERATOR('-'); /* unary minus */ 2831 } 2832 PL_last_uni = PL_oldbufptr; 2833 switch (tmp) { 2834 case 'r': ftst = OP_FTEREAD; break; 2835 case 'w': ftst = OP_FTEWRITE; break; 2836 case 'x': ftst = OP_FTEEXEC; break; 2837 case 'o': ftst = OP_FTEOWNED; break; 2838 case 'R': ftst = OP_FTRREAD; break; 2839 case 'W': ftst = OP_FTRWRITE; break; 2840 case 'X': ftst = OP_FTREXEC; break; 2841 case 'O': ftst = OP_FTROWNED; break; 2842 case 'e': ftst = OP_FTIS; break; 2843 case 'z': ftst = OP_FTZERO; break; 2844 case 's': ftst = OP_FTSIZE; break; 2845 case 'f': ftst = OP_FTFILE; break; 2846 case 'd': ftst = OP_FTDIR; break; 2847 case 'l': ftst = OP_FTLINK; break; 2848 case 'p': ftst = OP_FTPIPE; break; 2849 case 'S': ftst = OP_FTSOCK; break; 2850 case 'u': ftst = OP_FTSUID; break; 2851 case 'g': ftst = OP_FTSGID; break; 2852 case 'k': ftst = OP_FTSVTX; break; 2853 case 'b': ftst = OP_FTBLK; break; 2854 case 'c': ftst = OP_FTCHR; break; 2855 case 't': ftst = OP_FTTTY; break; 2856 case 'T': ftst = OP_FTTEXT; break; 2857 case 'B': ftst = OP_FTBINARY; break; 2858 case 'M': case 'A': case 'C': 2859 gv_fetchpv("\024",TRUE, SVt_PV); 2860 switch (tmp) { 2861 case 'M': ftst = OP_FTMTIME; break; 2862 case 'A': ftst = OP_FTATIME; break; 2863 case 'C': ftst = OP_FTCTIME; break; 2864 default: break; 2865 } 2866 break; 2867 default: 2868 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp); 2869 break; 2870 } 2871 PL_last_lop_op = ftst; 2872 DEBUG_T( { PerlIO_printf(Perl_debug_log, 2873 "### Saw file test %c\n", (int)ftst); 2874 } ) 2875 FTST(ftst); 2876 } 2877 tmp = *s++; 2878 if (*s == tmp) { 2879 s++; 2880 if (PL_expect == XOPERATOR) 2881 TERM(POSTDEC); 2882 else 2883 OPERATOR(PREDEC); 2884 } 2885 else if (*s == '>') { 2886 s++; 2887 s = skipspace(s); 2888 if (isIDFIRST_lazy_if(s,UTF)) { 2889 s = force_word(s,METHOD,FALSE,TRUE,FALSE); 2890 TOKEN(ARROW); 2891 } 2892 else if (*s == '$') 2893 OPERATOR(ARROW); 2894 else 2895 TERM(ARROW); 2896 } 2897 if (PL_expect == XOPERATOR) 2898 Aop(OP_SUBTRACT); 2899 else { 2900 if (isSPACE(*s) || !isSPACE(*PL_bufptr)) 2901 check_uni(); 2902 OPERATOR('-'); /* unary minus */ 2903 } 2904 2905 case '+': 2906 tmp = *s++; 2907 if (*s == tmp) { 2908 s++; 2909 if (PL_expect == XOPERATOR) 2910 TERM(POSTINC); 2911 else 2912 OPERATOR(PREINC); 2913 } 2914 if (PL_expect == XOPERATOR) 2915 Aop(OP_ADD); 2916 else { 2917 if (isSPACE(*s) || !isSPACE(*PL_bufptr)) 2918 check_uni(); 2919 OPERATOR('+'); 2920 } 2921 2922 case '*': 2923 if (PL_expect != XOPERATOR) { 2924 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE); 2925 PL_expect = XOPERATOR; 2926 force_ident(PL_tokenbuf, '*'); 2927 if (!*PL_tokenbuf) 2928 PREREF('*'); 2929 TERM('*'); 2930 } 2931 s++; 2932 if (*s == '*') { 2933 s++; 2934 PWop(OP_POW); 2935 } 2936 Mop(OP_MULTIPLY); 2937 2938 case '%': 2939 if (PL_expect == XOPERATOR) { 2940 ++s; 2941 Mop(OP_MODULO); 2942 } 2943 PL_tokenbuf[0] = '%'; 2944 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE); 2945 if (!PL_tokenbuf[1]) { 2946 if (s == PL_bufend) 2947 yyerror("Final % should be \\% or %name"); 2948 PREREF('%'); 2949 } 2950 PL_pending_ident = '%'; 2951 TERM('%'); 2952 2953 case '^': 2954 s++; 2955 BOop(OP_BIT_XOR); 2956 case '[': 2957 PL_lex_brackets++; 2958 /* FALL THROUGH */ 2959 case '~': 2960 case ',': 2961 tmp = *s++; 2962 OPERATOR(tmp); 2963 case ':': 2964 if (s[1] == ':') { 2965 len = 0; 2966 goto just_a_word; 2967 } 2968 s++; 2969 switch (PL_expect) { 2970 OP *attrs; 2971 case XOPERATOR: 2972 if (!PL_in_my || PL_lex_state != LEX_NORMAL) 2973 break; 2974 PL_bufptr = s; /* update in case we back off */ 2975 goto grabattrs; 2976 case XATTRBLOCK: 2977 PL_expect = XBLOCK; 2978 goto grabattrs; 2979 case XATTRTERM: 2980 PL_expect = XTERMBLOCK; 2981 grabattrs: 2982 s = skipspace(s); 2983 attrs = Nullop; 2984 while (isIDFIRST_lazy_if(s,UTF)) { 2985 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); 2986 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) { 2987 if (tmp < 0) tmp = -tmp; 2988 switch (tmp) { 2989 case KEY_or: 2990 case KEY_and: 2991 case KEY_for: 2992 case KEY_unless: 2993 case KEY_if: 2994 case KEY_while: 2995 case KEY_until: 2996 goto got_attrs; 2997 default: 2998 break; 2999 } 3000 } 3001 if (*d == '(') { 3002 d = scan_str(d,TRUE,TRUE); 3003 if (!d) { 3004 /* MUST advance bufptr here to avoid bogus 3005 "at end of line" context messages from yyerror(). 3006 */ 3007 PL_bufptr = s + len; 3008 yyerror("Unterminated attribute parameter in attribute list"); 3009 if (attrs) 3010 op_free(attrs); 3011 return 0; /* EOF indicator */ 3012 } 3013 } 3014 if (PL_lex_stuff) { 3015 SV *sv = newSVpvn(s, len); 3016 sv_catsv(sv, PL_lex_stuff); 3017 attrs = append_elem(OP_LIST, attrs, 3018 newSVOP(OP_CONST, 0, sv)); 3019 SvREFCNT_dec(PL_lex_stuff); 3020 PL_lex_stuff = Nullsv; 3021 } 3022 else { 3023 if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len)) 3024 CvLVALUE_on(PL_compcv); 3025 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len)) 3026 CvLOCKED_on(PL_compcv); 3027 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len)) 3028 CvMETHOD_on(PL_compcv); 3029 /* After we've set the flags, it could be argued that 3030 we don't need to do the attributes.pm-based setting 3031 process, and shouldn't bother appending recognized 3032 flags. To experiment with that, uncomment the 3033 following "else": */ 3034 /* else */ 3035 attrs = append_elem(OP_LIST, attrs, 3036 newSVOP(OP_CONST, 0, 3037 newSVpvn(s, len))); 3038 } 3039 s = skipspace(d); 3040 if (*s == ':' && s[1] != ':') 3041 s = skipspace(s+1); 3042 else if (s == d) 3043 break; /* require real whitespace or :'s */ 3044 } 3045 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */ 3046 if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) { 3047 char q = ((*s == '\'') ? '"' : '\''); 3048 /* If here for an expression, and parsed no attrs, back off. */ 3049 if (tmp == '=' && !attrs) { 3050 s = PL_bufptr; 3051 break; 3052 } 3053 /* MUST advance bufptr here to avoid bogus "at end of line" 3054 context messages from yyerror(). 3055 */ 3056 PL_bufptr = s; 3057 if (!*s) 3058 yyerror("Unterminated attribute list"); 3059 else 3060 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list", 3061 q, *s, q)); 3062 if (attrs) 3063 op_free(attrs); 3064 OPERATOR(':'); 3065 } 3066 got_attrs: 3067 if (attrs) { 3068 PL_nextval[PL_nexttoke].opval = attrs; 3069 force_next(THING); 3070 } 3071 TOKEN(COLONATTR); 3072 } 3073 OPERATOR(':'); 3074 case '(': 3075 s++; 3076 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr) 3077 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */ 3078 else 3079 PL_expect = XTERM; 3080 TOKEN('('); 3081 case ';': 3082 CLINE; 3083 tmp = *s++; 3084 OPERATOR(tmp); 3085 case ')': 3086 tmp = *s++; 3087 s = skipspace(s); 3088 if (*s == '{') 3089 PREBLOCK(tmp); 3090 TERM(tmp); 3091 case ']': 3092 s++; 3093 if (PL_lex_brackets <= 0) 3094 yyerror("Unmatched right square bracket"); 3095 else 3096 --PL_lex_brackets; 3097 if (PL_lex_state == LEX_INTERPNORMAL) { 3098 if (PL_lex_brackets == 0) { 3099 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>')) 3100 PL_lex_state = LEX_INTERPEND; 3101 } 3102 } 3103 TERM(']'); 3104 case '{': 3105 leftbracket: 3106 s++; 3107 if (PL_lex_brackets > 100) { 3108 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char); 3109 if (newlb != PL_lex_brackstack) { 3110 SAVEFREEPV(newlb); 3111 PL_lex_brackstack = newlb; 3112 } 3113 } 3114 switch (PL_expect) { 3115 case XTERM: 3116 if (PL_lex_formbrack) { 3117 s--; 3118 PRETERMBLOCK(DO); 3119 } 3120 if (PL_oldoldbufptr == PL_last_lop) 3121 PL_lex_brackstack[PL_lex_brackets++] = XTERM; 3122 else 3123 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; 3124 OPERATOR(HASHBRACK); 3125 case XOPERATOR: 3126 while (s < PL_bufend && SPACE_OR_TAB(*s)) 3127 s++; 3128 d = s; 3129 PL_tokenbuf[0] = '\0'; 3130 if (d < PL_bufend && *d == '-') { 3131 PL_tokenbuf[0] = '-'; 3132 d++; 3133 while (d < PL_bufend && SPACE_OR_TAB(*d)) 3134 d++; 3135 } 3136 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) { 3137 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, 3138 FALSE, &len); 3139 while (d < PL_bufend && SPACE_OR_TAB(*d)) 3140 d++; 3141 if (*d == '}') { 3142 char minus = (PL_tokenbuf[0] == '-'); 3143 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE); 3144 if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, 0) && 3145 PL_nextval[PL_nexttoke-1].opval) 3146 SvUTF8_on(((SVOP*)PL_nextval[PL_nexttoke-1].opval)->op_sv); 3147 if (minus) 3148 force_next('-'); 3149 } 3150 } 3151 /* FALL THROUGH */ 3152 case XATTRBLOCK: 3153 case XBLOCK: 3154 PL_lex_brackstack[PL_lex_brackets++] = XSTATE; 3155 PL_expect = XSTATE; 3156 break; 3157 case XATTRTERM: 3158 case XTERMBLOCK: 3159 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; 3160 PL_expect = XSTATE; 3161 break; 3162 default: { 3163 char *t; 3164 if (PL_oldoldbufptr == PL_last_lop) 3165 PL_lex_brackstack[PL_lex_brackets++] = XTERM; 3166 else 3167 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; 3168 s = skipspace(s); 3169 if (*s == '}') 3170 OPERATOR(HASHBRACK); 3171 /* This hack serves to disambiguate a pair of curlies 3172 * as being a block or an anon hash. Normally, expectation 3173 * determines that, but in cases where we're not in a 3174 * position to expect anything in particular (like inside 3175 * eval"") we have to resolve the ambiguity. This code 3176 * covers the case where the first term in the curlies is a 3177 * quoted string. Most other cases need to be explicitly 3178 * disambiguated by prepending a `+' before the opening 3179 * curly in order to force resolution as an anon hash. 3180 * 3181 * XXX should probably propagate the outer expectation 3182 * into eval"" to rely less on this hack, but that could 3183 * potentially break current behavior of eval"". 3184 * GSAR 97-07-21 3185 */ 3186 t = s; 3187 if (*s == '\'' || *s == '"' || *s == '`') { 3188 /* common case: get past first string, handling escapes */ 3189 for (t++; t < PL_bufend && *t != *s;) 3190 if (*t++ == '\\' && (*t == '\\' || *t == *s)) 3191 t++; 3192 t++; 3193 } 3194 else if (*s == 'q') { 3195 if (++t < PL_bufend 3196 && (!isALNUM(*t) 3197 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend 3198 && !isALNUM(*t)))) 3199 { 3200 char *tmps; 3201 char open, close, term; 3202 I32 brackets = 1; 3203 3204 while (t < PL_bufend && isSPACE(*t)) 3205 t++; 3206 term = *t; 3207 open = term; 3208 if (term && (tmps = strchr("([{< )]}> )]}>",term))) 3209 term = tmps[5]; 3210 close = term; 3211 if (open == close) 3212 for (t++; t < PL_bufend; t++) { 3213 if (*t == '\\' && t+1 < PL_bufend && open != '\\') 3214 t++; 3215 else if (*t == open) 3216 break; 3217 } 3218 else 3219 for (t++; t < PL_bufend; t++) { 3220 if (*t == '\\' && t+1 < PL_bufend) 3221 t++; 3222 else if (*t == close && --brackets <= 0) 3223 break; 3224 else if (*t == open) 3225 brackets++; 3226 } 3227 } 3228 t++; 3229 } 3230 else if (isALNUM_lazy_if(t,UTF)) { 3231 t += UTF8SKIP(t); 3232 while (t < PL_bufend && isALNUM_lazy_if(t,UTF)) 3233 t += UTF8SKIP(t); 3234 } 3235 while (t < PL_bufend && isSPACE(*t)) 3236 t++; 3237 /* if comma follows first term, call it an anon hash */ 3238 /* XXX it could be a comma expression with loop modifiers */ 3239 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s))) 3240 || (*t == '=' && t[1] == '>'))) 3241 OPERATOR(HASHBRACK); 3242 if (PL_expect == XREF) 3243 PL_expect = XTERM; 3244 else { 3245 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE; 3246 PL_expect = XSTATE; 3247 } 3248 } 3249 break; 3250 } 3251 yylval.ival = CopLINE(PL_curcop); 3252 if (isSPACE(*s) || *s == '#') 3253 PL_copline = NOLINE; /* invalidate current command line number */ 3254 TOKEN('{'); 3255 case '}': 3256 rightbracket: 3257 s++; 3258 if (PL_lex_brackets <= 0) 3259 yyerror("Unmatched right curly bracket"); 3260 else 3261 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets]; 3262 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL) 3263 PL_lex_formbrack = 0; 3264 if (PL_lex_state == LEX_INTERPNORMAL) { 3265 if (PL_lex_brackets == 0) { 3266 if (PL_expect & XFAKEBRACK) { 3267 PL_expect &= XENUMMASK; 3268 PL_lex_state = LEX_INTERPEND; 3269 PL_bufptr = s; 3270 return yylex(); /* ignore fake brackets */ 3271 } 3272 if (*s == '-' && s[1] == '>') 3273 PL_lex_state = LEX_INTERPENDMAYBE; 3274 else if (*s != '[' && *s != '{') 3275 PL_lex_state = LEX_INTERPEND; 3276 } 3277 } 3278 if (PL_expect & XFAKEBRACK) { 3279 PL_expect &= XENUMMASK; 3280 PL_bufptr = s; 3281 return yylex(); /* ignore fake brackets */ 3282 } 3283 force_next('}'); 3284 TOKEN(';'); 3285 case '&': 3286 s++; 3287 tmp = *s++; 3288 if (tmp == '&') 3289 AOPERATOR(ANDAND); 3290 s--; 3291 if (PL_expect == XOPERATOR) { 3292 if (ckWARN(WARN_SEMICOLON) 3293 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart) 3294 { 3295 CopLINE_dec(PL_curcop); 3296 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi); 3297 CopLINE_inc(PL_curcop); 3298 } 3299 BAop(OP_BIT_AND); 3300 } 3301 3302 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE); 3303 if (*PL_tokenbuf) { 3304 PL_expect = XOPERATOR; 3305 force_ident(PL_tokenbuf, '&'); 3306 } 3307 else 3308 PREREF('&'); 3309 yylval.ival = (OPpENTERSUB_AMPER<<8); 3310 TERM('&'); 3311 3312 case '|': 3313 s++; 3314 tmp = *s++; 3315 if (tmp == '|') 3316 AOPERATOR(OROR); 3317 s--; 3318 BOop(OP_BIT_OR); 3319 case '=': 3320 s++; 3321 tmp = *s++; 3322 if (tmp == '=') 3323 Eop(OP_EQ); 3324 if (tmp == '>') 3325 OPERATOR(','); 3326 if (tmp == '~') 3327 PMop(OP_MATCH); 3328 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp)) 3329 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp); 3330 s--; 3331 if (PL_expect == XSTATE && isALPHA(tmp) && 3332 (s == PL_linestart+1 || s[-2] == '\n') ) 3333 { 3334 if (PL_in_eval && !PL_rsfp) { 3335 d = PL_bufend; 3336 while (s < d) { 3337 if (*s++ == '\n') { 3338 incline(s); 3339 if (strnEQ(s,"=cut",4)) { 3340 s = strchr(s,'\n'); 3341 if (s) 3342 s++; 3343 else 3344 s = d; 3345 incline(s); 3346 goto retry; 3347 } 3348 } 3349 } 3350 goto retry; 3351 } 3352 s = PL_bufend; 3353 PL_doextract = TRUE; 3354 goto retry; 3355 } 3356 if (PL_lex_brackets < PL_lex_formbrack) { 3357 char *t; 3358 #ifdef PERL_STRICT_CR 3359 for (t = s; SPACE_OR_TAB(*t); t++) ; 3360 #else 3361 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ; 3362 #endif 3363 if (*t == '\n' || *t == '#') { 3364 s--; 3365 PL_expect = XBLOCK; 3366 goto leftbracket; 3367 } 3368 } 3369 yylval.ival = 0; 3370 OPERATOR(ASSIGNOP); 3371 case '!': 3372 s++; 3373 tmp = *s++; 3374 if (tmp == '=') 3375 Eop(OP_NE); 3376 if (tmp == '~') 3377 PMop(OP_NOT); 3378 s--; 3379 OPERATOR('!'); 3380 case '<': 3381 if (PL_expect != XOPERATOR) { 3382 if (s[1] != '<' && !strchr(s,'>')) 3383 check_uni(); 3384 if (s[1] == '<') 3385 s = scan_heredoc(s); 3386 else 3387 s = scan_inputsymbol(s); 3388 TERM(sublex_start()); 3389 } 3390 s++; 3391 tmp = *s++; 3392 if (tmp == '<') 3393 SHop(OP_LEFT_SHIFT); 3394 if (tmp == '=') { 3395 tmp = *s++; 3396 if (tmp == '>') 3397 Eop(OP_NCMP); 3398 s--; 3399 Rop(OP_LE); 3400 } 3401 s--; 3402 Rop(OP_LT); 3403 case '>': 3404 s++; 3405 tmp = *s++; 3406 if (tmp == '>') 3407 SHop(OP_RIGHT_SHIFT); 3408 if (tmp == '=') 3409 Rop(OP_GE); 3410 s--; 3411 Rop(OP_GT); 3412 3413 case '$': 3414 CLINE; 3415 3416 if (PL_expect == XOPERATOR) { 3417 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { 3418 PL_expect = XTERM; 3419 depcom(); 3420 return ','; /* grandfather non-comma-format format */ 3421 } 3422 } 3423 3424 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) { 3425 PL_tokenbuf[0] = '@'; 3426 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, 3427 sizeof PL_tokenbuf - 1, FALSE); 3428 if (PL_expect == XOPERATOR) 3429 no_op("Array length", s); 3430 if (!PL_tokenbuf[1]) 3431 PREREF(DOLSHARP); 3432 PL_expect = XOPERATOR; 3433 PL_pending_ident = '#'; 3434 TOKEN(DOLSHARP); 3435 } 3436 3437 PL_tokenbuf[0] = '$'; 3438 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, 3439 sizeof PL_tokenbuf - 1, FALSE); 3440 if (PL_expect == XOPERATOR) 3441 no_op("Scalar", s); 3442 if (!PL_tokenbuf[1]) { 3443 if (s == PL_bufend) 3444 yyerror("Final $ should be \\$ or $name"); 3445 PREREF('$'); 3446 } 3447 3448 /* This kludge not intended to be bulletproof. */ 3449 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) { 3450 yylval.opval = newSVOP(OP_CONST, 0, 3451 newSViv(PL_compiling.cop_arybase)); 3452 yylval.opval->op_private = OPpCONST_ARYBASE; 3453 TERM(THING); 3454 } 3455 3456 d = s; 3457 tmp = (I32)*s; 3458 if (PL_lex_state == LEX_NORMAL) 3459 s = skipspace(s); 3460 3461 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { 3462 char *t; 3463 if (*s == '[') { 3464 PL_tokenbuf[0] = '@'; 3465 if (ckWARN(WARN_SYNTAX)) { 3466 for(t = s + 1; 3467 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$'; 3468 t++) ; 3469 if (*t++ == ',') { 3470 PL_bufptr = skipspace(PL_bufptr); 3471 while (t < PL_bufend && *t != ']') 3472 t++; 3473 Perl_warner(aTHX_ WARN_SYNTAX, 3474 "Multidimensional syntax %.*s not supported", 3475 (t - PL_bufptr) + 1, PL_bufptr); 3476 } 3477 } 3478 } 3479 else if (*s == '{') { 3480 PL_tokenbuf[0] = '%'; 3481 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") && 3482 (t = strchr(s, '}')) && (t = strchr(t, '='))) 3483 { 3484 char tmpbuf[sizeof PL_tokenbuf]; 3485 STRLEN len; 3486 for (t++; isSPACE(*t); t++) ; 3487 if (isIDFIRST_lazy_if(t,UTF)) { 3488 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len); 3489 for (; isSPACE(*t); t++) ; 3490 if (*t == ';' && get_cv(tmpbuf, FALSE)) 3491 Perl_warner(aTHX_ WARN_SYNTAX, 3492 "You need to quote \"%s\"", tmpbuf); 3493 } 3494 } 3495 } 3496 } 3497 3498 PL_expect = XOPERATOR; 3499 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) { 3500 bool islop = (PL_last_lop == PL_oldoldbufptr); 3501 if (!islop || PL_last_lop_op == OP_GREPSTART) 3502 PL_expect = XOPERATOR; 3503 else if (strchr("$@\"'`q", *s)) 3504 PL_expect = XTERM; /* e.g. print $fh "foo" */ 3505 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF)) 3506 PL_expect = XTERM; /* e.g. print $fh &sub */ 3507 else if (isIDFIRST_lazy_if(s,UTF)) { 3508 char tmpbuf[sizeof PL_tokenbuf]; 3509 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); 3510 if ((tmp = keyword(tmpbuf, len))) { 3511 /* binary operators exclude handle interpretations */ 3512 switch (tmp) { 3513 case -KEY_x: 3514 case -KEY_eq: 3515 case -KEY_ne: 3516 case -KEY_gt: 3517 case -KEY_lt: 3518 case -KEY_ge: 3519 case -KEY_le: 3520 case -KEY_cmp: 3521 break; 3522 default: 3523 PL_expect = XTERM; /* e.g. print $fh length() */ 3524 break; 3525 } 3526 } 3527 else { 3528 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV); 3529 if (gv && GvCVu(gv)) 3530 PL_expect = XTERM; /* e.g. print $fh subr() */ 3531 } 3532 } 3533 else if (isDIGIT(*s)) 3534 PL_expect = XTERM; /* e.g. print $fh 3 */ 3535 else if (*s == '.' && isDIGIT(s[1])) 3536 PL_expect = XTERM; /* e.g. print $fh .3 */ 3537 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=') 3538 PL_expect = XTERM; /* e.g. print $fh -1 */ 3539 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=') 3540 PL_expect = XTERM; /* print $fh <<"EOF" */ 3541 } 3542 PL_pending_ident = '$'; 3543 TOKEN('$'); 3544 3545 case '@': 3546 if (PL_expect == XOPERATOR) 3547 no_op("Array", s); 3548 PL_tokenbuf[0] = '@'; 3549 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); 3550 if (!PL_tokenbuf[1]) { 3551 if (s == PL_bufend) 3552 yyerror("Final @ should be \\@ or @name"); 3553 PREREF('@'); 3554 } 3555 if (PL_lex_state == LEX_NORMAL) 3556 s = skipspace(s); 3557 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { 3558 if (*s == '{') 3559 PL_tokenbuf[0] = '%'; 3560 3561 /* Warn about @ where they meant $. */ 3562 if (ckWARN(WARN_SYNTAX)) { 3563 if (*s == '[' || *s == '{') { 3564 char *t = s + 1; 3565 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t))) 3566 t++; 3567 if (*t == '}' || *t == ']') { 3568 t++; 3569 PL_bufptr = skipspace(PL_bufptr); 3570 Perl_warner(aTHX_ WARN_SYNTAX, 3571 "Scalar value %.*s better written as $%.*s", 3572 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1); 3573 } 3574 } 3575 } 3576 } 3577 PL_pending_ident = '@'; 3578 TERM('@'); 3579 3580 case '/': /* may either be division or pattern */ 3581 case '?': /* may either be conditional or pattern */ 3582 if (PL_expect != XOPERATOR) { 3583 /* Disable warning on "study /blah/" */ 3584 if (PL_oldoldbufptr == PL_last_uni 3585 && (*PL_last_uni != 's' || s - PL_last_uni < 5 3586 || memNE(PL_last_uni, "study", 5) 3587 || isALNUM_lazy_if(PL_last_uni+5,UTF))) 3588 check_uni(); 3589 s = scan_pat(s,OP_MATCH); 3590 TERM(sublex_start()); 3591 } 3592 tmp = *s++; 3593 if (tmp == '/') 3594 Mop(OP_DIVIDE); 3595 OPERATOR(tmp); 3596 3597 case '.': 3598 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack 3599 #ifdef PERL_STRICT_CR 3600 && s[1] == '\n' 3601 #else 3602 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n')) 3603 #endif 3604 && (s == PL_linestart || s[-1] == '\n') ) 3605 { 3606 PL_lex_formbrack = 0; 3607 PL_expect = XSTATE; 3608 goto rightbracket; 3609 } 3610 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) { 3611 tmp = *s++; 3612 if (*s == tmp) { 3613 s++; 3614 if (*s == tmp) { 3615 s++; 3616 yylval.ival = OPf_SPECIAL; 3617 } 3618 else 3619 yylval.ival = 0; 3620 OPERATOR(DOTDOT); 3621 } 3622 if (PL_expect != XOPERATOR) 3623 check_uni(); 3624 Aop(OP_CONCAT); 3625 } 3626 /* FALL THROUGH */ 3627 case '0': case '1': case '2': case '3': case '4': 3628 case '5': case '6': case '7': case '8': case '9': 3629 s = scan_num(s, &yylval); 3630 DEBUG_T( { PerlIO_printf(Perl_debug_log, 3631 "### Saw number in '%s'\n", s); 3632 } ) 3633 if (PL_expect == XOPERATOR) 3634 no_op("Number",s); 3635 TERM(THING); 3636 3637 case '\'': 3638 s = scan_str(s,FALSE,FALSE); 3639 DEBUG_T( { PerlIO_printf(Perl_debug_log, 3640 "### Saw string before '%s'\n", s); 3641 } ) 3642 if (PL_expect == XOPERATOR) { 3643 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { 3644 PL_expect = XTERM; 3645 depcom(); 3646 return ','; /* grandfather non-comma-format format */ 3647 } 3648 else 3649 no_op("String",s); 3650 } 3651 if (!s) 3652 missingterm((char*)0); 3653 yylval.ival = OP_CONST; 3654 TERM(sublex_start()); 3655 3656 case '"': 3657 s = scan_str(s,FALSE,FALSE); 3658 DEBUG_T( { PerlIO_printf(Perl_debug_log, 3659 "### Saw string before '%s'\n", s); 3660 } ) 3661 if (PL_expect == XOPERATOR) { 3662 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { 3663 PL_expect = XTERM; 3664 depcom(); 3665 return ','; /* grandfather non-comma-format format */ 3666 } 3667 else 3668 no_op("String",s); 3669 } 3670 if (!s) 3671 missingterm((char*)0); 3672 yylval.ival = OP_CONST; 3673 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) { 3674 if (*d == '$' || *d == '@' || *d == '\\' || UTF8_IS_CONTINUED(*d)) { 3675 yylval.ival = OP_STRINGIFY; 3676 break; 3677 } 3678 } 3679 TERM(sublex_start()); 3680 3681 case '`': 3682 s = scan_str(s,FALSE,FALSE); 3683 DEBUG_T( { PerlIO_printf(Perl_debug_log, 3684 "### Saw backtick string before '%s'\n", s); 3685 } ) 3686 if (PL_expect == XOPERATOR) 3687 no_op("Backticks",s); 3688 if (!s) 3689 missingterm((char*)0); 3690 yylval.ival = OP_BACKTICK; 3691 set_csh(); 3692 TERM(sublex_start()); 3693 3694 case '\\': 3695 s++; 3696 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s)) 3697 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression", 3698 *s, *s); 3699 if (PL_expect == XOPERATOR) 3700 no_op("Backslash",s); 3701 OPERATOR(REFGEN); 3702 3703 case 'v': 3704 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) { 3705 char *start = s; 3706 start++; 3707 start++; 3708 while (isDIGIT(*start) || *start == '_') 3709 start++; 3710 if (*start == '.' && isDIGIT(start[1])) { 3711 s = scan_num(s, &yylval); 3712 TERM(THING); 3713 } 3714 /* avoid v123abc() or $h{v1}, allow C<print v10;> */ 3715 else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) { 3716 char c = *start; 3717 GV *gv; 3718 *start = '\0'; 3719 gv = gv_fetchpv(s, FALSE, SVt_PVCV); 3720 *start = c; 3721 if (!gv) { 3722 s = scan_num(s, &yylval); 3723 TERM(THING); 3724 } 3725 } 3726 } 3727 goto keylookup; 3728 case 'x': 3729 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) { 3730 s++; 3731 Mop(OP_REPEAT); 3732 } 3733 goto keylookup; 3734 3735 case '_': 3736 case 'a': case 'A': 3737 case 'b': case 'B': 3738 case 'c': case 'C': 3739 case 'd': case 'D': 3740 case 'e': case 'E': 3741 case 'f': case 'F': 3742 case 'g': case 'G': 3743 case 'h': case 'H': 3744 case 'i': case 'I': 3745 case 'j': case 'J': 3746 case 'k': case 'K': 3747 case 'l': case 'L': 3748 case 'm': case 'M': 3749 case 'n': case 'N': 3750 case 'o': case 'O': 3751 case 'p': case 'P': 3752 case 'q': case 'Q': 3753 case 'r': case 'R': 3754 case 's': case 'S': 3755 case 't': case 'T': 3756 case 'u': case 'U': 3757 case 'V': 3758 case 'w': case 'W': 3759 case 'X': 3760 case 'y': case 'Y': 3761 case 'z': case 'Z': 3762 3763 keylookup: { 3764 gv = Nullgv; 3765 gvp = 0; 3766 3767 PL_bufptr = s; 3768 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); 3769 3770 /* Some keywords can be followed by any delimiter, including ':' */ 3771 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) || 3772 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') || 3773 (PL_tokenbuf[0] == 'q' && 3774 strchr("qwxr", PL_tokenbuf[1]))))); 3775 3776 /* x::* is just a word, unless x is "CORE" */ 3777 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE")) 3778 goto just_a_word; 3779 3780 d = s; 3781 while (d < PL_bufend && isSPACE(*d)) 3782 d++; /* no comments skipped here, or s### is misparsed */ 3783 3784 /* Is this a label? */ 3785 if (!tmp && PL_expect == XSTATE 3786 && d < PL_bufend && *d == ':' && *(d + 1) != ':') { 3787 s = d + 1; 3788 yylval.pval = savepv(PL_tokenbuf); 3789 CLINE; 3790 TOKEN(LABEL); 3791 } 3792 3793 /* Check for keywords */ 3794 tmp = keyword(PL_tokenbuf, len); 3795 3796 /* Is this a word before a => operator? */ 3797 if (*d == '=' && d[1] == '>') { 3798 CLINE; 3799 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0)); 3800 yylval.opval->op_private = OPpCONST_BARE; 3801 if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len)) 3802 SvUTF8_on(((SVOP*)yylval.opval)->op_sv); 3803 TERM(WORD); 3804 } 3805 3806 if (tmp < 0) { /* second-class keyword? */ 3807 GV *ogv = Nullgv; /* override (winner) */ 3808 GV *hgv = Nullgv; /* hidden (loser) */ 3809 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) { 3810 CV *cv; 3811 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) && 3812 (cv = GvCVu(gv))) 3813 { 3814 if (GvIMPORTED_CV(gv)) 3815 ogv = gv; 3816 else if (! CvMETHOD(cv)) 3817 hgv = gv; 3818 } 3819 if (!ogv && 3820 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) && 3821 (gv = *gvp) != (GV*)&PL_sv_undef && 3822 GvCVu(gv) && GvIMPORTED_CV(gv)) 3823 { 3824 ogv = gv; 3825 } 3826 } 3827 if (ogv) { 3828 tmp = 0; /* overridden by import or by GLOBAL */ 3829 } 3830 else if (gv && !gvp 3831 && -tmp==KEY_lock /* XXX generalizable kludge */ 3832 && GvCVu(gv) 3833 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE)) 3834 { 3835 tmp = 0; /* any sub overrides "weak" keyword */ 3836 } 3837 else { /* no override */ 3838 tmp = -tmp; 3839 gv = Nullgv; 3840 gvp = 0; 3841 if (ckWARN(WARN_AMBIGUOUS) && hgv 3842 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */ 3843 Perl_warner(aTHX_ WARN_AMBIGUOUS, 3844 "Ambiguous call resolved as CORE::%s(), %s", 3845 GvENAME(hgv), "qualify as such or use &"); 3846 } 3847 } 3848 3849 reserved_word: 3850 switch (tmp) { 3851 3852 default: /* not a keyword */ 3853 just_a_word: { 3854 SV *sv; 3855 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); 3856 3857 /* Get the rest if it looks like a package qualifier */ 3858 3859 if (*s == '\'' || (*s == ':' && s[1] == ':')) { 3860 STRLEN morelen; 3861 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len, 3862 TRUE, &morelen); 3863 if (!morelen) 3864 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf, 3865 *s == '\'' ? "'" : "::"); 3866 len += morelen; 3867 } 3868 3869 if (PL_expect == XOPERATOR) { 3870 if (PL_bufptr == PL_linestart) { 3871 CopLINE_dec(PL_curcop); 3872 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi); 3873 CopLINE_inc(PL_curcop); 3874 } 3875 else 3876 no_op("Bareword",s); 3877 } 3878 3879 /* Look for a subroutine with this name in current package, 3880 unless name is "Foo::", in which case Foo is a bearword 3881 (and a package name). */ 3882 3883 if (len > 2 && 3884 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':') 3885 { 3886 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV)) 3887 Perl_warner(aTHX_ WARN_BAREWORD, 3888 "Bareword \"%s\" refers to nonexistent package", 3889 PL_tokenbuf); 3890 len -= 2; 3891 PL_tokenbuf[len] = '\0'; 3892 gv = Nullgv; 3893 gvp = 0; 3894 } 3895 else { 3896 len = 0; 3897 if (!gv) 3898 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV); 3899 } 3900 3901 /* if we saw a global override before, get the right name */ 3902 3903 if (gvp) { 3904 sv = newSVpvn("CORE::GLOBAL::",14); 3905 sv_catpv(sv,PL_tokenbuf); 3906 } 3907 else 3908 sv = newSVpv(PL_tokenbuf,0); 3909 3910 /* Presume this is going to be a bareword of some sort. */ 3911 3912 CLINE; 3913 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); 3914 yylval.opval->op_private = OPpCONST_BARE; 3915 3916 /* And if "Foo::", then that's what it certainly is. */ 3917 3918 if (len) 3919 goto safe_bareword; 3920 3921 /* See if it's the indirect object for a list operator. */ 3922 3923 if (PL_oldoldbufptr && 3924 PL_oldoldbufptr < PL_bufptr && 3925 (PL_oldoldbufptr == PL_last_lop 3926 || PL_oldoldbufptr == PL_last_uni) && 3927 /* NO SKIPSPACE BEFORE HERE! */ 3928 (PL_expect == XREF || 3929 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF)) 3930 { 3931 bool immediate_paren = *s == '('; 3932 3933 /* (Now we can afford to cross potential line boundary.) */ 3934 s = skipspace(s); 3935 3936 /* Two barewords in a row may indicate method call. */ 3937 3938 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv))) 3939 return tmp; 3940 3941 /* If not a declared subroutine, it's an indirect object. */ 3942 /* (But it's an indir obj regardless for sort.) */ 3943 3944 if ((PL_last_lop_op == OP_SORT || 3945 (!immediate_paren && (!gv || !GvCVu(gv)))) && 3946 (PL_last_lop_op != OP_MAPSTART && 3947 PL_last_lop_op != OP_GREPSTART)) 3948 { 3949 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR; 3950 goto bareword; 3951 } 3952 } 3953 3954 3955 PL_expect = XOPERATOR; 3956 s = skipspace(s); 3957 3958 /* Is this a word before a => operator? */ 3959 if (*s == '=' && s[1] == '>') { 3960 CLINE; 3961 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf); 3962 if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len)) 3963 SvUTF8_on(((SVOP*)yylval.opval)->op_sv); 3964 TERM(WORD); 3965 } 3966 3967 /* If followed by a paren, it's certainly a subroutine. */ 3968 if (*s == '(') { 3969 CLINE; 3970 if (gv && GvCVu(gv)) { 3971 for (d = s + 1; SPACE_OR_TAB(*d); d++) ; 3972 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) { 3973 s = d + 1; 3974 goto its_constant; 3975 } 3976 } 3977 PL_nextval[PL_nexttoke].opval = yylval.opval; 3978 PL_expect = XOPERATOR; 3979 force_next(WORD); 3980 yylval.ival = 0; 3981 TOKEN('&'); 3982 } 3983 3984 /* If followed by var or block, call it a method (unless sub) */ 3985 3986 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) { 3987 PL_last_lop = PL_oldbufptr; 3988 PL_last_lop_op = OP_METHOD; 3989 PREBLOCK(METHOD); 3990 } 3991 3992 /* If followed by a bareword, see if it looks like indir obj. */ 3993 3994 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv))) 3995 return tmp; 3996 3997 /* Not a method, so call it a subroutine (if defined) */ 3998 3999 if (gv && GvCVu(gv)) { 4000 CV* cv; 4001 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS)) 4002 Perl_warner(aTHX_ WARN_AMBIGUOUS, 4003 "Ambiguous use of -%s resolved as -&%s()", 4004 PL_tokenbuf, PL_tokenbuf); 4005 /* Check for a constant sub */ 4006 cv = GvCV(gv); 4007 if ((sv = cv_const_sv(cv))) { 4008 its_constant: 4009 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv); 4010 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv); 4011 yylval.opval->op_private = 0; 4012 TOKEN(WORD); 4013 } 4014 4015 /* Resolve to GV now. */ 4016 op_free(yylval.opval); 4017 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); 4018 yylval.opval->op_private |= OPpENTERSUB_NOPAREN; 4019 PL_last_lop = PL_oldbufptr; 4020 PL_last_lop_op = OP_ENTERSUB; 4021 /* Is there a prototype? */ 4022 if (SvPOK(cv)) { 4023 STRLEN len; 4024 char *proto = SvPV((SV*)cv, len); 4025 if (!len) 4026 TERM(FUNC0SUB); 4027 if (strEQ(proto, "$")) 4028 OPERATOR(UNIOPSUB); 4029 if (*proto == '&' && *s == '{') { 4030 sv_setpv(PL_subname,"__ANON__"); 4031 PREBLOCK(LSTOPSUB); 4032 } 4033 } 4034 PL_nextval[PL_nexttoke].opval = yylval.opval; 4035 PL_expect = XTERM; 4036 force_next(WORD); 4037 TOKEN(NOAMP); 4038 } 4039 4040 /* Call it a bare word */ 4041 4042 if (PL_hints & HINT_STRICT_SUBS) 4043 yylval.opval->op_private |= OPpCONST_STRICT; 4044 else { 4045 bareword: 4046 if (ckWARN(WARN_RESERVED)) { 4047 if (lastchar != '-') { 4048 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ; 4049 if (!*d) 4050 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved, 4051 PL_tokenbuf); 4052 } 4053 } 4054 } 4055 4056 safe_bareword: 4057 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) { 4058 Perl_warner(aTHX_ WARN_AMBIGUOUS, 4059 "Operator or semicolon missing before %c%s", 4060 lastchar, PL_tokenbuf); 4061 Perl_warner(aTHX_ WARN_AMBIGUOUS, 4062 "Ambiguous use of %c resolved as operator %c", 4063 lastchar, lastchar); 4064 } 4065 TOKEN(WORD); 4066 } 4067 4068 case KEY___FILE__: 4069 yylval.opval = (OP*)newSVOP(OP_CONST, 0, 4070 newSVpv(CopFILE(PL_curcop),0)); 4071 TERM(THING); 4072 4073 case KEY___LINE__: 4074 yylval.opval = (OP*)newSVOP(OP_CONST, 0, 4075 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop))); 4076 TERM(THING); 4077 4078 case KEY___PACKAGE__: 4079 yylval.opval = (OP*)newSVOP(OP_CONST, 0, 4080 (PL_curstash 4081 ? newSVsv(PL_curstname) 4082 : &PL_sv_undef)); 4083 TERM(THING); 4084 4085 case KEY___DATA__: 4086 case KEY___END__: { 4087 GV *gv; 4088 4089 /*SUPPRESS 560*/ 4090 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) { 4091 char *pname = "main"; 4092 if (PL_tokenbuf[2] == 'D') 4093 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash); 4094 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO); 4095 GvMULTI_on(gv); 4096 if (!GvIO(gv)) 4097 GvIOp(gv) = newIO(); 4098 IoIFP(GvIOp(gv)) = PL_rsfp; 4099 #if defined(HAS_FCNTL) && defined(F_SETFD) 4100 { 4101 int fd = PerlIO_fileno(PL_rsfp); 4102 fcntl(fd,F_SETFD,fd >= 3); 4103 } 4104 #endif 4105 /* Mark this internal pseudo-handle as clean */ 4106 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT; 4107 if (PL_preprocess) 4108 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE; 4109 else if ((PerlIO*)PL_rsfp == PerlIO_stdin()) 4110 IoTYPE(GvIOp(gv)) = IoTYPE_STD; 4111 else 4112 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY; 4113 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS) 4114 /* if the script was opened in binmode, we need to revert 4115 * it to text mode for compatibility; but only iff it has CRs 4116 * XXX this is a questionable hack at best. */ 4117 if (PL_bufend-PL_bufptr > 2 4118 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r') 4119 { 4120 Off_t loc = 0; 4121 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) { 4122 loc = PerlIO_tell(PL_rsfp); 4123 (void)PerlIO_seek(PL_rsfp, 0L, 0); 4124 } 4125 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) { 4126 #if defined(__BORLANDC__) 4127 /* XXX see note in do_binmode() */ 4128 ((FILE*)PL_rsfp)->flags &= ~_F_BIN; 4129 #endif 4130 if (loc > 0) 4131 PerlIO_seek(PL_rsfp, loc, 0); 4132 } 4133 } 4134 #endif 4135 PL_rsfp = Nullfp; 4136 } 4137 goto fake_eof; 4138 } 4139 4140 case KEY_AUTOLOAD: 4141 case KEY_DESTROY: 4142 case KEY_BEGIN: 4143 case KEY_CHECK: 4144 case KEY_INIT: 4145 case KEY_END: 4146 if (PL_expect == XSTATE) { 4147 s = PL_bufptr; 4148 goto really_sub; 4149 } 4150 goto just_a_word; 4151 4152 case KEY_CORE: 4153 if (*s == ':' && s[1] == ':') { 4154 s += 2; 4155 d = s; 4156 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); 4157 if (!(tmp = keyword(PL_tokenbuf, len))) 4158 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf); 4159 if (tmp < 0) 4160 tmp = -tmp; 4161 goto reserved_word; 4162 } 4163 goto just_a_word; 4164 4165 case KEY_abs: 4166 UNI(OP_ABS); 4167 4168 case KEY_alarm: 4169 UNI(OP_ALARM); 4170 4171 case KEY_accept: 4172 LOP(OP_ACCEPT,XTERM); 4173 4174 case KEY_and: 4175 OPERATOR(ANDOP); 4176 4177 case KEY_atan2: 4178 LOP(OP_ATAN2,XTERM); 4179 4180 case KEY_bind: 4181 LOP(OP_BIND,XTERM); 4182 4183 case KEY_binmode: 4184 LOP(OP_BINMODE,XTERM); 4185 4186 case KEY_bless: 4187 LOP(OP_BLESS,XTERM); 4188 4189 case KEY_chop: 4190 UNI(OP_CHOP); 4191 4192 case KEY_continue: 4193 PREBLOCK(CONTINUE); 4194 4195 case KEY_chdir: 4196 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */ 4197 UNI(OP_CHDIR); 4198 4199 case KEY_close: 4200 UNI(OP_CLOSE); 4201 4202 case KEY_closedir: 4203 UNI(OP_CLOSEDIR); 4204 4205 case KEY_cmp: 4206 Eop(OP_SCMP); 4207 4208 case KEY_caller: 4209 UNI(OP_CALLER); 4210 4211 case KEY_crypt: 4212 #ifdef FCRYPT 4213 if (!PL_cryptseen) { 4214 PL_cryptseen = TRUE; 4215 init_des(); 4216 } 4217 #endif 4218 LOP(OP_CRYPT,XTERM); 4219 4220 case KEY_chmod: 4221 if (ckWARN(WARN_CHMOD)) { 4222 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ; 4223 if (*d != '0' && isDIGIT(*d)) 4224 Perl_warner(aTHX_ WARN_CHMOD, 4225 "chmod() mode argument is missing initial 0"); 4226 } 4227 LOP(OP_CHMOD,XTERM); 4228 4229 case KEY_chown: 4230 LOP(OP_CHOWN,XTERM); 4231 4232 case KEY_connect: 4233 LOP(OP_CONNECT,XTERM); 4234 4235 case KEY_chr: 4236 UNI(OP_CHR); 4237 4238 case KEY_cos: 4239 UNI(OP_COS); 4240 4241 case KEY_chroot: 4242 UNI(OP_CHROOT); 4243 4244 case KEY_do: 4245 s = skipspace(s); 4246 if (*s == '{') 4247 PRETERMBLOCK(DO); 4248 if (*s != '\'') 4249 s = force_word(s,WORD,FALSE,TRUE,FALSE); 4250 OPERATOR(DO); 4251 4252 case KEY_die: 4253 PL_hints |= HINT_BLOCK_SCOPE; 4254 LOP(OP_DIE,XTERM); 4255 4256 case KEY_defined: 4257 UNI(OP_DEFINED); 4258 4259 case KEY_delete: 4260 UNI(OP_DELETE); 4261 4262 case KEY_dbmopen: 4263 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV); 4264 LOP(OP_DBMOPEN,XTERM); 4265 4266 case KEY_dbmclose: 4267 UNI(OP_DBMCLOSE); 4268 4269 case KEY_dump: 4270 s = force_word(s,WORD,TRUE,FALSE,FALSE); 4271 LOOPX(OP_DUMP); 4272 4273 case KEY_else: 4274 PREBLOCK(ELSE); 4275 4276 case KEY_elsif: 4277 yylval.ival = CopLINE(PL_curcop); 4278 OPERATOR(ELSIF); 4279 4280 case KEY_eq: 4281 Eop(OP_SEQ); 4282 4283 case KEY_exists: 4284 UNI(OP_EXISTS); 4285 4286 case KEY_exit: 4287 UNI(OP_EXIT); 4288 4289 case KEY_eval: 4290 s = skipspace(s); 4291 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM; 4292 UNIBRACK(OP_ENTEREVAL); 4293 4294 case KEY_eof: 4295 UNI(OP_EOF); 4296 4297 case KEY_exp: 4298 UNI(OP_EXP); 4299 4300 case KEY_each: 4301 UNI(OP_EACH); 4302 4303 case KEY_exec: 4304 set_csh(); 4305 LOP(OP_EXEC,XREF); 4306 4307 case KEY_endhostent: 4308 FUN0(OP_EHOSTENT); 4309 4310 case KEY_endnetent: 4311 FUN0(OP_ENETENT); 4312 4313 case KEY_endservent: 4314 FUN0(OP_ESERVENT); 4315 4316 case KEY_endprotoent: 4317 FUN0(OP_EPROTOENT); 4318 4319 case KEY_endpwent: 4320 FUN0(OP_EPWENT); 4321 4322 case KEY_endgrent: 4323 FUN0(OP_EGRENT); 4324 4325 case KEY_for: 4326 case KEY_foreach: 4327 yylval.ival = CopLINE(PL_curcop); 4328 s = skipspace(s); 4329 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) { 4330 char *p = s; 4331 if ((PL_bufend - p) >= 3 && 4332 strnEQ(p, "my", 2) && isSPACE(*(p + 2))) 4333 p += 2; 4334 else if ((PL_bufend - p) >= 4 && 4335 strnEQ(p, "our", 3) && isSPACE(*(p + 3))) 4336 p += 3; 4337 p = skipspace(p); 4338 if (isIDFIRST_lazy_if(p,UTF)) { 4339 p = scan_ident(p, PL_bufend, 4340 PL_tokenbuf, sizeof PL_tokenbuf, TRUE); 4341 p = skipspace(p); 4342 } 4343 if (*p != '$') 4344 Perl_croak(aTHX_ "Missing $ on loop variable"); 4345 } 4346 OPERATOR(FOR); 4347 4348 case KEY_formline: 4349 LOP(OP_FORMLINE,XTERM); 4350 4351 case KEY_fork: 4352 FUN0(OP_FORK); 4353 4354 case KEY_fcntl: 4355 LOP(OP_FCNTL,XTERM); 4356 4357 case KEY_fileno: 4358 UNI(OP_FILENO); 4359 4360 case KEY_flock: 4361 LOP(OP_FLOCK,XTERM); 4362 4363 case KEY_gt: 4364 Rop(OP_SGT); 4365 4366 case KEY_ge: 4367 Rop(OP_SGE); 4368 4369 case KEY_grep: 4370 LOP(OP_GREPSTART, XREF); 4371 4372 case KEY_goto: 4373 s = force_word(s,WORD,TRUE,FALSE,FALSE); 4374 LOOPX(OP_GOTO); 4375 4376 case KEY_gmtime: 4377 UNI(OP_GMTIME); 4378 4379 case KEY_getc: 4380 UNI(OP_GETC); 4381 4382 case KEY_getppid: 4383 FUN0(OP_GETPPID); 4384 4385 case KEY_getpgrp: 4386 UNI(OP_GETPGRP); 4387 4388 case KEY_getpriority: 4389 LOP(OP_GETPRIORITY,XTERM); 4390 4391 case KEY_getprotobyname: 4392 UNI(OP_GPBYNAME); 4393 4394 case KEY_getprotobynumber: 4395 LOP(OP_GPBYNUMBER,XTERM); 4396 4397 case KEY_getprotoent: 4398 FUN0(OP_GPROTOENT); 4399 4400 case KEY_getpwent: 4401 FUN0(OP_GPWENT); 4402 4403 case KEY_getpwnam: 4404 UNI(OP_GPWNAM); 4405 4406 case KEY_getpwuid: 4407 UNI(OP_GPWUID); 4408 4409 case KEY_getpeername: 4410 UNI(OP_GETPEERNAME); 4411 4412 case KEY_gethostbyname: 4413 UNI(OP_GHBYNAME); 4414 4415 case KEY_gethostbyaddr: 4416 LOP(OP_GHBYADDR,XTERM); 4417 4418 case KEY_gethostent: 4419 FUN0(OP_GHOSTENT); 4420 4421 case KEY_getnetbyname: 4422 UNI(OP_GNBYNAME); 4423 4424 case KEY_getnetbyaddr: 4425 LOP(OP_GNBYADDR,XTERM); 4426 4427 case KEY_getnetent: 4428 FUN0(OP_GNETENT); 4429 4430 case KEY_getservbyname: 4431 LOP(OP_GSBYNAME,XTERM); 4432 4433 case KEY_getservbyport: 4434 LOP(OP_GSBYPORT,XTERM); 4435 4436 case KEY_getservent: 4437 FUN0(OP_GSERVENT); 4438 4439 case KEY_getsockname: 4440 UNI(OP_GETSOCKNAME); 4441 4442 case KEY_getsockopt: 4443 LOP(OP_GSOCKOPT,XTERM); 4444 4445 case KEY_getgrent: 4446 FUN0(OP_GGRENT); 4447 4448 case KEY_getgrnam: 4449 UNI(OP_GGRNAM); 4450 4451 case KEY_getgrgid: 4452 UNI(OP_GGRGID); 4453 4454 case KEY_getlogin: 4455 FUN0(OP_GETLOGIN); 4456 4457 case KEY_glob: 4458 set_csh(); 4459 LOP(OP_GLOB,XTERM); 4460 4461 case KEY_hex: 4462 UNI(OP_HEX); 4463 4464 case KEY_if: 4465 yylval.ival = CopLINE(PL_curcop); 4466 OPERATOR(IF); 4467 4468 case KEY_index: 4469 LOP(OP_INDEX,XTERM); 4470 4471 case KEY_int: 4472 UNI(OP_INT); 4473 4474 case KEY_ioctl: 4475 LOP(OP_IOCTL,XTERM); 4476 4477 case KEY_join: 4478 LOP(OP_JOIN,XTERM); 4479 4480 case KEY_keys: 4481 UNI(OP_KEYS); 4482 4483 case KEY_kill: 4484 LOP(OP_KILL,XTERM); 4485 4486 case KEY_last: 4487 s = force_word(s,WORD,TRUE,FALSE,FALSE); 4488 LOOPX(OP_LAST); 4489 4490 case KEY_lc: 4491 UNI(OP_LC); 4492 4493 case KEY_lcfirst: 4494 UNI(OP_LCFIRST); 4495 4496 case KEY_local: 4497 yylval.ival = 0; 4498 OPERATOR(LOCAL); 4499 4500 case KEY_length: 4501 UNI(OP_LENGTH); 4502 4503 case KEY_lt: 4504 Rop(OP_SLT); 4505 4506 case KEY_le: 4507 Rop(OP_SLE); 4508 4509 case KEY_localtime: 4510 UNI(OP_LOCALTIME); 4511 4512 case KEY_log: 4513 UNI(OP_LOG); 4514 4515 case KEY_link: 4516 LOP(OP_LINK,XTERM); 4517 4518 case KEY_listen: 4519 LOP(OP_LISTEN,XTERM); 4520 4521 case KEY_lock: 4522 UNI(OP_LOCK); 4523 4524 case KEY_lstat: 4525 UNI(OP_LSTAT); 4526 4527 case KEY_m: 4528 s = scan_pat(s,OP_MATCH); 4529 TERM(sublex_start()); 4530 4531 case KEY_map: 4532 LOP(OP_MAPSTART, XREF); 4533 4534 case KEY_mkdir: 4535 LOP(OP_MKDIR,XTERM); 4536 4537 case KEY_msgctl: 4538 LOP(OP_MSGCTL,XTERM); 4539 4540 case KEY_msgget: 4541 LOP(OP_MSGGET,XTERM); 4542 4543 case KEY_msgrcv: 4544 LOP(OP_MSGRCV,XTERM); 4545 4546 case KEY_msgsnd: 4547 LOP(OP_MSGSND,XTERM); 4548 4549 case KEY_our: 4550 case KEY_my: 4551 PL_in_my = tmp; 4552 s = skipspace(s); 4553 if (isIDFIRST_lazy_if(s,UTF)) { 4554 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); 4555 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3)) 4556 goto really_sub; 4557 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len); 4558 if (!PL_in_my_stash) { 4559 char tmpbuf[1024]; 4560 PL_bufptr = s; 4561 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf); 4562 yyerror(tmpbuf); 4563 } 4564 } 4565 yylval.ival = 1; 4566 OPERATOR(MY); 4567 4568 case KEY_next: 4569 s = force_word(s,WORD,TRUE,FALSE,FALSE); 4570 LOOPX(OP_NEXT); 4571 4572 case KEY_ne: 4573 Eop(OP_SNE); 4574 4575 case KEY_no: 4576 if (PL_expect != XSTATE) 4577 yyerror("\"no\" not allowed in expression"); 4578 s = force_word(s,WORD,FALSE,TRUE,FALSE); 4579 s = force_version(s); 4580 yylval.ival = 0; 4581 OPERATOR(USE); 4582 4583 case KEY_not: 4584 if (*s == '(' || (s = skipspace(s), *s == '(')) 4585 FUN1(OP_NOT); 4586 else 4587 OPERATOR(NOTOP); 4588 4589 case KEY_open: 4590 s = skipspace(s); 4591 if (isIDFIRST_lazy_if(s,UTF)) { 4592 char *t; 4593 for (d = s; isALNUM_lazy_if(d,UTF); d++) ; 4594 t = skipspace(d); 4595 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)) 4596 Perl_warner(aTHX_ WARN_PRECEDENCE, 4597 "Precedence problem: open %.*s should be open(%.*s)", 4598 d-s,s, d-s,s); 4599 } 4600 LOP(OP_OPEN,XTERM); 4601 4602 case KEY_or: 4603 yylval.ival = OP_OR; 4604 OPERATOR(OROP); 4605 4606 case KEY_ord: 4607 UNI(OP_ORD); 4608 4609 case KEY_oct: 4610 UNI(OP_OCT); 4611 4612 case KEY_opendir: 4613 LOP(OP_OPEN_DIR,XTERM); 4614 4615 case KEY_print: 4616 checkcomma(s,PL_tokenbuf,"filehandle"); 4617 LOP(OP_PRINT,XREF); 4618 4619 case KEY_printf: 4620 checkcomma(s,PL_tokenbuf,"filehandle"); 4621 LOP(OP_PRTF,XREF); 4622 4623 case KEY_prototype: 4624 UNI(OP_PROTOTYPE); 4625 4626 case KEY_push: 4627 LOP(OP_PUSH,XTERM); 4628 4629 case KEY_pop: 4630 UNI(OP_POP); 4631 4632 case KEY_pos: 4633 UNI(OP_POS); 4634 4635 case KEY_pack: 4636 LOP(OP_PACK,XTERM); 4637 4638 case KEY_package: 4639 s = force_word(s,WORD,FALSE,TRUE,FALSE); 4640 OPERATOR(PACKAGE); 4641 4642 case KEY_pipe: 4643 LOP(OP_PIPE_OP,XTERM); 4644 4645 case KEY_q: 4646 s = scan_str(s,FALSE,FALSE); 4647 if (!s) 4648 missingterm((char*)0); 4649 yylval.ival = OP_CONST; 4650 TERM(sublex_start()); 4651 4652 case KEY_quotemeta: 4653 UNI(OP_QUOTEMETA); 4654 4655 case KEY_qw: 4656 s = scan_str(s,FALSE,FALSE); 4657 if (!s) 4658 missingterm((char*)0); 4659 force_next(')'); 4660 if (SvCUR(PL_lex_stuff)) { 4661 OP *words = Nullop; 4662 int warned = 0; 4663 d = SvPV_force(PL_lex_stuff, len); 4664 while (len) { 4665 SV *sv; 4666 for (; isSPACE(*d) && len; --len, ++d) ; 4667 if (len) { 4668 char *b = d; 4669 if (!warned && ckWARN(WARN_QW)) { 4670 for (; !isSPACE(*d) && len; --len, ++d) { 4671 if (*d == ',') { 4672 Perl_warner(aTHX_ WARN_QW, 4673 "Possible attempt to separate words with commas"); 4674 ++warned; 4675 } 4676 else if (*d == '#') { 4677 Perl_warner(aTHX_ WARN_QW, 4678 "Possible attempt to put comments in qw() list"); 4679 ++warned; 4680 } 4681 } 4682 } 4683 else { 4684 for (; !isSPACE(*d) && len; --len, ++d) ; 4685 } 4686 sv = newSVpvn(b, d-b); 4687 if (DO_UTF8(PL_lex_stuff)) 4688 SvUTF8_on(sv); 4689 words = append_elem(OP_LIST, words, 4690 newSVOP(OP_CONST, 0, tokeq(sv))); 4691 } 4692 } 4693 if (words) { 4694 PL_nextval[PL_nexttoke].opval = words; 4695 force_next(THING); 4696 } 4697 } 4698 if (PL_lex_stuff) { 4699 SvREFCNT_dec(PL_lex_stuff); 4700 PL_lex_stuff = Nullsv; 4701 } 4702 PL_expect = XTERM; 4703 TOKEN('('); 4704 4705 case KEY_qq: 4706 s = scan_str(s,FALSE,FALSE); 4707 if (!s) 4708 missingterm((char*)0); 4709 yylval.ival = OP_STRINGIFY; 4710 if (SvIVX(PL_lex_stuff) == '\'') 4711 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */ 4712 TERM(sublex_start()); 4713 4714 case KEY_qr: 4715 s = scan_pat(s,OP_QR); 4716 TERM(sublex_start()); 4717 4718 case KEY_qx: 4719 s = scan_str(s,FALSE,FALSE); 4720 if (!s) 4721 missingterm((char*)0); 4722 yylval.ival = OP_BACKTICK; 4723 set_csh(); 4724 TERM(sublex_start()); 4725 4726 case KEY_return: 4727 OLDLOP(OP_RETURN); 4728 4729 case KEY_require: 4730 s = skipspace(s); 4731 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { 4732 s = force_version(s); 4733 } 4734 else { 4735 *PL_tokenbuf = '\0'; 4736 s = force_word(s,WORD,TRUE,TRUE,FALSE); 4737 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF)) 4738 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE); 4739 else if (*s == '<') 4740 yyerror("<> should be quotes"); 4741 } 4742 UNI(OP_REQUIRE); 4743 4744 case KEY_reset: 4745 UNI(OP_RESET); 4746 4747 case KEY_redo: 4748 s = force_word(s,WORD,TRUE,FALSE,FALSE); 4749 LOOPX(OP_REDO); 4750 4751 case KEY_rename: 4752 LOP(OP_RENAME,XTERM); 4753 4754 case KEY_rand: 4755 UNI(OP_RAND); 4756 4757 case KEY_rmdir: 4758 UNI(OP_RMDIR); 4759 4760 case KEY_rindex: 4761 LOP(OP_RINDEX,XTERM); 4762 4763 case KEY_read: 4764 LOP(OP_READ,XTERM); 4765 4766 case KEY_readdir: 4767 UNI(OP_READDIR); 4768 4769 case KEY_readline: 4770 set_csh(); 4771 UNI(OP_READLINE); 4772 4773 case KEY_readpipe: 4774 set_csh(); 4775 UNI(OP_BACKTICK); 4776 4777 case KEY_rewinddir: 4778 UNI(OP_REWINDDIR); 4779 4780 case KEY_recv: 4781 LOP(OP_RECV,XTERM); 4782 4783 case KEY_reverse: 4784 LOP(OP_REVERSE,XTERM); 4785 4786 case KEY_readlink: 4787 UNI(OP_READLINK); 4788 4789 case KEY_ref: 4790 UNI(OP_REF); 4791 4792 case KEY_s: 4793 s = scan_subst(s); 4794 if (yylval.opval) 4795 TERM(sublex_start()); 4796 else 4797 TOKEN(1); /* force error */ 4798 4799 case KEY_chomp: 4800 UNI(OP_CHOMP); 4801 4802 case KEY_scalar: 4803 UNI(OP_SCALAR); 4804 4805 case KEY_select: 4806 LOP(OP_SELECT,XTERM); 4807 4808 case KEY_seek: 4809 LOP(OP_SEEK,XTERM); 4810 4811 case KEY_semctl: 4812 LOP(OP_SEMCTL,XTERM); 4813 4814 case KEY_semget: 4815 LOP(OP_SEMGET,XTERM); 4816 4817 case KEY_semop: 4818 LOP(OP_SEMOP,XTERM); 4819 4820 case KEY_send: 4821 LOP(OP_SEND,XTERM); 4822 4823 case KEY_setpgrp: 4824 LOP(OP_SETPGRP,XTERM); 4825 4826 case KEY_setpriority: 4827 LOP(OP_SETPRIORITY,XTERM); 4828 4829 case KEY_sethostent: 4830 UNI(OP_SHOSTENT); 4831 4832 case KEY_setnetent: 4833 UNI(OP_SNETENT); 4834 4835 case KEY_setservent: 4836 UNI(OP_SSERVENT); 4837 4838 case KEY_setprotoent: 4839 UNI(OP_SPROTOENT); 4840 4841 case KEY_setpwent: 4842 FUN0(OP_SPWENT); 4843 4844 case KEY_setgrent: 4845 FUN0(OP_SGRENT); 4846 4847 case KEY_seekdir: 4848 LOP(OP_SEEKDIR,XTERM); 4849 4850 case KEY_setsockopt: 4851 LOP(OP_SSOCKOPT,XTERM); 4852 4853 case KEY_shift: 4854 UNI(OP_SHIFT); 4855 4856 case KEY_shmctl: 4857 LOP(OP_SHMCTL,XTERM); 4858 4859 case KEY_shmget: 4860 LOP(OP_SHMGET,XTERM); 4861 4862 case KEY_shmread: 4863 LOP(OP_SHMREAD,XTERM); 4864 4865 case KEY_shmwrite: 4866 LOP(OP_SHMWRITE,XTERM); 4867 4868 case KEY_shutdown: 4869 LOP(OP_SHUTDOWN,XTERM); 4870 4871 case KEY_sin: 4872 UNI(OP_SIN); 4873 4874 case KEY_sleep: 4875 UNI(OP_SLEEP); 4876 4877 case KEY_socket: 4878 LOP(OP_SOCKET,XTERM); 4879 4880 case KEY_socketpair: 4881 LOP(OP_SOCKPAIR,XTERM); 4882 4883 case KEY_sort: 4884 checkcomma(s,PL_tokenbuf,"subroutine name"); 4885 s = skipspace(s); 4886 if (*s == ';' || *s == ')') /* probably a close */ 4887 Perl_croak(aTHX_ "sort is now a reserved word"); 4888 PL_expect = XTERM; 4889 s = force_word(s,WORD,TRUE,TRUE,FALSE); 4890 LOP(OP_SORT,XREF); 4891 4892 case KEY_split: 4893 LOP(OP_SPLIT,XTERM); 4894 4895 case KEY_sprintf: 4896 LOP(OP_SPRINTF,XTERM); 4897 4898 case KEY_splice: 4899 LOP(OP_SPLICE,XTERM); 4900 4901 case KEY_sqrt: 4902 UNI(OP_SQRT); 4903 4904 case KEY_srand: 4905 UNI(OP_SRAND); 4906 4907 case KEY_stat: 4908 UNI(OP_STAT); 4909 4910 case KEY_study: 4911 UNI(OP_STUDY); 4912 4913 case KEY_substr: 4914 LOP(OP_SUBSTR,XTERM); 4915 4916 case KEY_format: 4917 case KEY_sub: 4918 really_sub: 4919 { 4920 char tmpbuf[sizeof PL_tokenbuf]; 4921 SSize_t tboffset; 4922 expectation attrful; 4923 bool have_name, have_proto; 4924 int key = tmp; 4925 4926 s = skipspace(s); 4927 4928 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' || 4929 (*s == ':' && s[1] == ':')) 4930 { 4931 PL_expect = XBLOCK; 4932 attrful = XATTRBLOCK; 4933 /* remember buffer pos'n for later force_word */ 4934 tboffset = s - PL_oldbufptr; 4935 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); 4936 if (strchr(tmpbuf, ':')) 4937 sv_setpv(PL_subname, tmpbuf); 4938 else { 4939 sv_setsv(PL_subname,PL_curstname); 4940 sv_catpvn(PL_subname,"::",2); 4941 sv_catpvn(PL_subname,tmpbuf,len); 4942 } 4943 s = skipspace(d); 4944 have_name = TRUE; 4945 } 4946 else { 4947 if (key == KEY_my) 4948 Perl_croak(aTHX_ "Missing name in \"my sub\""); 4949 PL_expect = XTERMBLOCK; 4950 attrful = XATTRTERM; 4951 sv_setpv(PL_subname,"?"); 4952 have_name = FALSE; 4953 } 4954 4955 if (key == KEY_format) { 4956 if (*s == '=') 4957 PL_lex_formbrack = PL_lex_brackets + 1; 4958 if (have_name) 4959 (void) force_word(PL_oldbufptr + tboffset, WORD, 4960 FALSE, TRUE, TRUE); 4961 OPERATOR(FORMAT); 4962 } 4963 4964 /* Look for a prototype */ 4965 if (*s == '(') { 4966 char *p; 4967 4968 s = scan_str(s,FALSE,FALSE); 4969 if (!s) 4970 Perl_croak(aTHX_ "Prototype not terminated"); 4971 /* strip spaces */ 4972 d = SvPVX(PL_lex_stuff); 4973 tmp = 0; 4974 for (p = d; *p; ++p) { 4975 if (!isSPACE(*p)) 4976 d[tmp++] = *p; 4977 } 4978 d[tmp] = '\0'; 4979 SvCUR(PL_lex_stuff) = tmp; 4980 have_proto = TRUE; 4981 4982 s = skipspace(s); 4983 } 4984 else 4985 have_proto = FALSE; 4986 4987 if (*s == ':' && s[1] != ':') 4988 PL_expect = attrful; 4989 4990 if (have_proto) { 4991 PL_nextval[PL_nexttoke].opval = 4992 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff); 4993 PL_lex_stuff = Nullsv; 4994 force_next(THING); 4995 } 4996 if (!have_name) { 4997 sv_setpv(PL_subname,"__ANON__"); 4998 TOKEN(ANONSUB); 4999 } 5000 (void) force_word(PL_oldbufptr + tboffset, WORD, 5001 FALSE, TRUE, TRUE); 5002 if (key == KEY_my) 5003 TOKEN(MYSUB); 5004 TOKEN(SUB); 5005 } 5006 5007 case KEY_system: 5008 set_csh(); 5009 LOP(OP_SYSTEM,XREF); 5010 5011 case KEY_symlink: 5012 LOP(OP_SYMLINK,XTERM); 5013 5014 case KEY_syscall: 5015 LOP(OP_SYSCALL,XTERM); 5016 5017 case KEY_sysopen: 5018 LOP(OP_SYSOPEN,XTERM); 5019 5020 case KEY_sysseek: 5021 LOP(OP_SYSSEEK,XTERM); 5022 5023 case KEY_sysread: 5024 LOP(OP_SYSREAD,XTERM); 5025 5026 case KEY_syswrite: 5027 LOP(OP_SYSWRITE,XTERM); 5028 5029 case KEY_tr: 5030 s = scan_trans(s); 5031 TERM(sublex_start()); 5032 5033 case KEY_tell: 5034 UNI(OP_TELL); 5035 5036 case KEY_telldir: 5037 UNI(OP_TELLDIR); 5038 5039 case KEY_tie: 5040 LOP(OP_TIE,XTERM); 5041 5042 case KEY_tied: 5043 UNI(OP_TIED); 5044 5045 case KEY_time: 5046 FUN0(OP_TIME); 5047 5048 case KEY_times: 5049 FUN0(OP_TMS); 5050 5051 case KEY_truncate: 5052 LOP(OP_TRUNCATE,XTERM); 5053 5054 case KEY_uc: 5055 UNI(OP_UC); 5056 5057 case KEY_ucfirst: 5058 UNI(OP_UCFIRST); 5059 5060 case KEY_untie: 5061 UNI(OP_UNTIE); 5062 5063 case KEY_until: 5064 yylval.ival = CopLINE(PL_curcop); 5065 OPERATOR(UNTIL); 5066 5067 case KEY_unless: 5068 yylval.ival = CopLINE(PL_curcop); 5069 OPERATOR(UNLESS); 5070 5071 case KEY_unlink: 5072 LOP(OP_UNLINK,XTERM); 5073 5074 case KEY_undef: 5075 UNI(OP_UNDEF); 5076 5077 case KEY_unpack: 5078 LOP(OP_UNPACK,XTERM); 5079 5080 case KEY_utime: 5081 LOP(OP_UTIME,XTERM); 5082 5083 case KEY_umask: 5084 if (ckWARN(WARN_UMASK)) { 5085 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ; 5086 if (*d != '0' && isDIGIT(*d)) 5087 Perl_warner(aTHX_ WARN_UMASK, 5088 "umask: argument is missing initial 0"); 5089 } 5090 UNI(OP_UMASK); 5091 5092 case KEY_unshift: 5093 LOP(OP_UNSHIFT,XTERM); 5094 5095 case KEY_use: 5096 if (PL_expect != XSTATE) 5097 yyerror("\"use\" not allowed in expression"); 5098 s = skipspace(s); 5099 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { 5100 s = force_version(s); 5101 if (*s == ';' || (s = skipspace(s), *s == ';')) { 5102 PL_nextval[PL_nexttoke].opval = Nullop; 5103 force_next(WORD); 5104 } 5105 } 5106 else { 5107 s = force_word(s,WORD,FALSE,TRUE,FALSE); 5108 s = force_version(s); 5109 } 5110 yylval.ival = 1; 5111 OPERATOR(USE); 5112 5113 case KEY_values: 5114 UNI(OP_VALUES); 5115 5116 case KEY_vec: 5117 LOP(OP_VEC,XTERM); 5118 5119 case KEY_while: 5120 yylval.ival = CopLINE(PL_curcop); 5121 OPERATOR(WHILE); 5122 5123 case KEY_warn: 5124 PL_hints |= HINT_BLOCK_SCOPE; 5125 LOP(OP_WARN,XTERM); 5126 5127 case KEY_wait: 5128 FUN0(OP_WAIT); 5129 5130 case KEY_waitpid: 5131 LOP(OP_WAITPID,XTERM); 5132 5133 case KEY_wantarray: 5134 FUN0(OP_WANTARRAY); 5135 5136 case KEY_write: 5137 #ifdef EBCDIC 5138 { 5139 static char ctl_l[2]; 5140 5141 if (ctl_l[0] == '\0') 5142 ctl_l[0] = toCTRL('L'); 5143 gv_fetchpv(ctl_l,TRUE, SVt_PV); 5144 } 5145 #else 5146 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */ 5147 #endif 5148 UNI(OP_ENTERWRITE); 5149 5150 case KEY_x: 5151 if (PL_expect == XOPERATOR) 5152 Mop(OP_REPEAT); 5153 check_uni(); 5154 goto just_a_word; 5155 5156 case KEY_xor: 5157 yylval.ival = OP_XOR; 5158 OPERATOR(OROP); 5159 5160 case KEY_y: 5161 s = scan_trans(s); 5162 TERM(sublex_start()); 5163 } 5164 }} 5165 } 5166 #ifdef __SC__ 5167 #pragma segment Main 5168 #endif 5169 5170 I32 5171 Perl_keyword(pTHX_ register char *d, I32 len) 5172 { 5173 switch (*d) { 5174 case '_': 5175 if (d[1] == '_') { 5176 if (strEQ(d,"__FILE__")) return -KEY___FILE__; 5177 if (strEQ(d,"__LINE__")) return -KEY___LINE__; 5178 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__; 5179 if (strEQ(d,"__DATA__")) return KEY___DATA__; 5180 if (strEQ(d,"__END__")) return KEY___END__; 5181 } 5182 break; 5183 case 'A': 5184 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD; 5185 break; 5186 case 'a': 5187 switch (len) { 5188 case 3: 5189 if (strEQ(d,"and")) return -KEY_and; 5190 if (strEQ(d,"abs")) return -KEY_abs; 5191 break; 5192 case 5: 5193 if (strEQ(d,"alarm")) return -KEY_alarm; 5194 if (strEQ(d,"atan2")) return -KEY_atan2; 5195 break; 5196 case 6: 5197 if (strEQ(d,"accept")) return -KEY_accept; 5198 break; 5199 } 5200 break; 5201 case 'B': 5202 if (strEQ(d,"BEGIN")) return KEY_BEGIN; 5203 break; 5204 case 'b': 5205 if (strEQ(d,"bless")) return -KEY_bless; 5206 if (strEQ(d,"bind")) return -KEY_bind; 5207 if (strEQ(d,"binmode")) return -KEY_binmode; 5208 break; 5209 case 'C': 5210 if (strEQ(d,"CORE")) return -KEY_CORE; 5211 if (strEQ(d,"CHECK")) return KEY_CHECK; 5212 break; 5213 case 'c': 5214 switch (len) { 5215 case 3: 5216 if (strEQ(d,"cmp")) return -KEY_cmp; 5217 if (strEQ(d,"chr")) return -KEY_chr; 5218 if (strEQ(d,"cos")) return -KEY_cos; 5219 break; 5220 case 4: 5221 if (strEQ(d,"chop")) return -KEY_chop; 5222 break; 5223 case 5: 5224 if (strEQ(d,"close")) return -KEY_close; 5225 if (strEQ(d,"chdir")) return -KEY_chdir; 5226 if (strEQ(d,"chomp")) return -KEY_chomp; 5227 if (strEQ(d,"chmod")) return -KEY_chmod; 5228 if (strEQ(d,"chown")) return -KEY_chown; 5229 if (strEQ(d,"crypt")) return -KEY_crypt; 5230 break; 5231 case 6: 5232 if (strEQ(d,"chroot")) return -KEY_chroot; 5233 if (strEQ(d,"caller")) return -KEY_caller; 5234 break; 5235 case 7: 5236 if (strEQ(d,"connect")) return -KEY_connect; 5237 break; 5238 case 8: 5239 if (strEQ(d,"closedir")) return -KEY_closedir; 5240 if (strEQ(d,"continue")) return -KEY_continue; 5241 break; 5242 } 5243 break; 5244 case 'D': 5245 if (strEQ(d,"DESTROY")) return KEY_DESTROY; 5246 break; 5247 case 'd': 5248 switch (len) { 5249 case 2: 5250 if (strEQ(d,"do")) return KEY_do; 5251 break; 5252 case 3: 5253 if (strEQ(d,"die")) return -KEY_die; 5254 break; 5255 case 4: 5256 if (strEQ(d,"dump")) return -KEY_dump; 5257 break; 5258 case 6: 5259 if (strEQ(d,"delete")) return KEY_delete; 5260 break; 5261 case 7: 5262 if (strEQ(d,"defined")) return KEY_defined; 5263 if (strEQ(d,"dbmopen")) return -KEY_dbmopen; 5264 break; 5265 case 8: 5266 if (strEQ(d,"dbmclose")) return -KEY_dbmclose; 5267 break; 5268 } 5269 break; 5270 case 'E': 5271 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;} 5272 if (strEQ(d,"END")) return KEY_END; 5273 break; 5274 case 'e': 5275 switch (len) { 5276 case 2: 5277 if (strEQ(d,"eq")) return -KEY_eq; 5278 break; 5279 case 3: 5280 if (strEQ(d,"eof")) return -KEY_eof; 5281 if (strEQ(d,"exp")) return -KEY_exp; 5282 break; 5283 case 4: 5284 if (strEQ(d,"else")) return KEY_else; 5285 if (strEQ(d,"exit")) return -KEY_exit; 5286 if (strEQ(d,"eval")) return KEY_eval; 5287 if (strEQ(d,"exec")) return -KEY_exec; 5288 if (strEQ(d,"each")) return -KEY_each; 5289 break; 5290 case 5: 5291 if (strEQ(d,"elsif")) return KEY_elsif; 5292 break; 5293 case 6: 5294 if (strEQ(d,"exists")) return KEY_exists; 5295 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif"); 5296 break; 5297 case 8: 5298 if (strEQ(d,"endgrent")) return -KEY_endgrent; 5299 if (strEQ(d,"endpwent")) return -KEY_endpwent; 5300 break; 5301 case 9: 5302 if (strEQ(d,"endnetent")) return -KEY_endnetent; 5303 break; 5304 case 10: 5305 if (strEQ(d,"endhostent")) return -KEY_endhostent; 5306 if (strEQ(d,"endservent")) return -KEY_endservent; 5307 break; 5308 case 11: 5309 if (strEQ(d,"endprotoent")) return -KEY_endprotoent; 5310 break; 5311 } 5312 break; 5313 case 'f': 5314 switch (len) { 5315 case 3: 5316 if (strEQ(d,"for")) return KEY_for; 5317 break; 5318 case 4: 5319 if (strEQ(d,"fork")) return -KEY_fork; 5320 break; 5321 case 5: 5322 if (strEQ(d,"fcntl")) return -KEY_fcntl; 5323 if (strEQ(d,"flock")) return -KEY_flock; 5324 break; 5325 case 6: 5326 if (strEQ(d,"format")) return KEY_format; 5327 if (strEQ(d,"fileno")) return -KEY_fileno; 5328 break; 5329 case 7: 5330 if (strEQ(d,"foreach")) return KEY_foreach; 5331 break; 5332 case 8: 5333 if (strEQ(d,"formline")) return -KEY_formline; 5334 break; 5335 } 5336 break; 5337 case 'G': 5338 if (len == 2) { 5339 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;} 5340 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;} 5341 } 5342 break; 5343 case 'g': 5344 if (strnEQ(d,"get",3)) { 5345 d += 3; 5346 if (*d == 'p') { 5347 switch (len) { 5348 case 7: 5349 if (strEQ(d,"ppid")) return -KEY_getppid; 5350 if (strEQ(d,"pgrp")) return -KEY_getpgrp; 5351 break; 5352 case 8: 5353 if (strEQ(d,"pwent")) return -KEY_getpwent; 5354 if (strEQ(d,"pwnam")) return -KEY_getpwnam; 5355 if (strEQ(d,"pwuid")) return -KEY_getpwuid; 5356 break; 5357 case 11: 5358 if (strEQ(d,"peername")) return -KEY_getpeername; 5359 if (strEQ(d,"protoent")) return -KEY_getprotoent; 5360 if (strEQ(d,"priority")) return -KEY_getpriority; 5361 break; 5362 case 14: 5363 if (strEQ(d,"protobyname")) return -KEY_getprotobyname; 5364 break; 5365 case 16: 5366 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber; 5367 break; 5368 } 5369 } 5370 else if (*d == 'h') { 5371 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname; 5372 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr; 5373 if (strEQ(d,"hostent")) return -KEY_gethostent; 5374 } 5375 else if (*d == 'n') { 5376 if (strEQ(d,"netbyname")) return -KEY_getnetbyname; 5377 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr; 5378 if (strEQ(d,"netent")) return -KEY_getnetent; 5379 } 5380 else if (*d == 's') { 5381 if (strEQ(d,"servbyname")) return -KEY_getservbyname; 5382 if (strEQ(d,"servbyport")) return -KEY_getservbyport; 5383 if (strEQ(d,"servent")) return -KEY_getservent; 5384 if (strEQ(d,"sockname")) return -KEY_getsockname; 5385 if (strEQ(d,"sockopt")) return -KEY_getsockopt; 5386 } 5387 else if (*d == 'g') { 5388 if (strEQ(d,"grent")) return -KEY_getgrent; 5389 if (strEQ(d,"grnam")) return -KEY_getgrnam; 5390 if (strEQ(d,"grgid")) return -KEY_getgrgid; 5391 } 5392 else if (*d == 'l') { 5393 if (strEQ(d,"login")) return -KEY_getlogin; 5394 } 5395 else if (strEQ(d,"c")) return -KEY_getc; 5396 break; 5397 } 5398 switch (len) { 5399 case 2: 5400 if (strEQ(d,"gt")) return -KEY_gt; 5401 if (strEQ(d,"ge")) return -KEY_ge; 5402 break; 5403 case 4: 5404 if (strEQ(d,"grep")) return KEY_grep; 5405 if (strEQ(d,"goto")) return KEY_goto; 5406 if (strEQ(d,"glob")) return KEY_glob; 5407 break; 5408 case 6: 5409 if (strEQ(d,"gmtime")) return -KEY_gmtime; 5410 break; 5411 } 5412 break; 5413 case 'h': 5414 if (strEQ(d,"hex")) return -KEY_hex; 5415 break; 5416 case 'I': 5417 if (strEQ(d,"INIT")) return KEY_INIT; 5418 break; 5419 case 'i': 5420 switch (len) { 5421 case 2: 5422 if (strEQ(d,"if")) return KEY_if; 5423 break; 5424 case 3: 5425 if (strEQ(d,"int")) return -KEY_int; 5426 break; 5427 case 5: 5428 if (strEQ(d,"index")) return -KEY_index; 5429 if (strEQ(d,"ioctl")) return -KEY_ioctl; 5430 break; 5431 } 5432 break; 5433 case 'j': 5434 if (strEQ(d,"join")) return -KEY_join; 5435 break; 5436 case 'k': 5437 if (len == 4) { 5438 if (strEQ(d,"keys")) return -KEY_keys; 5439 if (strEQ(d,"kill")) return -KEY_kill; 5440 } 5441 break; 5442 case 'L': 5443 if (len == 2) { 5444 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;} 5445 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;} 5446 } 5447 break; 5448 case 'l': 5449 switch (len) { 5450 case 2: 5451 if (strEQ(d,"lt")) return -KEY_lt; 5452 if (strEQ(d,"le")) return -KEY_le; 5453 if (strEQ(d,"lc")) return -KEY_lc; 5454 break; 5455 case 3: 5456 if (strEQ(d,"log")) return -KEY_log; 5457 break; 5458 case 4: 5459 if (strEQ(d,"last")) return KEY_last; 5460 if (strEQ(d,"link")) return -KEY_link; 5461 if (strEQ(d,"lock")) return -KEY_lock; 5462 break; 5463 case 5: 5464 if (strEQ(d,"local")) return KEY_local; 5465 if (strEQ(d,"lstat")) return -KEY_lstat; 5466 break; 5467 case 6: 5468 if (strEQ(d,"length")) return -KEY_length; 5469 if (strEQ(d,"listen")) return -KEY_listen; 5470 break; 5471 case 7: 5472 if (strEQ(d,"lcfirst")) return -KEY_lcfirst; 5473 break; 5474 case 9: 5475 if (strEQ(d,"localtime")) return -KEY_localtime; 5476 break; 5477 } 5478 break; 5479 case 'm': 5480 switch (len) { 5481 case 1: return KEY_m; 5482 case 2: 5483 if (strEQ(d,"my")) return KEY_my; 5484 break; 5485 case 3: 5486 if (strEQ(d,"map")) return KEY_map; 5487 break; 5488 case 5: 5489 if (strEQ(d,"mkdir")) return -KEY_mkdir; 5490 break; 5491 case 6: 5492 if (strEQ(d,"msgctl")) return -KEY_msgctl; 5493 if (strEQ(d,"msgget")) return -KEY_msgget; 5494 if (strEQ(d,"msgrcv")) return -KEY_msgrcv; 5495 if (strEQ(d,"msgsnd")) return -KEY_msgsnd; 5496 break; 5497 } 5498 break; 5499 case 'N': 5500 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;} 5501 break; 5502 case 'n': 5503 if (strEQ(d,"next")) return KEY_next; 5504 if (strEQ(d,"ne")) return -KEY_ne; 5505 if (strEQ(d,"not")) return -KEY_not; 5506 if (strEQ(d,"no")) return KEY_no; 5507 break; 5508 case 'o': 5509 switch (len) { 5510 case 2: 5511 if (strEQ(d,"or")) return -KEY_or; 5512 break; 5513 case 3: 5514 if (strEQ(d,"ord")) return -KEY_ord; 5515 if (strEQ(d,"oct")) return -KEY_oct; 5516 if (strEQ(d,"our")) return KEY_our; 5517 break; 5518 case 4: 5519 if (strEQ(d,"open")) return -KEY_open; 5520 break; 5521 case 7: 5522 if (strEQ(d,"opendir")) return -KEY_opendir; 5523 break; 5524 } 5525 break; 5526 case 'p': 5527 switch (len) { 5528 case 3: 5529 if (strEQ(d,"pop")) return -KEY_pop; 5530 if (strEQ(d,"pos")) return KEY_pos; 5531 break; 5532 case 4: 5533 if (strEQ(d,"push")) return -KEY_push; 5534 if (strEQ(d,"pack")) return -KEY_pack; 5535 if (strEQ(d,"pipe")) return -KEY_pipe; 5536 break; 5537 case 5: 5538 if (strEQ(d,"print")) return KEY_print; 5539 break; 5540 case 6: 5541 if (strEQ(d,"printf")) return KEY_printf; 5542 break; 5543 case 7: 5544 if (strEQ(d,"package")) return KEY_package; 5545 break; 5546 case 9: 5547 if (strEQ(d,"prototype")) return KEY_prototype; 5548 } 5549 break; 5550 case 'q': 5551 if (len <= 2) { 5552 if (strEQ(d,"q")) return KEY_q; 5553 if (strEQ(d,"qr")) return KEY_qr; 5554 if (strEQ(d,"qq")) return KEY_qq; 5555 if (strEQ(d,"qw")) return KEY_qw; 5556 if (strEQ(d,"qx")) return KEY_qx; 5557 } 5558 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta; 5559 break; 5560 case 'r': 5561 switch (len) { 5562 case 3: 5563 if (strEQ(d,"ref")) return -KEY_ref; 5564 break; 5565 case 4: 5566 if (strEQ(d,"read")) return -KEY_read; 5567 if (strEQ(d,"rand")) return -KEY_rand; 5568 if (strEQ(d,"recv")) return -KEY_recv; 5569 if (strEQ(d,"redo")) return KEY_redo; 5570 break; 5571 case 5: 5572 if (strEQ(d,"rmdir")) return -KEY_rmdir; 5573 if (strEQ(d,"reset")) return -KEY_reset; 5574 break; 5575 case 6: 5576 if (strEQ(d,"return")) return KEY_return; 5577 if (strEQ(d,"rename")) return -KEY_rename; 5578 if (strEQ(d,"rindex")) return -KEY_rindex; 5579 break; 5580 case 7: 5581 if (strEQ(d,"require")) return -KEY_require; 5582 if (strEQ(d,"reverse")) return -KEY_reverse; 5583 if (strEQ(d,"readdir")) return -KEY_readdir; 5584 break; 5585 case 8: 5586 if (strEQ(d,"readlink")) return -KEY_readlink; 5587 if (strEQ(d,"readline")) return -KEY_readline; 5588 if (strEQ(d,"readpipe")) return -KEY_readpipe; 5589 break; 5590 case 9: 5591 if (strEQ(d,"rewinddir")) return -KEY_rewinddir; 5592 break; 5593 } 5594 break; 5595 case 's': 5596 switch (d[1]) { 5597 case 0: return KEY_s; 5598 case 'c': 5599 if (strEQ(d,"scalar")) return KEY_scalar; 5600 break; 5601 case 'e': 5602 switch (len) { 5603 case 4: 5604 if (strEQ(d,"seek")) return -KEY_seek; 5605 if (strEQ(d,"send")) return -KEY_send; 5606 break; 5607 case 5: 5608 if (strEQ(d,"semop")) return -KEY_semop; 5609 break; 5610 case 6: 5611 if (strEQ(d,"select")) return -KEY_select; 5612 if (strEQ(d,"semctl")) return -KEY_semctl; 5613 if (strEQ(d,"semget")) return -KEY_semget; 5614 break; 5615 case 7: 5616 if (strEQ(d,"setpgrp")) return -KEY_setpgrp; 5617 if (strEQ(d,"seekdir")) return -KEY_seekdir; 5618 break; 5619 case 8: 5620 if (strEQ(d,"setpwent")) return -KEY_setpwent; 5621 if (strEQ(d,"setgrent")) return -KEY_setgrent; 5622 break; 5623 case 9: 5624 if (strEQ(d,"setnetent")) return -KEY_setnetent; 5625 break; 5626 case 10: 5627 if (strEQ(d,"setsockopt")) return -KEY_setsockopt; 5628 if (strEQ(d,"sethostent")) return -KEY_sethostent; 5629 if (strEQ(d,"setservent")) return -KEY_setservent; 5630 break; 5631 case 11: 5632 if (strEQ(d,"setpriority")) return -KEY_setpriority; 5633 if (strEQ(d,"setprotoent")) return -KEY_setprotoent; 5634 break; 5635 } 5636 break; 5637 case 'h': 5638 switch (len) { 5639 case 5: 5640 if (strEQ(d,"shift")) return -KEY_shift; 5641 break; 5642 case 6: 5643 if (strEQ(d,"shmctl")) return -KEY_shmctl; 5644 if (strEQ(d,"shmget")) return -KEY_shmget; 5645 break; 5646 case 7: 5647 if (strEQ(d,"shmread")) return -KEY_shmread; 5648 break; 5649 case 8: 5650 if (strEQ(d,"shmwrite")) return -KEY_shmwrite; 5651 if (strEQ(d,"shutdown")) return -KEY_shutdown; 5652 break; 5653 } 5654 break; 5655 case 'i': 5656 if (strEQ(d,"sin")) return -KEY_sin; 5657 break; 5658 case 'l': 5659 if (strEQ(d,"sleep")) return -KEY_sleep; 5660 break; 5661 case 'o': 5662 if (strEQ(d,"sort")) return KEY_sort; 5663 if (strEQ(d,"socket")) return -KEY_socket; 5664 if (strEQ(d,"socketpair")) return -KEY_socketpair; 5665 break; 5666 case 'p': 5667 if (strEQ(d,"split")) return KEY_split; 5668 if (strEQ(d,"sprintf")) return -KEY_sprintf; 5669 if (strEQ(d,"splice")) return -KEY_splice; 5670 break; 5671 case 'q': 5672 if (strEQ(d,"sqrt")) return -KEY_sqrt; 5673 break; 5674 case 'r': 5675 if (strEQ(d,"srand")) return -KEY_srand; 5676 break; 5677 case 't': 5678 if (strEQ(d,"stat")) return -KEY_stat; 5679 if (strEQ(d,"study")) return KEY_study; 5680 break; 5681 case 'u': 5682 if (strEQ(d,"substr")) return -KEY_substr; 5683 if (strEQ(d,"sub")) return KEY_sub; 5684 break; 5685 case 'y': 5686 switch (len) { 5687 case 6: 5688 if (strEQ(d,"system")) return -KEY_system; 5689 break; 5690 case 7: 5691 if (strEQ(d,"symlink")) return -KEY_symlink; 5692 if (strEQ(d,"syscall")) return -KEY_syscall; 5693 if (strEQ(d,"sysopen")) return -KEY_sysopen; 5694 if (strEQ(d,"sysread")) return -KEY_sysread; 5695 if (strEQ(d,"sysseek")) return -KEY_sysseek; 5696 break; 5697 case 8: 5698 if (strEQ(d,"syswrite")) return -KEY_syswrite; 5699 break; 5700 } 5701 break; 5702 } 5703 break; 5704 case 't': 5705 switch (len) { 5706 case 2: 5707 if (strEQ(d,"tr")) return KEY_tr; 5708 break; 5709 case 3: 5710 if (strEQ(d,"tie")) return KEY_tie; 5711 break; 5712 case 4: 5713 if (strEQ(d,"tell")) return -KEY_tell; 5714 if (strEQ(d,"tied")) return KEY_tied; 5715 if (strEQ(d,"time")) return -KEY_time; 5716 break; 5717 case 5: 5718 if (strEQ(d,"times")) return -KEY_times; 5719 break; 5720 case 7: 5721 if (strEQ(d,"telldir")) return -KEY_telldir; 5722 break; 5723 case 8: 5724 if (strEQ(d,"truncate")) return -KEY_truncate; 5725 break; 5726 } 5727 break; 5728 case 'u': 5729 switch (len) { 5730 case 2: 5731 if (strEQ(d,"uc")) return -KEY_uc; 5732 break; 5733 case 3: 5734 if (strEQ(d,"use")) return KEY_use; 5735 break; 5736 case 5: 5737 if (strEQ(d,"undef")) return KEY_undef; 5738 if (strEQ(d,"until")) return KEY_until; 5739 if (strEQ(d,"untie")) return KEY_untie; 5740 if (strEQ(d,"utime")) return -KEY_utime; 5741 if (strEQ(d,"umask")) return -KEY_umask; 5742 break; 5743 case 6: 5744 if (strEQ(d,"unless")) return KEY_unless; 5745 if (strEQ(d,"unpack")) return -KEY_unpack; 5746 if (strEQ(d,"unlink")) return -KEY_unlink; 5747 break; 5748 case 7: 5749 if (strEQ(d,"unshift")) return -KEY_unshift; 5750 if (strEQ(d,"ucfirst")) return -KEY_ucfirst; 5751 break; 5752 } 5753 break; 5754 case 'v': 5755 if (strEQ(d,"values")) return -KEY_values; 5756 if (strEQ(d,"vec")) return -KEY_vec; 5757 break; 5758 case 'w': 5759 switch (len) { 5760 case 4: 5761 if (strEQ(d,"warn")) return -KEY_warn; 5762 if (strEQ(d,"wait")) return -KEY_wait; 5763 break; 5764 case 5: 5765 if (strEQ(d,"while")) return KEY_while; 5766 if (strEQ(d,"write")) return -KEY_write; 5767 break; 5768 case 7: 5769 if (strEQ(d,"waitpid")) return -KEY_waitpid; 5770 break; 5771 case 9: 5772 if (strEQ(d,"wantarray")) return -KEY_wantarray; 5773 break; 5774 } 5775 break; 5776 case 'x': 5777 if (len == 1) return -KEY_x; 5778 if (strEQ(d,"xor")) return -KEY_xor; 5779 break; 5780 case 'y': 5781 if (len == 1) return KEY_y; 5782 break; 5783 case 'z': 5784 break; 5785 } 5786 return 0; 5787 } 5788 5789 STATIC void 5790 S_checkcomma(pTHX_ register char *s, char *name, char *what) 5791 { 5792 char *w; 5793 5794 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ 5795 if (ckWARN(WARN_SYNTAX)) { 5796 int level = 1; 5797 for (w = s+2; *w && level; w++) { 5798 if (*w == '(') 5799 ++level; 5800 else if (*w == ')') 5801 --level; 5802 } 5803 if (*w) 5804 for (; *w && isSPACE(*w); w++) ; 5805 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */ 5806 Perl_warner(aTHX_ WARN_SYNTAX, 5807 "%s (...) interpreted as function",name); 5808 } 5809 } 5810 while (s < PL_bufend && isSPACE(*s)) 5811 s++; 5812 if (*s == '(') 5813 s++; 5814 while (s < PL_bufend && isSPACE(*s)) 5815 s++; 5816 if (isIDFIRST_lazy_if(s,UTF)) { 5817 w = s++; 5818 while (isALNUM_lazy_if(s,UTF)) 5819 s++; 5820 while (s < PL_bufend && isSPACE(*s)) 5821 s++; 5822 if (*s == ',') { 5823 int kw; 5824 *s = '\0'; 5825 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0; 5826 *s = ','; 5827 if (kw) 5828 return; 5829 Perl_croak(aTHX_ "No comma allowed after %s", what); 5830 } 5831 } 5832 } 5833 5834 /* Either returns sv, or mortalizes sv and returns a new SV*. 5835 Best used as sv=new_constant(..., sv, ...). 5836 If s, pv are NULL, calls subroutine with one argument, 5837 and type is used with error messages only. */ 5838 5839 STATIC SV * 5840 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, 5841 const char *type) 5842 { 5843 dSP; 5844 HV *table = GvHV(PL_hintgv); /* ^H */ 5845 SV *res; 5846 SV **cvp; 5847 SV *cv, *typesv; 5848 const char *why1, *why2, *why3; 5849 5850 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { 5851 SV *msg; 5852 5853 why2 = strEQ(key,"charnames") 5854 ? "(possibly a missing \"use charnames ...\")" 5855 : ""; 5856 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s", 5857 (type ? type: "undef"), why2); 5858 5859 /* This is convoluted and evil ("goto considered harmful") 5860 * but I do not understand the intricacies of all the different 5861 * failure modes of %^H in here. The goal here is to make 5862 * the most probable error message user-friendly. --jhi */ 5863 5864 goto msgdone; 5865 5866 report: 5867 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s", 5868 (type ? type: "undef"), why1, why2, why3); 5869 msgdone: 5870 yyerror(SvPVX(msg)); 5871 SvREFCNT_dec(msg); 5872 return sv; 5873 } 5874 cvp = hv_fetch(table, key, strlen(key), FALSE); 5875 if (!cvp || !SvOK(*cvp)) { 5876 why1 = "$^H{"; 5877 why2 = key; 5878 why3 = "} is not defined"; 5879 goto report; 5880 } 5881 sv_2mortal(sv); /* Parent created it permanently */ 5882 cv = *cvp; 5883 if (!pv && s) 5884 pv = sv_2mortal(newSVpvn(s, len)); 5885 if (type && pv) 5886 typesv = sv_2mortal(newSVpv(type, 0)); 5887 else 5888 typesv = &PL_sv_undef; 5889 5890 PUSHSTACKi(PERLSI_OVERLOAD); 5891 ENTER ; 5892 SAVETMPS; 5893 5894 PUSHMARK(SP) ; 5895 EXTEND(sp, 3); 5896 if (pv) 5897 PUSHs(pv); 5898 PUSHs(sv); 5899 if (pv) 5900 PUSHs(typesv); 5901 PUTBACK; 5902 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL)); 5903 5904 SPAGAIN ; 5905 5906 /* Check the eval first */ 5907 if (!PL_in_eval && SvTRUE(ERRSV)) { 5908 STRLEN n_a; 5909 sv_catpv(ERRSV, "Propagated"); 5910 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */ 5911 (void)POPs; 5912 res = SvREFCNT_inc(sv); 5913 } 5914 else { 5915 res = POPs; 5916 (void)SvREFCNT_inc(res); 5917 } 5918 5919 PUTBACK ; 5920 FREETMPS ; 5921 LEAVE ; 5922 POPSTACK; 5923 5924 if (!SvOK(res)) { 5925 why1 = "Call to &{$^H{"; 5926 why2 = key; 5927 why3 = "}} did not return a defined value"; 5928 sv = res; 5929 goto report; 5930 } 5931 5932 return res; 5933 } 5934 5935 STATIC char * 5936 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) 5937 { 5938 register char *d = dest; 5939 register char *e = d + destlen - 3; /* two-character token, ending NUL */ 5940 for (;;) { 5941 if (d >= e) 5942 Perl_croak(aTHX_ ident_too_long); 5943 if (isALNUM(*s)) /* UTF handled below */ 5944 *d++ = *s++; 5945 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) { 5946 *d++ = ':'; 5947 *d++ = ':'; 5948 s++; 5949 } 5950 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') { 5951 *d++ = *s++; 5952 *d++ = *s++; 5953 } 5954 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { 5955 char *t = s + UTF8SKIP(s); 5956 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t)) 5957 t += UTF8SKIP(t); 5958 if (d + (t - s) > e) 5959 Perl_croak(aTHX_ ident_too_long); 5960 Copy(s, d, t - s, char); 5961 d += t - s; 5962 s = t; 5963 } 5964 else { 5965 *d = '\0'; 5966 *slp = d - dest; 5967 return s; 5968 } 5969 } 5970 } 5971 5972 STATIC char * 5973 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni) 5974 { 5975 register char *d; 5976 register char *e; 5977 char *bracket = 0; 5978 char funny = *s++; 5979 5980 if (isSPACE(*s)) 5981 s = skipspace(s); 5982 d = dest; 5983 e = d + destlen - 3; /* two-character token, ending NUL */ 5984 if (isDIGIT(*s)) { 5985 while (isDIGIT(*s)) { 5986 if (d >= e) 5987 Perl_croak(aTHX_ ident_too_long); 5988 *d++ = *s++; 5989 } 5990 } 5991 else { 5992 for (;;) { 5993 if (d >= e) 5994 Perl_croak(aTHX_ ident_too_long); 5995 if (isALNUM(*s)) /* UTF handled below */ 5996 *d++ = *s++; 5997 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) { 5998 *d++ = ':'; 5999 *d++ = ':'; 6000 s++; 6001 } 6002 else if (*s == ':' && s[1] == ':') { 6003 *d++ = *s++; 6004 *d++ = *s++; 6005 } 6006 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { 6007 char *t = s + UTF8SKIP(s); 6008 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t)) 6009 t += UTF8SKIP(t); 6010 if (d + (t - s) > e) 6011 Perl_croak(aTHX_ ident_too_long); 6012 Copy(s, d, t - s, char); 6013 d += t - s; 6014 s = t; 6015 } 6016 else 6017 break; 6018 } 6019 } 6020 *d = '\0'; 6021 d = dest; 6022 if (*d) { 6023 if (PL_lex_state != LEX_NORMAL) 6024 PL_lex_state = LEX_INTERPENDMAYBE; 6025 return s; 6026 } 6027 if (*s == '$' && s[1] && 6028 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) ) 6029 { 6030 return s; 6031 } 6032 if (*s == '{') { 6033 bracket = s; 6034 s++; 6035 } 6036 else if (ck_uni) 6037 check_uni(); 6038 if (s < send) 6039 *d = *s++; 6040 d[1] = '\0'; 6041 if (*d == '^' && *s && isCONTROLVAR(*s)) { 6042 *d = toCTRL(*s); 6043 s++; 6044 } 6045 if (bracket) { 6046 if (isSPACE(s[-1])) { 6047 while (s < send) { 6048 char ch = *s++; 6049 if (!SPACE_OR_TAB(ch)) { 6050 *d = ch; 6051 break; 6052 } 6053 } 6054 } 6055 if (isIDFIRST_lazy_if(d,UTF)) { 6056 d++; 6057 if (UTF) { 6058 e = s; 6059 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') { 6060 e += UTF8SKIP(e); 6061 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e)) 6062 e += UTF8SKIP(e); 6063 } 6064 Copy(s, d, e - s, char); 6065 d += e - s; 6066 s = e; 6067 } 6068 else { 6069 while ((isALNUM(*s) || *s == ':') && d < e) 6070 *d++ = *s++; 6071 if (d >= e) 6072 Perl_croak(aTHX_ ident_too_long); 6073 } 6074 *d = '\0'; 6075 while (s < send && SPACE_OR_TAB(*s)) s++; 6076 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { 6077 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) { 6078 const char *brack = *s == '[' ? "[...]" : "{...}"; 6079 Perl_warner(aTHX_ WARN_AMBIGUOUS, 6080 "Ambiguous use of %c{%s%s} resolved to %c%s%s", 6081 funny, dest, brack, funny, dest, brack); 6082 } 6083 bracket++; 6084 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK); 6085 return s; 6086 } 6087 } 6088 /* Handle extended ${^Foo} variables 6089 * 1999-02-27 mjd-perl-patch@plover.com */ 6090 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */ 6091 && isALNUM(*s)) 6092 { 6093 d++; 6094 while (isALNUM(*s) && d < e) { 6095 *d++ = *s++; 6096 } 6097 if (d >= e) 6098 Perl_croak(aTHX_ ident_too_long); 6099 *d = '\0'; 6100 } 6101 if (*s == '}') { 6102 s++; 6103 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) 6104 PL_lex_state = LEX_INTERPEND; 6105 if (funny == '#') 6106 funny = '@'; 6107 if (PL_lex_state == LEX_NORMAL) { 6108 if (ckWARN(WARN_AMBIGUOUS) && 6109 (keyword(dest, d - dest) || get_cv(dest, FALSE))) 6110 { 6111 Perl_warner(aTHX_ WARN_AMBIGUOUS, 6112 "Ambiguous use of %c{%s} resolved to %c%s", 6113 funny, dest, funny, dest); 6114 } 6115 } 6116 } 6117 else { 6118 s = bracket; /* let the parser handle it */ 6119 *dest = '\0'; 6120 } 6121 } 6122 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s)) 6123 PL_lex_state = LEX_INTERPEND; 6124 return s; 6125 } 6126 6127 void 6128 Perl_pmflag(pTHX_ U16 *pmfl, int ch) 6129 { 6130 if (ch == 'i') 6131 *pmfl |= PMf_FOLD; 6132 else if (ch == 'g') 6133 *pmfl |= PMf_GLOBAL; 6134 else if (ch == 'c') 6135 *pmfl |= PMf_CONTINUE; 6136 else if (ch == 'o') 6137 *pmfl |= PMf_KEEP; 6138 else if (ch == 'm') 6139 *pmfl |= PMf_MULTILINE; 6140 else if (ch == 's') 6141 *pmfl |= PMf_SINGLELINE; 6142 else if (ch == 'x') 6143 *pmfl |= PMf_EXTENDED; 6144 } 6145 6146 STATIC char * 6147 S_scan_pat(pTHX_ char *start, I32 type) 6148 { 6149 PMOP *pm; 6150 char *s; 6151 6152 s = scan_str(start,FALSE,FALSE); 6153 if (!s) 6154 Perl_croak(aTHX_ "Search pattern not terminated"); 6155 6156 pm = (PMOP*)newPMOP(type, 0); 6157 if (PL_multi_open == '?') 6158 pm->op_pmflags |= PMf_ONCE; 6159 if(type == OP_QR) { 6160 while (*s && strchr("iomsx", *s)) 6161 pmflag(&pm->op_pmflags,*s++); 6162 } 6163 else { 6164 while (*s && strchr("iogcmsx", *s)) 6165 pmflag(&pm->op_pmflags,*s++); 6166 } 6167 pm->op_pmpermflags = pm->op_pmflags; 6168 6169 PL_lex_op = (OP*)pm; 6170 yylval.ival = OP_MATCH; 6171 return s; 6172 } 6173 6174 STATIC char * 6175 S_scan_subst(pTHX_ char *start) 6176 { 6177 register char *s; 6178 register PMOP *pm; 6179 I32 first_start; 6180 I32 es = 0; 6181 6182 yylval.ival = OP_NULL; 6183 6184 s = scan_str(start,FALSE,FALSE); 6185 6186 if (!s) 6187 Perl_croak(aTHX_ "Substitution pattern not terminated"); 6188 6189 if (s[-1] == PL_multi_open) 6190 s--; 6191 6192 first_start = PL_multi_start; 6193 s = scan_str(s,FALSE,FALSE); 6194 if (!s) { 6195 if (PL_lex_stuff) { 6196 SvREFCNT_dec(PL_lex_stuff); 6197 PL_lex_stuff = Nullsv; 6198 } 6199 Perl_croak(aTHX_ "Substitution replacement not terminated"); 6200 } 6201 PL_multi_start = first_start; /* so whole substitution is taken together */ 6202 6203 pm = (PMOP*)newPMOP(OP_SUBST, 0); 6204 while (*s) { 6205 if (*s == 'e') { 6206 s++; 6207 es++; 6208 } 6209 else if (strchr("iogcmsx", *s)) 6210 pmflag(&pm->op_pmflags,*s++); 6211 else 6212 break; 6213 } 6214 6215 if (es) { 6216 SV *repl; 6217 PL_sublex_info.super_bufptr = s; 6218 PL_sublex_info.super_bufend = PL_bufend; 6219 PL_multi_end = 0; 6220 pm->op_pmflags |= PMf_EVAL; 6221 repl = newSVpvn("",0); 6222 while (es-- > 0) 6223 sv_catpv(repl, es ? "eval " : "do "); 6224 sv_catpvn(repl, "{ ", 2); 6225 sv_catsv(repl, PL_lex_repl); 6226 sv_catpvn(repl, " };", 2); 6227 SvEVALED_on(repl); 6228 SvREFCNT_dec(PL_lex_repl); 6229 PL_lex_repl = repl; 6230 } 6231 6232 pm->op_pmpermflags = pm->op_pmflags; 6233 PL_lex_op = (OP*)pm; 6234 yylval.ival = OP_SUBST; 6235 return s; 6236 } 6237 6238 STATIC char * 6239 S_scan_trans(pTHX_ char *start) 6240 { 6241 register char* s; 6242 OP *o; 6243 short *tbl; 6244 I32 squash; 6245 I32 del; 6246 I32 complement; 6247 I32 utf8; 6248 I32 count = 0; 6249 6250 yylval.ival = OP_NULL; 6251 6252 s = scan_str(start,FALSE,FALSE); 6253 if (!s) 6254 Perl_croak(aTHX_ "Transliteration pattern not terminated"); 6255 if (s[-1] == PL_multi_open) 6256 s--; 6257 6258 s = scan_str(s,FALSE,FALSE); 6259 if (!s) { 6260 if (PL_lex_stuff) { 6261 SvREFCNT_dec(PL_lex_stuff); 6262 PL_lex_stuff = Nullsv; 6263 } 6264 Perl_croak(aTHX_ "Transliteration replacement not terminated"); 6265 } 6266 6267 New(803,tbl,256,short); 6268 o = newPVOP(OP_TRANS, 0, (char*)tbl); 6269 6270 complement = del = squash = 0; 6271 while (strchr("cds", *s)) { 6272 if (*s == 'c') 6273 complement = OPpTRANS_COMPLEMENT; 6274 else if (*s == 'd') 6275 del = OPpTRANS_DELETE; 6276 else if (*s == 's') 6277 squash = OPpTRANS_SQUASH; 6278 s++; 6279 } 6280 o->op_private = del|squash|complement| 6281 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)| 6282 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0); 6283 6284 PL_lex_op = o; 6285 yylval.ival = OP_TRANS; 6286 return s; 6287 } 6288 6289 STATIC char * 6290 S_scan_heredoc(pTHX_ register char *s) 6291 { 6292 SV *herewas; 6293 I32 op_type = OP_SCALAR; 6294 I32 len; 6295 SV *tmpstr; 6296 char term; 6297 register char *d; 6298 register char *e; 6299 char *peek; 6300 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR)); 6301 6302 s += 2; 6303 d = PL_tokenbuf; 6304 e = PL_tokenbuf + sizeof PL_tokenbuf - 1; 6305 if (!outer) 6306 *d++ = '\n'; 6307 for (peek = s; SPACE_OR_TAB(*peek); peek++) ; 6308 if (*peek && strchr("`'\"",*peek)) { 6309 s = peek; 6310 term = *s++; 6311 s = delimcpy(d, e, s, PL_bufend, term, &len); 6312 d += len; 6313 if (s < PL_bufend) 6314 s++; 6315 } 6316 else { 6317 if (*s == '\\') 6318 s++, term = '\''; 6319 else 6320 term = '"'; 6321 if (!isALNUM_lazy_if(s,UTF)) 6322 deprecate("bare << to mean <<\"\""); 6323 for (; isALNUM_lazy_if(s,UTF); s++) { 6324 if (d < e) 6325 *d++ = *s; 6326 } 6327 } 6328 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1) 6329 Perl_croak(aTHX_ "Delimiter for here document is too long"); 6330 *d++ = '\n'; 6331 *d = '\0'; 6332 len = d - PL_tokenbuf; 6333 #ifndef PERL_STRICT_CR 6334 d = strchr(s, '\r'); 6335 if (d) { 6336 char *olds = s; 6337 s = d; 6338 while (s < PL_bufend) { 6339 if (*s == '\r') { 6340 *d++ = '\n'; 6341 if (*++s == '\n') 6342 s++; 6343 } 6344 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */ 6345 *d++ = *s++; 6346 s++; 6347 } 6348 else 6349 *d++ = *s++; 6350 } 6351 *d = '\0'; 6352 PL_bufend = d; 6353 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr)); 6354 s = olds; 6355 } 6356 #endif 6357 d = "\n"; 6358 if (outer || !(d=ninstr(s,PL_bufend,d,d+1))) 6359 herewas = newSVpvn(s,PL_bufend-s); 6360 else 6361 s--, herewas = newSVpvn(s,d-s); 6362 s += SvCUR(herewas); 6363 6364 tmpstr = NEWSV(87,79); 6365 sv_upgrade(tmpstr, SVt_PVIV); 6366 if (term == '\'') { 6367 op_type = OP_CONST; 6368 SvIVX(tmpstr) = -1; 6369 } 6370 else if (term == '`') { 6371 op_type = OP_BACKTICK; 6372 SvIVX(tmpstr) = '\\'; 6373 } 6374 6375 CLINE; 6376 PL_multi_start = CopLINE(PL_curcop); 6377 PL_multi_open = PL_multi_close = '<'; 6378 term = *PL_tokenbuf; 6379 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) { 6380 char *bufptr = PL_sublex_info.super_bufptr; 6381 char *bufend = PL_sublex_info.super_bufend; 6382 char *olds = s - SvCUR(herewas); 6383 s = strchr(bufptr, '\n'); 6384 if (!s) 6385 s = bufend; 6386 d = s; 6387 while (s < bufend && 6388 (*s != term || memNE(s,PL_tokenbuf,len)) ) { 6389 if (*s++ == '\n') 6390 CopLINE_inc(PL_curcop); 6391 } 6392 if (s >= bufend) { 6393 CopLINE_set(PL_curcop, PL_multi_start); 6394 missingterm(PL_tokenbuf); 6395 } 6396 sv_setpvn(herewas,bufptr,d-bufptr+1); 6397 sv_setpvn(tmpstr,d+1,s-d); 6398 s += len - 1; 6399 sv_catpvn(herewas,s,bufend-s); 6400 (void)strcpy(bufptr,SvPVX(herewas)); 6401 6402 s = olds; 6403 goto retval; 6404 } 6405 else if (!outer) { 6406 d = s; 6407 while (s < PL_bufend && 6408 (*s != term || memNE(s,PL_tokenbuf,len)) ) { 6409 if (*s++ == '\n') 6410 CopLINE_inc(PL_curcop); 6411 } 6412 if (s >= PL_bufend) { 6413 CopLINE_set(PL_curcop, PL_multi_start); 6414 missingterm(PL_tokenbuf); 6415 } 6416 sv_setpvn(tmpstr,d+1,s-d); 6417 s += len - 1; 6418 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */ 6419 6420 sv_catpvn(herewas,s,PL_bufend-s); 6421 sv_setsv(PL_linestr,herewas); 6422 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr); 6423 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 6424 PL_last_lop = PL_last_uni = Nullch; 6425 } 6426 else 6427 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */ 6428 while (s >= PL_bufend) { /* multiple line string? */ 6429 if (!outer || 6430 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) { 6431 CopLINE_set(PL_curcop, PL_multi_start); 6432 missingterm(PL_tokenbuf); 6433 } 6434 CopLINE_inc(PL_curcop); 6435 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 6436 PL_last_lop = PL_last_uni = Nullch; 6437 #ifndef PERL_STRICT_CR 6438 if (PL_bufend - PL_linestart >= 2) { 6439 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') || 6440 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r')) 6441 { 6442 PL_bufend[-2] = '\n'; 6443 PL_bufend--; 6444 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr)); 6445 } 6446 else if (PL_bufend[-1] == '\r') 6447 PL_bufend[-1] = '\n'; 6448 } 6449 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r') 6450 PL_bufend[-1] = '\n'; 6451 #endif 6452 if (PERLDB_LINE && PL_curstash != PL_debstash) { 6453 SV *sv = NEWSV(88,0); 6454 6455 sv_upgrade(sv, SVt_PVMG); 6456 sv_setsv(sv,PL_linestr); 6457 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv); 6458 } 6459 if (*s == term && memEQ(s,PL_tokenbuf,len)) { 6460 s = PL_bufend - 1; 6461 *s = ' '; 6462 sv_catsv(PL_linestr,herewas); 6463 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 6464 } 6465 else { 6466 s = PL_bufend; 6467 sv_catsv(tmpstr,PL_linestr); 6468 } 6469 } 6470 s++; 6471 retval: 6472 PL_multi_end = CopLINE(PL_curcop); 6473 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) { 6474 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1); 6475 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char); 6476 } 6477 SvREFCNT_dec(herewas); 6478 if (UTF && !IN_BYTE && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr))) 6479 SvUTF8_on(tmpstr); 6480 PL_lex_stuff = tmpstr; 6481 yylval.ival = op_type; 6482 return s; 6483 } 6484 6485 /* scan_inputsymbol 6486 takes: current position in input buffer 6487 returns: new position in input buffer 6488 side-effects: yylval and lex_op are set. 6489 6490 This code handles: 6491 6492 <> read from ARGV 6493 <FH> read from filehandle 6494 <pkg::FH> read from package qualified filehandle 6495 <pkg'FH> read from package qualified filehandle 6496 <$fh> read from filehandle in $fh 6497 <*.h> filename glob 6498 6499 */ 6500 6501 STATIC char * 6502 S_scan_inputsymbol(pTHX_ char *start) 6503 { 6504 register char *s = start; /* current position in buffer */ 6505 register char *d; 6506 register char *e; 6507 char *end; 6508 I32 len; 6509 6510 d = PL_tokenbuf; /* start of temp holding space */ 6511 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */ 6512 end = strchr(s, '\n'); 6513 if (!end) 6514 end = PL_bufend; 6515 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */ 6516 6517 /* die if we didn't have space for the contents of the <>, 6518 or if it didn't end, or if we see a newline 6519 */ 6520 6521 if (len >= sizeof PL_tokenbuf) 6522 Perl_croak(aTHX_ "Excessively long <> operator"); 6523 if (s >= end) 6524 Perl_croak(aTHX_ "Unterminated <> operator"); 6525 6526 s++; 6527 6528 /* check for <$fh> 6529 Remember, only scalar variables are interpreted as filehandles by 6530 this code. Anything more complex (e.g., <$fh{$num}>) will be 6531 treated as a glob() call. 6532 This code makes use of the fact that except for the $ at the front, 6533 a scalar variable and a filehandle look the same. 6534 */ 6535 if (*d == '$' && d[1]) d++; 6536 6537 /* allow <Pkg'VALUE> or <Pkg::VALUE> */ 6538 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':')) 6539 d++; 6540 6541 /* If we've tried to read what we allow filehandles to look like, and 6542 there's still text left, then it must be a glob() and not a getline. 6543 Use scan_str to pull out the stuff between the <> and treat it 6544 as nothing more than a string. 6545 */ 6546 6547 if (d - PL_tokenbuf != len) { 6548 yylval.ival = OP_GLOB; 6549 set_csh(); 6550 s = scan_str(start,FALSE,FALSE); 6551 if (!s) 6552 Perl_croak(aTHX_ "Glob not terminated"); 6553 return s; 6554 } 6555 else { 6556 /* we're in a filehandle read situation */ 6557 d = PL_tokenbuf; 6558 6559 /* turn <> into <ARGV> */ 6560 if (!len) 6561 (void)strcpy(d,"ARGV"); 6562 6563 /* if <$fh>, create the ops to turn the variable into a 6564 filehandle 6565 */ 6566 if (*d == '$') { 6567 I32 tmp; 6568 6569 /* try to find it in the pad for this block, otherwise find 6570 add symbol table ops 6571 */ 6572 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) { 6573 OP *o = newOP(OP_PADSV, 0); 6574 o->op_targ = tmp; 6575 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o); 6576 } 6577 else { 6578 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV); 6579 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, 6580 newUNOP(OP_RV2SV, 0, 6581 newGVOP(OP_GV, 0, gv))); 6582 } 6583 PL_lex_op->op_flags |= OPf_SPECIAL; 6584 /* we created the ops in PL_lex_op, so make yylval.ival a null op */ 6585 yylval.ival = OP_NULL; 6586 } 6587 6588 /* If it's none of the above, it must be a literal filehandle 6589 (<Foo::BAR> or <FOO>) so build a simple readline OP */ 6590 else { 6591 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO); 6592 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv)); 6593 yylval.ival = OP_NULL; 6594 } 6595 } 6596 6597 return s; 6598 } 6599 6600 6601 /* scan_str 6602 takes: start position in buffer 6603 keep_quoted preserve \ on the embedded delimiter(s) 6604 keep_delims preserve the delimiters around the string 6605 returns: position to continue reading from buffer 6606 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and 6607 updates the read buffer. 6608 6609 This subroutine pulls a string out of the input. It is called for: 6610 q single quotes q(literal text) 6611 ' single quotes 'literal text' 6612 qq double quotes qq(interpolate $here please) 6613 " double quotes "interpolate $here please" 6614 qx backticks qx(/bin/ls -l) 6615 ` backticks `/bin/ls -l` 6616 qw quote words @EXPORT_OK = qw( func() $spam ) 6617 m// regexp match m/this/ 6618 s/// regexp substitute s/this/that/ 6619 tr/// string transliterate tr/this/that/ 6620 y/// string transliterate y/this/that/ 6621 ($*@) sub prototypes sub foo ($) 6622 (stuff) sub attr parameters sub foo : attr(stuff) 6623 <> readline or globs <FOO>, <>, <$fh>, or <*.c> 6624 6625 In most of these cases (all but <>, patterns and transliterate) 6626 yylex() calls scan_str(). m// makes yylex() call scan_pat() which 6627 calls scan_str(). s/// makes yylex() call scan_subst() which calls 6628 scan_str(). tr/// and y/// make yylex() call scan_trans() which 6629 calls scan_str(). 6630 6631 It skips whitespace before the string starts, and treats the first 6632 character as the delimiter. If the delimiter is one of ([{< then 6633 the corresponding "close" character )]}> is used as the closing 6634 delimiter. It allows quoting of delimiters, and if the string has 6635 balanced delimiters ([{<>}]) it allows nesting. 6636 6637 On success, the SV with the resulting string is put into lex_stuff or, 6638 if that is already non-NULL, into lex_repl. The second case occurs only 6639 when parsing the RHS of the special constructs s/// and tr/// (y///). 6640 For convenience, the terminating delimiter character is stuffed into 6641 SvIVX of the SV. 6642 */ 6643 6644 STATIC char * 6645 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) 6646 { 6647 SV *sv; /* scalar value: string */ 6648 char *tmps; /* temp string, used for delimiter matching */ 6649 register char *s = start; /* current position in the buffer */ 6650 register char term; /* terminating character */ 6651 register char *to; /* current position in the sv's data */ 6652 I32 brackets = 1; /* bracket nesting level */ 6653 bool has_utf8 = FALSE; /* is there any utf8 content? */ 6654 6655 /* skip space before the delimiter */ 6656 if (isSPACE(*s)) 6657 s = skipspace(s); 6658 6659 /* mark where we are, in case we need to report errors */ 6660 CLINE; 6661 6662 /* after skipping whitespace, the next character is the terminator */ 6663 term = *s; 6664 if (UTF8_IS_CONTINUED(term) && UTF) 6665 has_utf8 = TRUE; 6666 6667 /* mark where we are */ 6668 PL_multi_start = CopLINE(PL_curcop); 6669 PL_multi_open = term; 6670 6671 /* find corresponding closing delimiter */ 6672 if (term && (tmps = strchr("([{< )]}> )]}>",term))) 6673 term = tmps[5]; 6674 PL_multi_close = term; 6675 6676 /* create a new SV to hold the contents. 87 is leak category, I'm 6677 assuming. 79 is the SV's initial length. What a random number. */ 6678 sv = NEWSV(87,79); 6679 sv_upgrade(sv, SVt_PVIV); 6680 SvIVX(sv) = term; 6681 (void)SvPOK_only(sv); /* validate pointer */ 6682 6683 /* move past delimiter and try to read a complete string */ 6684 if (keep_delims) 6685 sv_catpvn(sv, s, 1); 6686 s++; 6687 for (;;) { 6688 /* extend sv if need be */ 6689 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1); 6690 /* set 'to' to the next character in the sv's string */ 6691 to = SvPVX(sv)+SvCUR(sv); 6692 6693 /* if open delimiter is the close delimiter read unbridle */ 6694 if (PL_multi_open == PL_multi_close) { 6695 for (; s < PL_bufend; s++,to++) { 6696 /* embedded newlines increment the current line number */ 6697 if (*s == '\n' && !PL_rsfp) 6698 CopLINE_inc(PL_curcop); 6699 /* handle quoted delimiters */ 6700 if (*s == '\\' && s+1 < PL_bufend && term != '\\') { 6701 if (!keep_quoted && s[1] == term) 6702 s++; 6703 /* any other quotes are simply copied straight through */ 6704 else 6705 *to++ = *s++; 6706 } 6707 /* terminate when run out of buffer (the for() condition), or 6708 have found the terminator */ 6709 else if (*s == term) 6710 break; 6711 else if (!has_utf8 && UTF8_IS_CONTINUED(*s) && UTF) 6712 has_utf8 = TRUE; 6713 *to = *s; 6714 } 6715 } 6716 6717 /* if the terminator isn't the same as the start character (e.g., 6718 matched brackets), we have to allow more in the quoting, and 6719 be prepared for nested brackets. 6720 */ 6721 else { 6722 /* read until we run out of string, or we find the terminator */ 6723 for (; s < PL_bufend; s++,to++) { 6724 /* embedded newlines increment the line count */ 6725 if (*s == '\n' && !PL_rsfp) 6726 CopLINE_inc(PL_curcop); 6727 /* backslashes can escape the open or closing characters */ 6728 if (*s == '\\' && s+1 < PL_bufend) { 6729 if (!keep_quoted && 6730 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))) 6731 s++; 6732 else 6733 *to++ = *s++; 6734 } 6735 /* allow nested opens and closes */ 6736 else if (*s == PL_multi_close && --brackets <= 0) 6737 break; 6738 else if (*s == PL_multi_open) 6739 brackets++; 6740 else if (!has_utf8 && UTF8_IS_CONTINUED(*s) && UTF) 6741 has_utf8 = TRUE; 6742 *to = *s; 6743 } 6744 } 6745 /* terminate the copied string and update the sv's end-of-string */ 6746 *to = '\0'; 6747 SvCUR_set(sv, to - SvPVX(sv)); 6748 6749 /* 6750 * this next chunk reads more into the buffer if we're not done yet 6751 */ 6752 6753 if (s < PL_bufend) 6754 break; /* handle case where we are done yet :-) */ 6755 6756 #ifndef PERL_STRICT_CR 6757 if (to - SvPVX(sv) >= 2) { 6758 if ((to[-2] == '\r' && to[-1] == '\n') || 6759 (to[-2] == '\n' && to[-1] == '\r')) 6760 { 6761 to[-2] = '\n'; 6762 to--; 6763 SvCUR_set(sv, to - SvPVX(sv)); 6764 } 6765 else if (to[-1] == '\r') 6766 to[-1] = '\n'; 6767 } 6768 else if (to - SvPVX(sv) == 1 && to[-1] == '\r') 6769 to[-1] = '\n'; 6770 #endif 6771 6772 /* if we're out of file, or a read fails, bail and reset the current 6773 line marker so we can report where the unterminated string began 6774 */ 6775 if (!PL_rsfp || 6776 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) { 6777 sv_free(sv); 6778 CopLINE_set(PL_curcop, PL_multi_start); 6779 return Nullch; 6780 } 6781 /* we read a line, so increment our line counter */ 6782 CopLINE_inc(PL_curcop); 6783 6784 /* update debugger info */ 6785 if (PERLDB_LINE && PL_curstash != PL_debstash) { 6786 SV *sv = NEWSV(88,0); 6787 6788 sv_upgrade(sv, SVt_PVMG); 6789 sv_setsv(sv,PL_linestr); 6790 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv); 6791 } 6792 6793 /* having changed the buffer, we must update PL_bufend */ 6794 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 6795 PL_last_lop = PL_last_uni = Nullch; 6796 } 6797 6798 /* at this point, we have successfully read the delimited string */ 6799 6800 if (keep_delims) 6801 sv_catpvn(sv, s, 1); 6802 if (has_utf8) 6803 SvUTF8_on(sv); 6804 PL_multi_end = CopLINE(PL_curcop); 6805 s++; 6806 6807 /* if we allocated too much space, give some back */ 6808 if (SvCUR(sv) + 5 < SvLEN(sv)) { 6809 SvLEN_set(sv, SvCUR(sv) + 1); 6810 Renew(SvPVX(sv), SvLEN(sv), char); 6811 } 6812 6813 /* decide whether this is the first or second quoted string we've read 6814 for this op 6815 */ 6816 6817 if (PL_lex_stuff) 6818 PL_lex_repl = sv; 6819 else 6820 PL_lex_stuff = sv; 6821 return s; 6822 } 6823 6824 /* 6825 scan_num 6826 takes: pointer to position in buffer 6827 returns: pointer to new position in buffer 6828 side-effects: builds ops for the constant in yylval.op 6829 6830 Read a number in any of the formats that Perl accepts: 6831 6832 0(x[0-7A-F]+)|([0-7]+)|(b[01]) 6833 [\d_]+(\.[\d_]*)?[Ee](\d+) 6834 6835 Underbars (_) are allowed in decimal numbers. If -w is on, 6836 underbars before a decimal point must be at three digit intervals. 6837 6838 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the 6839 thing it reads. 6840 6841 If it reads a number without a decimal point or an exponent, it will 6842 try converting the number to an integer and see if it can do so 6843 without loss of precision. 6844 */ 6845 6846 char * 6847 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) 6848 { 6849 register char *s = start; /* current position in buffer */ 6850 register char *d; /* destination in temp buffer */ 6851 register char *e; /* end of temp buffer */ 6852 NV nv; /* number read, as a double */ 6853 SV *sv = Nullsv; /* place to put the converted number */ 6854 bool floatit; /* boolean: int or float? */ 6855 char *lastub = 0; /* position of last underbar */ 6856 static char number_too_long[] = "Number too long"; 6857 6858 /* We use the first character to decide what type of number this is */ 6859 6860 switch (*s) { 6861 default: 6862 Perl_croak(aTHX_ "panic: scan_num"); 6863 6864 /* if it starts with a 0, it could be an octal number, a decimal in 6865 0.13 disguise, or a hexadecimal number, or a binary number. */ 6866 case '0': 6867 { 6868 /* variables: 6869 u holds the "number so far" 6870 shift the power of 2 of the base 6871 (hex == 4, octal == 3, binary == 1) 6872 overflowed was the number more than we can hold? 6873 6874 Shift is used when we add a digit. It also serves as an "are 6875 we in octal/hex/binary?" indicator to disallow hex characters 6876 when in octal mode. 6877 */ 6878 NV n = 0.0; 6879 UV u = 0; 6880 I32 shift; 6881 bool overflowed = FALSE; 6882 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 }; 6883 static char* bases[5] = { "", "binary", "", "octal", 6884 "hexadecimal" }; 6885 static char* Bases[5] = { "", "Binary", "", "Octal", 6886 "Hexadecimal" }; 6887 static char *maxima[5] = { "", 6888 "0b11111111111111111111111111111111", 6889 "", 6890 "037777777777", 6891 "0xffffffff" }; 6892 char *base, *Base, *max; 6893 6894 /* check for hex */ 6895 if (s[1] == 'x') { 6896 shift = 4; 6897 s += 2; 6898 } else if (s[1] == 'b') { 6899 shift = 1; 6900 s += 2; 6901 } 6902 /* check for a decimal in disguise */ 6903 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E') 6904 goto decimal; 6905 /* so it must be octal */ 6906 else 6907 shift = 3; 6908 6909 base = bases[shift]; 6910 Base = Bases[shift]; 6911 max = maxima[shift]; 6912 6913 /* read the rest of the number */ 6914 for (;;) { 6915 /* x is used in the overflow test, 6916 b is the digit we're adding on. */ 6917 UV x, b; 6918 6919 switch (*s) { 6920 6921 /* if we don't mention it, we're done */ 6922 default: 6923 goto out; 6924 6925 /* _ are ignored */ 6926 case '_': 6927 s++; 6928 break; 6929 6930 /* 8 and 9 are not octal */ 6931 case '8': case '9': 6932 if (shift == 3) 6933 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s)); 6934 /* FALL THROUGH */ 6935 6936 /* octal digits */ 6937 case '2': case '3': case '4': 6938 case '5': case '6': case '7': 6939 if (shift == 1) 6940 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s)); 6941 /* FALL THROUGH */ 6942 6943 case '0': case '1': 6944 b = *s++ & 15; /* ASCII digit -> value of digit */ 6945 goto digit; 6946 6947 /* hex digits */ 6948 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': 6949 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': 6950 /* make sure they said 0x */ 6951 if (shift != 4) 6952 goto out; 6953 b = (*s++ & 7) + 9; 6954 6955 /* Prepare to put the digit we have onto the end 6956 of the number so far. We check for overflows. 6957 */ 6958 6959 digit: 6960 if (!overflowed) { 6961 x = u << shift; /* make room for the digit */ 6962 6963 if ((x >> shift) != u 6964 && !(PL_hints & HINT_NEW_BINARY)) { 6965 overflowed = TRUE; 6966 n = (NV) u; 6967 if (ckWARN_d(WARN_OVERFLOW)) 6968 Perl_warner(aTHX_ WARN_OVERFLOW, 6969 "Integer overflow in %s number", 6970 base); 6971 } else 6972 u = x | b; /* add the digit to the end */ 6973 } 6974 if (overflowed) { 6975 n *= nvshift[shift]; 6976 /* If an NV has not enough bits in its 6977 * mantissa to represent an UV this summing of 6978 * small low-order numbers is a waste of time 6979 * (because the NV cannot preserve the 6980 * low-order bits anyway): we could just 6981 * remember when did we overflow and in the 6982 * end just multiply n by the right 6983 * amount. */ 6984 n += (NV) b; 6985 } 6986 break; 6987 } 6988 } 6989 6990 /* if we get here, we had success: make a scalar value from 6991 the number. 6992 */ 6993 out: 6994 sv = NEWSV(92,0); 6995 if (overflowed) { 6996 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0) 6997 Perl_warner(aTHX_ WARN_PORTABLE, 6998 "%s number > %s non-portable", 6999 Base, max); 7000 sv_setnv(sv, n); 7001 } 7002 else { 7003 #if UVSIZE > 4 7004 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff) 7005 Perl_warner(aTHX_ WARN_PORTABLE, 7006 "%s number > %s non-portable", 7007 Base, max); 7008 #endif 7009 sv_setuv(sv, u); 7010 } 7011 if (PL_hints & HINT_NEW_BINARY) 7012 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL); 7013 } 7014 break; 7015 7016 /* 7017 handle decimal numbers. 7018 we're also sent here when we read a 0 as the first digit 7019 */ 7020 case '1': case '2': case '3': case '4': case '5': 7021 case '6': case '7': case '8': case '9': case '.': 7022 decimal: 7023 d = PL_tokenbuf; 7024 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */ 7025 floatit = FALSE; 7026 7027 /* read next group of digits and _ and copy into d */ 7028 while (isDIGIT(*s) || *s == '_') { 7029 /* skip underscores, checking for misplaced ones 7030 if -w is on 7031 */ 7032 if (*s == '_') { 7033 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3) 7034 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number"); 7035 lastub = ++s; 7036 } 7037 else { 7038 /* check for end of fixed-length buffer */ 7039 if (d >= e) 7040 Perl_croak(aTHX_ number_too_long); 7041 /* if we're ok, copy the character */ 7042 *d++ = *s++; 7043 } 7044 } 7045 7046 /* final misplaced underbar check */ 7047 if (lastub && s - lastub != 3) { 7048 if (ckWARN(WARN_SYNTAX)) 7049 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number"); 7050 } 7051 7052 /* read a decimal portion if there is one. avoid 7053 3..5 being interpreted as the number 3. followed 7054 by .5 7055 */ 7056 if (*s == '.' && s[1] != '.') { 7057 floatit = TRUE; 7058 *d++ = *s++; 7059 7060 /* copy, ignoring underbars, until we run out of 7061 digits. Note: no misplaced underbar checks! 7062 */ 7063 for (; isDIGIT(*s) || *s == '_'; s++) { 7064 /* fixed length buffer check */ 7065 if (d >= e) 7066 Perl_croak(aTHX_ number_too_long); 7067 if (*s != '_') 7068 *d++ = *s; 7069 } 7070 if (*s == '.' && isDIGIT(s[1])) { 7071 /* oops, it's really a v-string, but without the "v" */ 7072 s = start - 1; 7073 goto vstring; 7074 } 7075 } 7076 7077 /* read exponent part, if present */ 7078 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) { 7079 floatit = TRUE; 7080 s++; 7081 7082 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */ 7083 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */ 7084 7085 /* allow positive or negative exponent */ 7086 if (*s == '+' || *s == '-') 7087 *d++ = *s++; 7088 7089 /* read digits of exponent (no underbars :-) */ 7090 while (isDIGIT(*s)) { 7091 if (d >= e) 7092 Perl_croak(aTHX_ number_too_long); 7093 *d++ = *s++; 7094 } 7095 } 7096 7097 /* terminate the string */ 7098 *d = '\0'; 7099 7100 /* make an sv from the string */ 7101 sv = NEWSV(92,0); 7102 7103 #if defined(Strtol) && defined(Strtoul) 7104 7105 /* 7106 strtol/strtoll sets errno to ERANGE if the number is too big 7107 for an integer. We try to do an integer conversion first 7108 if no characters indicating "float" have been found. 7109 */ 7110 7111 if (!floatit) { 7112 IV iv; 7113 UV uv; 7114 errno = 0; 7115 if (*PL_tokenbuf == '-') 7116 iv = Strtol(PL_tokenbuf, (char**)NULL, 10); 7117 else 7118 uv = Strtoul(PL_tokenbuf, (char**)NULL, 10); 7119 if (errno) 7120 floatit = TRUE; /* Probably just too large. */ 7121 else if (*PL_tokenbuf == '-') 7122 sv_setiv(sv, iv); 7123 else if (uv <= IV_MAX) 7124 sv_setiv(sv, uv); /* Prefer IVs over UVs. */ 7125 else 7126 sv_setuv(sv, uv); 7127 } 7128 if (floatit) { 7129 nv = Atof(PL_tokenbuf); 7130 sv_setnv(sv, nv); 7131 } 7132 #else 7133 /* 7134 No working strtou?ll?. 7135 7136 Unfortunately atol() doesn't do range checks (returning 7137 LONG_MIN/LONG_MAX, and setting errno to ERANGE on overflows) 7138 everywhere [1], so we cannot use use atol() (or atoll()). 7139 If we could, they would be used, as Atol(), very much like 7140 Strtol() and Strtoul() are used above. 7141 7142 [1] XXX Configure test needed to check for atol() 7143 (and atoll()) overflow behaviour XXX 7144 7145 --jhi 7146 7147 We need to do this the hard way. */ 7148 7149 nv = Atof(PL_tokenbuf); 7150 7151 /* See if we can make do with an integer value without loss of 7152 precision. We use U_V to cast to a UV, because some 7153 compilers have issues. Then we try casting it back and see 7154 if it was the same [1]. We only do this if we know we 7155 specifically read an integer. If floatit is true, then we 7156 don't need to do the conversion at all. 7157 7158 [1] Note that this is lossy if our NVs cannot preserve our 7159 UVs. There are metaconfig defines NV_PRESERVES_UV (a boolean) 7160 and NV_PRESERVES_UV_BITS (a number), but in general we really 7161 do hope all such potentially lossy platforms have strtou?ll? 7162 to do a lossless IV/UV conversion. 7163 7164 Maybe could do some tricks with DBL_DIG, LDBL_DIG and 7165 DBL_MANT_DIG and LDBL_MANT_DIG (these are already available 7166 as NV_DIG and NV_MANT_DIG)? 7167 7168 --jhi 7169 */ 7170 { 7171 UV uv = U_V(nv); 7172 if (!floatit && (NV)uv == nv) { 7173 if (uv <= IV_MAX) 7174 sv_setiv(sv, uv); /* Prefer IVs over UVs. */ 7175 else 7176 sv_setuv(sv, uv); 7177 } 7178 else 7179 sv_setnv(sv, nv); 7180 } 7181 #endif 7182 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : 7183 (PL_hints & HINT_NEW_INTEGER) ) 7184 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf, 7185 (floatit ? "float" : "integer"), 7186 sv, Nullsv, NULL); 7187 break; 7188 7189 /* if it starts with a v, it could be a v-string */ 7190 case 'v': 7191 vstring: 7192 { 7193 char *pos = s; 7194 pos++; 7195 while (isDIGIT(*pos) || *pos == '_') 7196 pos++; 7197 if (!isALPHA(*pos)) { 7198 UV rev; 7199 U8 tmpbuf[UTF8_MAXLEN+1]; 7200 U8 *tmpend; 7201 bool utf8 = FALSE; 7202 s++; /* get past 'v' */ 7203 7204 sv = NEWSV(92,5); 7205 sv_setpvn(sv, "", 0); 7206 7207 for (;;) { 7208 if (*s == '0' && isDIGIT(s[1])) 7209 yyerror("Octal number in vector unsupported"); 7210 rev = 0; 7211 { 7212 /* this is atoi() that tolerates underscores */ 7213 char *end = pos; 7214 UV mult = 1; 7215 while (--end >= s) { 7216 UV orev; 7217 if (*end == '_') 7218 continue; 7219 orev = rev; 7220 rev += (*end - '0') * mult; 7221 mult *= 10; 7222 if (orev > rev && ckWARN_d(WARN_OVERFLOW)) 7223 Perl_warner(aTHX_ WARN_OVERFLOW, 7224 "Integer overflow in decimal number"); 7225 } 7226 } 7227 tmpend = uv_to_utf8(tmpbuf, rev); 7228 utf8 = utf8 || rev > 127; 7229 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); 7230 if (*pos == '.' && isDIGIT(pos[1])) 7231 s = ++pos; 7232 else { 7233 s = pos; 7234 break; 7235 } 7236 while (isDIGIT(*pos) || *pos == '_') 7237 pos++; 7238 } 7239 7240 SvPOK_on(sv); 7241 SvREADONLY_on(sv); 7242 if (utf8) { 7243 SvUTF8_on(sv); 7244 if (!UTF||IN_BYTE) 7245 sv_utf8_downgrade(sv, TRUE); 7246 } 7247 } 7248 } 7249 break; 7250 } 7251 7252 /* make the op for the constant and return */ 7253 7254 if (sv) 7255 lvalp->opval = newSVOP(OP_CONST, 0, sv); 7256 else 7257 lvalp->opval = Nullop; 7258 7259 return s; 7260 } 7261 7262 STATIC char * 7263 S_scan_formline(pTHX_ register char *s) 7264 { 7265 register char *eol; 7266 register char *t; 7267 SV *stuff = newSVpvn("",0); 7268 bool needargs = FALSE; 7269 7270 while (!needargs) { 7271 if (*s == '.' || *s == /*{*/'}') { 7272 /*SUPPRESS 530*/ 7273 #ifdef PERL_STRICT_CR 7274 for (t = s+1;SPACE_OR_TAB(*t); t++) ; 7275 #else 7276 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ; 7277 #endif 7278 if (*t == '\n' || t == PL_bufend) 7279 break; 7280 } 7281 if (PL_in_eval && !PL_rsfp) { 7282 eol = strchr(s,'\n'); 7283 if (!eol++) 7284 eol = PL_bufend; 7285 } 7286 else 7287 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); 7288 if (*s != '#') { 7289 for (t = s; t < eol; t++) { 7290 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) { 7291 needargs = FALSE; 7292 goto enough; /* ~~ must be first line in formline */ 7293 } 7294 if (*t == '@' || *t == '^') 7295 needargs = TRUE; 7296 } 7297 sv_catpvn(stuff, s, eol-s); 7298 #ifndef PERL_STRICT_CR 7299 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') { 7300 char *end = SvPVX(stuff) + SvCUR(stuff); 7301 end[-2] = '\n'; 7302 end[-1] = '\0'; 7303 SvCUR(stuff)--; 7304 } 7305 #endif 7306 } 7307 s = eol; 7308 if (PL_rsfp) { 7309 s = filter_gets(PL_linestr, PL_rsfp, 0); 7310 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); 7311 PL_bufend = PL_bufptr + SvCUR(PL_linestr); 7312 PL_last_lop = PL_last_uni = Nullch; 7313 if (!s) { 7314 s = PL_bufptr; 7315 yyerror("Format not terminated"); 7316 break; 7317 } 7318 } 7319 incline(s); 7320 } 7321 enough: 7322 if (SvCUR(stuff)) { 7323 PL_expect = XTERM; 7324 if (needargs) { 7325 PL_lex_state = LEX_NORMAL; 7326 PL_nextval[PL_nexttoke].ival = 0; 7327 force_next(','); 7328 } 7329 else 7330 PL_lex_state = LEX_FORMLINE; 7331 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff); 7332 force_next(THING); 7333 PL_nextval[PL_nexttoke].ival = OP_FORMLINE; 7334 force_next(LSTOP); 7335 } 7336 else { 7337 SvREFCNT_dec(stuff); 7338 PL_lex_formbrack = 0; 7339 PL_bufptr = s; 7340 } 7341 return s; 7342 } 7343 7344 STATIC void 7345 S_set_csh(pTHX) 7346 { 7347 #ifdef CSH 7348 if (!PL_cshlen) 7349 PL_cshlen = strlen(PL_cshname); 7350 #endif 7351 } 7352 7353 I32 7354 Perl_start_subparse(pTHX_ I32 is_format, U32 flags) 7355 { 7356 I32 oldsavestack_ix = PL_savestack_ix; 7357 CV* outsidecv = PL_compcv; 7358 AV* comppadlist; 7359 7360 if (PL_compcv) { 7361 assert(SvTYPE(PL_compcv) == SVt_PVCV); 7362 } 7363 SAVEI32(PL_subline); 7364 save_item(PL_subname); 7365 SAVEI32(PL_padix); 7366 SAVECOMPPAD(); 7367 SAVESPTR(PL_comppad_name); 7368 SAVESPTR(PL_compcv); 7369 SAVEI32(PL_comppad_name_fill); 7370 SAVEI32(PL_min_intro_pending); 7371 SAVEI32(PL_max_intro_pending); 7372 SAVEI32(PL_pad_reset_pending); 7373 7374 PL_compcv = (CV*)NEWSV(1104,0); 7375 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV); 7376 CvFLAGS(PL_compcv) |= flags; 7377 7378 PL_comppad = newAV(); 7379 av_push(PL_comppad, Nullsv); 7380 PL_curpad = AvARRAY(PL_comppad); 7381 PL_comppad_name = newAV(); 7382 PL_comppad_name_fill = 0; 7383 PL_min_intro_pending = 0; 7384 PL_padix = 0; 7385 PL_subline = CopLINE(PL_curcop); 7386 #ifdef USE_THREADS 7387 av_store(PL_comppad_name, 0, newSVpvn("@_", 2)); 7388 PL_curpad[0] = (SV*)newAV(); 7389 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */ 7390 #endif /* USE_THREADS */ 7391 7392 comppadlist = newAV(); 7393 AvREAL_off(comppadlist); 7394 av_store(comppadlist, 0, (SV*)PL_comppad_name); 7395 av_store(comppadlist, 1, (SV*)PL_comppad); 7396 7397 CvPADLIST(PL_compcv) = comppadlist; 7398 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv); 7399 #ifdef USE_THREADS 7400 CvOWNER(PL_compcv) = 0; 7401 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex); 7402 MUTEX_INIT(CvMUTEXP(PL_compcv)); 7403 #endif /* USE_THREADS */ 7404 7405 return oldsavestack_ix; 7406 } 7407 7408 #ifdef __SC__ 7409 #pragma segment Perl_yylex 7410 #endif 7411 int 7412 Perl_yywarn(pTHX_ char *s) 7413 { 7414 PL_in_eval |= EVAL_WARNONLY; 7415 yyerror(s); 7416 PL_in_eval &= ~EVAL_WARNONLY; 7417 return 0; 7418 } 7419 7420 int 7421 Perl_yyerror(pTHX_ char *s) 7422 { 7423 char *where = NULL; 7424 char *context = NULL; 7425 int contlen = -1; 7426 SV *msg; 7427 7428 if (!yychar || (yychar == ';' && !PL_rsfp)) 7429 where = "at EOF"; 7430 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 && 7431 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) { 7432 while (isSPACE(*PL_oldoldbufptr)) 7433 PL_oldoldbufptr++; 7434 context = PL_oldoldbufptr; 7435 contlen = PL_bufptr - PL_oldoldbufptr; 7436 } 7437 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 && 7438 PL_oldbufptr != PL_bufptr) { 7439 while (isSPACE(*PL_oldbufptr)) 7440 PL_oldbufptr++; 7441 context = PL_oldbufptr; 7442 contlen = PL_bufptr - PL_oldbufptr; 7443 } 7444 else if (yychar > 255) 7445 where = "next token ???"; 7446 #ifdef USE_PURE_BISON 7447 /* GNU Bison sets the value -2 */ 7448 else if (yychar == -2) { 7449 #else 7450 else if ((yychar & 127) == 127) { 7451 #endif 7452 if (PL_lex_state == LEX_NORMAL || 7453 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL)) 7454 where = "at end of line"; 7455 else if (PL_lex_inpat) 7456 where = "within pattern"; 7457 else 7458 where = "within string"; 7459 } 7460 else { 7461 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10)); 7462 if (yychar < 32) 7463 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar)); 7464 else if (isPRINT_LC(yychar)) 7465 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar); 7466 else 7467 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255); 7468 where = SvPVX(where_sv); 7469 } 7470 msg = sv_2mortal(newSVpv(s, 0)); 7471 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ", 7472 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 7473 if (context) 7474 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context); 7475 else 7476 Perl_sv_catpvf(aTHX_ msg, "%s\n", where); 7477 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) { 7478 Perl_sv_catpvf(aTHX_ msg, 7479 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n", 7480 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start); 7481 PL_multi_end = 0; 7482 } 7483 if (PL_in_eval & EVAL_WARNONLY) 7484 Perl_warn(aTHX_ "%"SVf, msg); 7485 else 7486 qerror(msg); 7487 if (PL_error_count >= 10) { 7488 if (PL_in_eval && SvCUR(ERRSV)) 7489 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n", 7490 ERRSV, CopFILE(PL_curcop)); 7491 else 7492 Perl_croak(aTHX_ "%s has too many errors.\n", 7493 CopFILE(PL_curcop)); 7494 } 7495 PL_in_my = 0; 7496 PL_in_my_stash = Nullhv; 7497 return 0; 7498 } 7499 #ifdef __SC__ 7500 #pragma segment Main 7501 #endif 7502 7503 STATIC char* 7504 S_swallow_bom(pTHX_ U8 *s) 7505 { 7506 STRLEN slen; 7507 slen = SvCUR(PL_linestr); 7508 switch (*s) { 7509 case 0xFF: 7510 if (s[1] == 0xFE) { 7511 /* UTF-16 little-endian */ 7512 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */ 7513 Perl_croak(aTHX_ "Unsupported script encoding"); 7514 #ifndef PERL_NO_UTF16_FILTER 7515 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n")); 7516 s += 2; 7517 if (PL_bufend > (char*)s) { 7518 U8 *news; 7519 I32 newlen; 7520 7521 filter_add(utf16rev_textfilter, NULL); 7522 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); 7523 PL_bufend = (char*)utf16_to_utf8_reversed(s, news, 7524 PL_bufend - (char*)s - 1, 7525 &newlen); 7526 Copy(news, s, newlen, U8); 7527 SvCUR_set(PL_linestr, newlen); 7528 PL_bufend = SvPVX(PL_linestr) + newlen; 7529 news[newlen++] = '\0'; 7530 Safefree(news); 7531 } 7532 #else 7533 Perl_croak(aTHX_ "Unsupported script encoding"); 7534 #endif 7535 } 7536 break; 7537 7538 case 0xFE: 7539 if (s[1] == 0xFF) { /* UTF-16 big-endian */ 7540 #ifndef PERL_NO_UTF16_FILTER 7541 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n")); 7542 s += 2; 7543 if (PL_bufend > (char *)s) { 7544 U8 *news; 7545 I32 newlen; 7546 7547 filter_add(utf16_textfilter, NULL); 7548 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); 7549 PL_bufend = (char*)utf16_to_utf8(s, news, 7550 PL_bufend - (char*)s, 7551 &newlen); 7552 Copy(news, s, newlen, U8); 7553 SvCUR_set(PL_linestr, newlen); 7554 PL_bufend = SvPVX(PL_linestr) + newlen; 7555 news[newlen++] = '\0'; 7556 Safefree(news); 7557 } 7558 #else 7559 Perl_croak(aTHX_ "Unsupported script encoding"); 7560 #endif 7561 } 7562 break; 7563 7564 case 0xEF: 7565 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) { 7566 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n")); 7567 s += 3; /* UTF-8 */ 7568 } 7569 break; 7570 case 0: 7571 if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */ 7572 s[2] == 0xFE && s[3] == 0xFF) 7573 { 7574 Perl_croak(aTHX_ "Unsupported script encoding"); 7575 } 7576 } 7577 return (char*)s; 7578 } 7579 7580 #ifdef PERL_OBJECT 7581 #include "XSUB.h" 7582 #endif 7583 7584 /* 7585 * restore_rsfp 7586 * Restore a source filter. 7587 */ 7588 7589 static void 7590 restore_rsfp(pTHXo_ void *f) 7591 { 7592 PerlIO *fp = (PerlIO*)f; 7593 7594 if (PL_rsfp == PerlIO_stdin()) 7595 PerlIO_clearerr(PL_rsfp); 7596 else if (PL_rsfp && (PL_rsfp != fp)) 7597 PerlIO_close(PL_rsfp); 7598 PL_rsfp = fp; 7599 } 7600 7601 #ifndef PERL_NO_UTF16_FILTER 7602 static I32 7603 utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen) 7604 { 7605 I32 count = FILTER_READ(idx+1, sv, maxlen); 7606 if (count) { 7607 U8* tmps; 7608 U8* tend; 7609 I32 newlen; 7610 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); 7611 if (!*SvPV_nolen(sv)) 7612 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */ 7613 return count; 7614 7615 tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen); 7616 sv_usepvn(sv, (char*)tmps, tend - tmps); 7617 } 7618 return count; 7619 } 7620 7621 static I32 7622 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen) 7623 { 7624 I32 count = FILTER_READ(idx+1, sv, maxlen); 7625 if (count) { 7626 U8* tmps; 7627 U8* tend; 7628 I32 newlen; 7629 if (!*SvPV_nolen(sv)) 7630 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */ 7631 return count; 7632 7633 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); 7634 tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen); 7635 sv_usepvn(sv, (char*)tmps, tend - tmps); 7636 } 7637 return count; 7638 } 7639 #endif 7640