toke.c

   1 /*    toke.c
   2  *
   3  *    Copyright (c) 1991-1997, 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 #include "EXTERN.h"
  15 #include "perl.h"
  16
  17 static void check_uni _((void));
  18 static void  force_next _((I32 type));
  19 static char *force_version _((char *start));
  20 static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
  21 static SV *q _((SV *sv));
  22 static char *scan_const _((char *start));
  23 static char *scan_formline _((char *s));
  24 static char *scan_heredoc _((char *s));
  25 static char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
  26                            I32 ck_uni));
  27 static char *scan_inputsymbol _((char *start));
  28 static char *scan_pat _((char *start));
  29 static char *scan_str _((char *start));
  30 static char *scan_subst _((char *start));
  31 static char *scan_trans _((char *start));
  32 static char *scan_word _((char *s, char *dest, STRLEN destlen,
  33                           int allow_package, STRLEN *slp));
  34 static char *skipspace _((char *s));
  35 static void checkcomma _((char *s, char *name, char *what));
  36 static void force_ident _((char *s, int kind));
  37 static void incline _((char *s));
  38 static int intuit_method _((char *s, GV *gv));
  39 static int intuit_more _((char *s));
  40 static I32 lop _((I32 f, expectation x, char *s));
  41 static void missingterm _((char *s));
  42 static void no_op _((char *what, char *s));
  43 static void set_csh _((void));
  44 static I32 sublex_done _((void));
  45 static I32 sublex_push _((void));
  46 static I32 sublex_start _((void));
  47 #ifdef CRIPPLED_CC
  48 static int uni _((I32 f, char *s));
  49 #endif
  50 static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
  51 static void restore_rsfp _((void *f));
  52
  53 static char ident_too_long[] = "Identifier too long";
  54
  55 static char *linestart;         /* beg. of most recently read line */
  56
  57 static char pending_ident;      /* pending identifier lookup */
  58
  59 static struct {
  60     I32 super_state;    /* lexer state to save */
  61     I32 sub_inwhat;     /* "lex_inwhat" to use */
  62     OP *sub_op;         /* "lex_op" to use */
  63 } sublex_info;
  64
  65 /* The following are arranged oddly so that the guard on the switch statement
  66  * can get by with a single comparison (if the compiler is smart enough).
  67  */
  68
  69 /* #define LEX_NOTPARSING               11 is done in perl.h. */
  70
  71 #define LEX_NORMAL              10
  72 #define LEX_INTERPNORMAL         9
  73 #define LEX_INTERPCASEMOD        8
  74 #define LEX_INTERPPUSH           7
  75 #define LEX_INTERPSTART          6
  76 #define LEX_INTERPEND            5
  77 #define LEX_INTERPENDMAYBE       4
  78 #define LEX_INTERPCONCAT         3
  79 #define LEX_INTERPCONST          2
  80 #define LEX_FORMLINE             1
  81 #define LEX_KNOWNEXT             0
  82
  83 #ifdef I_FCNTL
  84 #include <fcntl.h>
  85 #endif
  86 #ifdef I_SYS_FILE
  87 #include <sys/file.h>
  88 #endif
  89
  90 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  91 #ifdef I_UNISTD
  92 #  include <unistd.h> /* Needed for execv() */
  93 #endif
  94
  95
  96 #ifdef ff_next
  97 #undef ff_next
  98 #endif
  99
 100 #include "keywords.h"
 101
 102 #ifdef CLINE
 103 #undef CLINE
 104 #endif
 105 #define CLINE (copline = (curcop->cop_line < copline ? curcop->cop_line : copline))
 106
 107 #define TOKEN(retval) return (bufptr = s,(int)retval)
 108 #define OPERATOR(retval) return (expect = XTERM,bufptr = s,(int)retval)
 109 #define AOPERATOR(retval) return ao((expect = XTERM,bufptr = s,(int)retval))
 110 #define PREBLOCK(retval) return (expect = XBLOCK,bufptr = s,(int)retval)
 111 #define PRETERMBLOCK(retval) return (expect = XTERMBLOCK,bufptr = s,(int)retval)
 112 #define PREREF(retval) return (expect = XREF,bufptr = s,(int)retval)
 113 #define TERM(retval) return (CLINE, expect = XOPERATOR,bufptr = s,(int)retval)
 114 #define LOOPX(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LOOPEX)
 115 #define FTST(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)UNIOP)
 116 #define FUN0(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC0)
 117 #define FUN1(f) return(yylval.ival = f,expect = XOPERATOR,bufptr = s,(int)FUNC1)
 118 #define BOop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)BITOROP))
 119 #define BAop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)BITANDOP))
 120 #define SHop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)SHIFTOP))
 121 #define PWop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)POWOP))
 122 #define PMop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)MATCHOP)
 123 #define Aop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)ADDOP))
 124 #define Mop(f) return ao((yylval.ival=f,expect = XTERM,bufptr = s,(int)MULOP))
 125 #define Eop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)EQOP)
 126 #define Rop(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)RELOP)
 127
 128 /* This bit of chicanery makes a unary function followed by
 129  * a parenthesis into a function with one argument, highest precedence.
 130  */
 131 #define UNI(f) return(yylval.ival = f, \
 132         expect = XTERM, \
 133         bufptr = s, \
 134         last_uni = oldbufptr, \
 135         last_lop_op = f, \
 136         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 137
 138 #define UNIBRACK(f) return(yylval.ival = f, \
 139         bufptr = s, \
 140         last_uni = oldbufptr, \
 141         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 142
 143 /* grandfather return to old style */
 144 #define OLDLOP(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LSTOP)
 145
 146 static int
 147 ao(toketype)
 148 int toketype;
 149 {
 150     if (*bufptr == '=') {
 151         bufptr++;
 152         if (toketype == ANDAND)
 153             yylval.ival = OP_ANDASSIGN;
 154         else if (toketype == OROR)
 155             yylval.ival = OP_ORASSIGN;
 156         toketype = ASSIGNOP;
 157     }
 158     return toketype;
 159 }
 160
 161 static void
 162 no_op(what, s)
 163 char *what;
 164 char *s;
 165 {
 166     char *oldbp = bufptr;
 167     bool is_first = (oldbufptr == linestart);
 168
 169     bufptr = s;
 170     yywarn(form("%s found where operator expected", what));
 171     if (is_first)
 172         warn("\t(Missing semicolon on previous line?)\n");
 173     else if (oldoldbufptr && isIDFIRST(*oldoldbufptr)) {
 174         char *t;
 175         for (t = oldoldbufptr; *t && (isALNUM(*t) || *t == ':'); t++) ;
 176         if (t < bufptr && isSPACE(*t))
 177             warn("\t(Do you need to predeclare %.*s?)\n",
 178                 t - oldoldbufptr, oldoldbufptr);
 179
 180     }
 181     else
 182         warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
 183     bufptr = oldbp;
 184 }
 185
 186 static void
 187 missingterm(s)
 188 char *s;
 189 {
 190     char tmpbuf[3];
 191     char q;
 192     if (s) {
 193         char *nl = strrchr(s,'\n');
 194         if (nl)
 195             *nl = '\0';
 196     }
 197     else if (multi_close < 32 || multi_close == 127) {
 198         *tmpbuf = '^';
 199         tmpbuf[1] = toCTRL(multi_close);
 200         s = "\\n";
 201         tmpbuf[2] = '\0';
 202         s = tmpbuf;
 203     }
 204     else {
 205         *tmpbuf = multi_close;
 206         tmpbuf[1] = '\0';
 207         s = tmpbuf;
 208     }
 209     q = strchr(s,'"') ? '\'' : '"';
 210     croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
 211 }
 212
 213 void
 214 deprecate(s)
 215 char *s;
 216 {
 217     if (dowarn)
 218         warn("Use of %s is deprecated", s);
 219 }
 220
 221 static void
 222 depcom()
 223 {
 224     deprecate("comma-less variable list");
 225 }
 226
 227 void
 228 lex_start(line)
 229 SV *line;
 230 {
 231     dTHR;
 232     char *s;
 233     STRLEN len;
 234
 235     SAVEI32(lex_dojoin);
 236     SAVEI32(lex_brackets);
 237     SAVEI32(lex_fakebrack);
 238     SAVEI32(lex_casemods);
 239     SAVEI32(lex_starts);
 240     SAVEI32(lex_state);
 241     SAVESPTR(lex_inpat);
 242     SAVEI32(lex_inwhat);
 243     SAVEI16(curcop->cop_line);
 244     SAVEPPTR(bufptr);
 245     SAVEPPTR(bufend);
 246     SAVEPPTR(oldbufptr);
 247     SAVEPPTR(oldoldbufptr);
 248     SAVEPPTR(linestart);
 249     SAVESPTR(linestr);
 250     SAVEPPTR(lex_brackstack);
 251     SAVEPPTR(lex_casestack);
 252     SAVEDESTRUCTOR(restore_rsfp, rsfp);
 253
 254     lex_state = LEX_NORMAL;
 255     lex_defer = 0;
 256     expect = XSTATE;
 257     lex_brackets = 0;
 258     lex_fakebrack = 0;
 259     New(899, lex_brackstack, 120, char);
 260     New(899, lex_casestack, 12, char);
 261     SAVEFREEPV(lex_brackstack);
 262     SAVEFREEPV(lex_casestack);
 263     lex_casemods = 0;
 264     *lex_casestack = '\0';
 265     lex_dojoin = 0;
 266     lex_starts = 0;
 267     if (lex_stuff)
 268         SvREFCNT_dec(lex_stuff);
 269     lex_stuff = Nullsv;
 270     if (lex_repl)
 271         SvREFCNT_dec(lex_repl);
 272     lex_repl = Nullsv;
 273     lex_inpat = 0;
 274     lex_inwhat = 0;
 275     linestr = line;
 276     if (SvREADONLY(linestr))
 277         linestr = sv_2mortal(newSVsv(linestr));
 278     s = SvPV(linestr, len);
 279     if (len && s[len-1] != ';') {
 280         if (!(SvFLAGS(linestr) & SVs_TEMP))
 281             linestr = sv_2mortal(newSVsv(linestr));
 282         sv_catpvn(linestr, "\n;", 2);
 283     }
 284     SvTEMP_off(linestr);
 285     oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
 286     bufend = bufptr + SvCUR(linestr);
 287     SvREFCNT_dec(rs);
 288     rs = newSVpv("\n", 1);
 289     rsfp = 0;
 290 }
 291
 292 void
 293 lex_end()
 294 {
 295     doextract = FALSE;
 296 }
 297
 298 static void
 299 restore_rsfp(f)
 300 void *f;
 301 {
 302     PerlIO *fp = (PerlIO*)f;
 303
 304     if (rsfp == PerlIO_stdin())
 305         PerlIO_clearerr(rsfp);
 306     else if (rsfp && (rsfp != fp))
 307         PerlIO_close(rsfp);
 308     rsfp = fp;
 309 }
 310
 311 static void
 312 incline(s)
 313 char *s;
 314 {
 315     dTHR;
 316     char *t;
 317     char *n;
 318     char ch;
 319     int sawline = 0;
 320
 321     curcop->cop_line++;
 322     if (*s++ != '#')
 323         return;
 324     while (*s == ' ' || *s == '\t') s++;
 325     if (strnEQ(s, "line ", 5)) {
 326         s += 5;
 327         sawline = 1;
 328     }
 329     if (!isDIGIT(*s))
 330         return;
 331     n = s;
 332     while (isDIGIT(*s))
 333         s++;
 334     while (*s == ' ' || *s == '\t')
 335         s++;
 336     if (*s == '"' && (t = strchr(s+1, '"')))
 337         s++;
 338     else {
 339         if (!sawline)
 340             return;             /* false alarm */
 341         for (t = s; !isSPACE(*t); t++) ;
 342     }
 343     ch = *t;
 344     *t = '\0';
 345     if (t - s > 0)
 346         curcop->cop_filegv = gv_fetchfile(s);
 347     else
 348         curcop->cop_filegv = gv_fetchfile(origfilename);
 349     *t = ch;
 350     curcop->cop_line = atoi(n)-1;
 351 }
 352
 353 static char *
 354 skipspace(s)
 355 register char *s;
 356 {
 357     dTHR;
 358     if (lex_formbrack && lex_brackets <= lex_formbrack) {
 359         while (s < bufend && (*s == ' ' || *s == '\t'))
 360             s++;
 361         return s;
 362     }
 363     for (;;) {
 364         STRLEN prevlen;
 365         while (s < bufend && isSPACE(*s))
 366             s++;
 367         if (s < bufend && *s == '#') {
 368             while (s < bufend && *s != '\n')
 369                 s++;
 370             if (s < bufend)
 371                 s++;
 372         }
 373         if (s < bufend || !rsfp || lex_state != LEX_NORMAL)
 374             return s;
 375         if ((s = filter_gets(linestr, rsfp, (prevlen = SvCUR(linestr)))) == Nullch) {
 376             if (minus_n || minus_p) {
 377                 sv_setpv(linestr,minus_p ?
 378                          ";}continue{print or die qq(-p destination: $!\\n)" :
 379                          "");
 380                 sv_catpv(linestr,";}");
 381                 minus_n = minus_p = 0;
 382             }
 383             else
 384                 sv_setpv(linestr,";");
 385             oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
 386             bufend = SvPVX(linestr) + SvCUR(linestr);
 387             if (preprocess && !in_eval)
 388                 (void)my_pclose(rsfp);
 389             else if ((PerlIO*)rsfp == PerlIO_stdin())
 390                 PerlIO_clearerr(rsfp);
 391             else
 392                 (void)PerlIO_close(rsfp);
 393             if (e_fp == rsfp)
 394                 e_fp = Nullfp;
 395             rsfp = Nullfp;
 396             return s;
 397         }
 398         linestart = bufptr = s + prevlen;
 399         bufend = s + SvCUR(linestr);
 400         s = bufptr;
 401         incline(s);
 402         if (PERLDB_LINE && curstash != debstash) {
 403             SV *sv = NEWSV(85,0);
 404
 405             sv_upgrade(sv, SVt_PVMG);
 406             sv_setpvn(sv,bufptr,bufend-bufptr);
 407             av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
 408         }
 409     }
 410 }
 411
 412 static void
 413 check_uni() {
 414     char *s;
 415     char ch;
 416     char *t;
 417
 418     if (oldoldbufptr != last_uni)
 419         return;
 420     while (isSPACE(*last_uni))
 421         last_uni++;
 422     for (s = last_uni; isALNUM(*s) || *s == '-'; s++) ;
 423     if ((t = strchr(s, '(')) && t < bufptr)
 424         return;
 425     ch = *s;
 426     *s = '\0';
 427     warn("Warning: Use of \"%s\" without parens is ambiguous", last_uni);
 428     *s = ch;
 429 }
 430
 431 #ifdef CRIPPLED_CC
 432
 433 #undef UNI
 434 #define UNI(f) return uni(f,s)
 435
 436 static int
 437 uni(f,s)
 438 I32 f;
 439 char *s;
 440 {
 441     yylval.ival = f;
 442     expect = XTERM;
 443     bufptr = s;
 444     last_uni = oldbufptr;
 445     last_lop_op = f;
 446     if (*s == '(')
 447         return FUNC1;
 448     s = skipspace(s);
 449     if (*s == '(')
 450         return FUNC1;
 451     else
 452         return UNIOP;
 453 }
 454
 455 #endif /* CRIPPLED_CC */
 456
 457 #define LOP(f,x) return lop(f,x,s)
 458
 459 static I32
 460 lop
 461 #ifdef CAN_PROTOTYPE
 462    (I32 f, expectation x, char *s)
 463 #else
 464    (f,x,s)
 465 I32 f;
 466 expectation x;
 467 char *s;
 468 #endif /* CAN_PROTOTYPE */
 469 {
 470     dTHR;
 471     yylval.ival = f;
 472     CLINE;
 473     expect = x;
 474     bufptr = s;
 475     last_lop = oldbufptr;
 476     last_lop_op = f;
 477     if (nexttoke)
 478         return LSTOP;
 479     if (*s == '(')
 480         return FUNC;
 481     s = skipspace(s);
 482     if (*s == '(')
 483         return FUNC;
 484     else
 485         return LSTOP;
 486 }
 487
 488 static void
 489 force_next(type)
 490 I32 type;
 491 {
 492     nexttype[nexttoke] = type;
 493     nexttoke++;
 494     if (lex_state != LEX_KNOWNEXT) {
 495         lex_defer = lex_state;
 496         lex_expect = expect;
 497         lex_state = LEX_KNOWNEXT;
 498     }
 499 }
 500
 501 static char *
 502 force_word(start,token,check_keyword,allow_pack,allow_tick)
 503 register char *start;
 504 int token;
 505 int check_keyword;
 506 int allow_pack;
 507 int allow_tick;
 508 {
 509     register char *s;
 510     STRLEN len;
 511
 512     start = skipspace(start);
 513     s = start;
 514     if (isIDFIRST(*s) ||
 515         (allow_pack && *s == ':') ||
 516         (allow_tick && *s == '\'') )
 517     {
 518         s = scan_word(s, tokenbuf, sizeof tokenbuf, allow_pack, &len);
 519         if (check_keyword && keyword(tokenbuf, len))
 520             return start;
 521         if (token == METHOD) {
 522             s = skipspace(s);
 523             if (*s == '(')
 524                 expect = XTERM;
 525             else {
 526                 expect = XOPERATOR;
 527                 force_next(')');
 528                 force_next('(');
 529             }
 530         }
 531         nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(tokenbuf,0));
 532         nextval[nexttoke].opval->op_private |= OPpCONST_BARE;
 533         force_next(token);
 534     }
 535     return s;
 536 }
 537
 538 static void
 539 force_ident(s, kind)
 540 register char *s;
 541 int kind;
 542 {
 543     if (s && *s) {
 544         OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
 545         nextval[nexttoke].opval = o;
 546         force_next(WORD);
 547         if (kind) {
 548             dTHR;               /* just for in_eval */
 549             o->op_private = OPpCONST_ENTERED;
 550             /* XXX see note in pp_entereval() for why we forgo typo
 551                warnings if the symbol must be introduced in an eval.
 552                GSAR 96-10-12 */
 553             gv_fetchpv(s, in_eval ? GV_ADDMULTI : TRUE,
 554                 kind == '$' ? SVt_PV :
 555                 kind == '@' ? SVt_PVAV :
 556                 kind == '%' ? SVt_PVHV :
 557                               SVt_PVGV
 558                 );
 559         }
 560     }
 561 }
 562
 563 static char *
 564 force_version(s)
 565 char *s;
 566 {
 567     OP *version = Nullop;
 568
 569     s = skipspace(s);
 570
 571     /* default VERSION number -- GBARR */
 572
 573     if(isDIGIT(*s)) {
 574         char *d;
 575         int c;
 576         for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
 577         if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
 578             s = scan_num(s);
 579             /* real VERSION number -- GBARR */
 580             version = yylval.opval;
 581         }
 582     }
 583
 584     /* NOTE: The parser sees the package name and the VERSION swapped */
 585     nextval[nexttoke].opval = version;
 586     force_next(WORD);
 587
 588     return (s);
 589 }
 590
 591 static SV *
 592 q(sv)
 593 SV *sv;
 594 {
 595     register char *s;
 596     register char *send;
 597     register char *d;
 598     STRLEN len;
 599
 600     if (!SvLEN(sv))
 601         return sv;
 602
 603     s = SvPV_force(sv, len);
 604     if (SvIVX(sv) == -1)
 605         return sv;
 606     send = s + len;
 607     while (s < send && *s != '\\')
 608         s++;
 609     if (s == send)
 610         return sv;
 611     d = s;
 612     while (s < send) {
 613         if (*s == '\\') {
 614             if (s + 1 < send && (s[1] == '\\'))
 615                 s++;            /* all that, just for this */
 616         }
 617         *d++ = *s++;
 618     }
 619     *d = '\0';
 620     SvCUR_set(sv, d - SvPVX(sv));
 621
 622     return sv;
 623 }
 624
 625 static I32
 626 sublex_start()
 627 {
 628     register I32 op_type = yylval.ival;
 629
 630     if (op_type == OP_NULL) {
 631         yylval.opval = lex_op;
 632         lex_op = Nullop;
 633         return THING;
 634     }
 635     if (op_type == OP_CONST || op_type == OP_READLINE) {
 636         SV *sv = q(lex_stuff);
 637         STRLEN len;
 638         char *p = SvPV(sv, len);
 639         yylval.opval = (OP*)newSVOP(op_type, 0, newSVpv(p, len));
 640         SvREFCNT_dec(sv);
 641         lex_stuff = Nullsv;
 642         return THING;
 643     }
 644
 645     sublex_info.super_state = lex_state;
 646     sublex_info.sub_inwhat = op_type;
 647     sublex_info.sub_op = lex_op;
 648     lex_state = LEX_INTERPPUSH;
 649
 650     expect = XTERM;
 651     if (lex_op) {
 652         yylval.opval = lex_op;
 653         lex_op = Nullop;
 654         return PMFUNC;
 655     }
 656     else
 657         return FUNC;
 658 }
 659
 660 static I32
 661 sublex_push()
 662 {
 663     dTHR;
 664     push_scope();
 665
 666     lex_state = sublex_info.super_state;
 667     SAVEI32(lex_dojoin);
 668     SAVEI32(lex_brackets);
 669     SAVEI32(lex_fakebrack);
 670     SAVEI32(lex_casemods);
 671     SAVEI32(lex_starts);
 672     SAVEI32(lex_state);
 673     SAVESPTR(lex_inpat);
 674     SAVEI32(lex_inwhat);
 675     SAVEI16(curcop->cop_line);
 676     SAVEPPTR(bufptr);
 677     SAVEPPTR(oldbufptr);
 678     SAVEPPTR(oldoldbufptr);
 679     SAVEPPTR(linestart);
 680     SAVESPTR(linestr);
 681     SAVEPPTR(lex_brackstack);
 682     SAVEPPTR(lex_casestack);
 683
 684     linestr = lex_stuff;
 685     lex_stuff = Nullsv;
 686
 687     bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
 688     bufend += SvCUR(linestr);
 689     SAVEFREESV(linestr);
 690
 691     lex_dojoin = FALSE;
 692     lex_brackets = 0;
 693     lex_fakebrack = 0;
 694     New(899, lex_brackstack, 120, char);
 695     New(899, lex_casestack, 12, char);
 696     SAVEFREEPV(lex_brackstack);
 697     SAVEFREEPV(lex_casestack);
 698     lex_casemods = 0;
 699     *lex_casestack = '\0';
 700     lex_starts = 0;
 701     lex_state = LEX_INTERPCONCAT;
 702     curcop->cop_line = multi_start;
 703
 704     lex_inwhat = sublex_info.sub_inwhat;
 705     if (lex_inwhat == OP_MATCH || lex_inwhat == OP_SUBST)
 706         lex_inpat = sublex_info.sub_op;
 707     else
 708         lex_inpat = Nullop;
 709
 710     return '(';
 711 }
 712
 713 static I32
 714 sublex_done()
 715 {
 716     if (!lex_starts++) {
 717         expect = XOPERATOR;
 718         yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
 719         return THING;
 720     }
 721
 722     if (lex_casemods) {         /* oops, we've got some unbalanced parens */
 723         lex_state = LEX_INTERPCASEMOD;
 724         return yylex();
 725     }
 726
 727     /* Is there a right-hand side to take care of? */
 728     if (lex_repl && (lex_inwhat == OP_SUBST || lex_inwhat == OP_TRANS)) {
 729         linestr = lex_repl;
 730         lex_inpat = 0;
 731         bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
 732         bufend += SvCUR(linestr);
 733         SAVEFREESV(linestr);
 734         lex_dojoin = FALSE;
 735         lex_brackets = 0;
 736         lex_fakebrack = 0;
 737         lex_casemods = 0;
 738         *lex_casestack = '\0';
 739         lex_starts = 0;
 740         if (SvCOMPILED(lex_repl)) {
 741             lex_state = LEX_INTERPNORMAL;
 742             lex_starts++;
 743         }
 744         else
 745             lex_state = LEX_INTERPCONCAT;
 746         lex_repl = Nullsv;
 747         return ',';
 748     }
 749     else {
 750         pop_scope();
 751         bufend = SvPVX(linestr);
 752         bufend += SvCUR(linestr);
 753         expect = XOPERATOR;
 754         return ')';
 755     }
 756 }
 757
 758 static char *
 759 scan_const(start)
 760 char *start;
 761 {
 762     register char *send = bufend;
 763     SV *sv = NEWSV(93, send - start);
 764     register char *s = start;
 765     register char *d = SvPVX(sv);
 766     bool dorange = FALSE;
 767     I32 len;
 768     char *leaveit =
 769         lex_inpat
 770             ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#"
 771             : (lex_inwhat & OP_TRANS)
 772                 ? ""
 773                 : "";
 774
 775     while (s < send || dorange) {
 776         if (lex_inwhat == OP_TRANS) {
 777             if (dorange) {
 778                 I32 i;
 779                 I32 max;
 780                 i = d - SvPVX(sv);
 781                 SvGROW(sv, SvLEN(sv) + 256);
 782                 d = SvPVX(sv) + i;
 783                 d -= 2;
 784                 max = (U8)d[1];
 785                 for (i = (U8)*d; i <= max; i++)
 786                     *d++ = i;
 787                 dorange = FALSE;
 788                 continue;
 789             }
 790             else if (*s == '-' && s+1 < send  && s != start) {
 791                 dorange = TRUE;
 792                 s++;
 793             }
 794         }
 795         else if (*s == '(' && lex_inpat && s[1] == '?' && s[2] == '#') {
 796             while (s < send && *s != ')')
 797                 *d++ = *s++;
 798         }
 799         else if (*s == '#' && lex_inpat &&
 800           ((PMOP*)lex_inpat)->op_pmflags & PMf_EXTENDED) {
 801             while (s+1 < send && *s != '\n')
 802                 *d++ = *s++;
 803         }
 804         else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
 805             break;
 806         else if (*s == '$') {
 807             if (!lex_inpat)     /* not a regexp, so $ must be var */
 808                 break;
 809             if (s + 1 < send && !strchr(")| \n\t", s[1]))
 810                 break;          /* in regexp, $ might be tail anchor */
 811         }
 812         if (*s == '\\' && s+1 < send) {
 813             s++;
 814             if (*s && strchr(leaveit, *s)) {
 815                 *d++ = '\\';
 816                 *d++ = *s++;
 817                 continue;
 818             }
 819             if (lex_inwhat == OP_SUBST && !lex_inpat &&
 820                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
 821             {
 822                 if (dowarn)
 823                     warn("\\%c better written as $%c", *s, *s);
 824                 *--s = '$';
 825                 break;
 826             }
 827             if (lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
 828                 --s;
 829                 break;
 830             }
 831             switch (*s) {
 832             case '-':
 833                 if (lex_inwhat == OP_TRANS) {
 834                     *d++ = *s++;
 835                     continue;
 836                 }
 837                 /* FALL THROUGH */
 838             default:
 839                 *d++ = *s++;
 840                 continue;
 841             case '0': case '1': case '2': case '3':
 842             case '4': case '5': case '6': case '7':
 843                 *d++ = scan_oct(s, 3, &len);
 844                 s += len;
 845                 continue;
 846             case 'x':
 847                 *d++ = scan_hex(++s, 2, &len);
 848                 s += len;
 849                 continue;
 850             case 'c':
 851                 s++;
 852                 len = *s++;
 853                 *d++ = toCTRL(len);
 854                 continue;
 855             case 'b':
 856                 *d++ = '\b';
 857                 break;
 858             case 'n':
 859                 *d++ = '\n';
 860                 break;
 861             case 'r':
 862                 *d++ = '\r';
 863                 break;
 864             case 'f':
 865                 *d++ = '\f';
 866                 break;
 867             case 't':
 868                 *d++ = '\t';
 869                 break;
 870             case 'e':
 871                 *d++ = '\033';
 872                 break;
 873             case 'a':
 874                 *d++ = '\007';
 875                 break;
 876             }
 877             s++;
 878             continue;
 879         }
 880         *d++ = *s++;
 881     }
 882     *d = '\0';
 883     SvCUR_set(sv, d - SvPVX(sv));
 884     SvPOK_on(sv);
 885
 886     if (SvCUR(sv) + 5 < SvLEN(sv)) {
 887         SvLEN_set(sv, SvCUR(sv) + 1);
 888         Renew(SvPVX(sv), SvLEN(sv), char);
 889     }
 890     if (s > bufptr)
 891         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
 892     else
 893         SvREFCNT_dec(sv);
 894     return s;
 895 }
 896
 897 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
 898 static int
 899 intuit_more(s)
 900 register char *s;
 901 {
 902     if (lex_brackets)
 903         return TRUE;
 904     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
 905         return TRUE;
 906     if (*s != '{' && *s != '[')
 907         return FALSE;
 908     if (!lex_inpat)
 909         return TRUE;
 910
 911     /* In a pattern, so maybe we have {n,m}. */
 912     if (*s == '{') {
 913         s++;
 914         if (!isDIGIT(*s))
 915             return TRUE;
 916         while (isDIGIT(*s))
 917             s++;
 918         if (*s == ',')
 919             s++;
 920         while (isDIGIT(*s))
 921             s++;
 922         if (*s == '}')
 923             return FALSE;
 924         return TRUE;
 925
 926     }
 927
 928     /* On the other hand, maybe we have a character class */
 929
 930     s++;
 931     if (*s == ']' || *s == '^')
 932         return FALSE;
 933     else {
 934         int weight = 2;         /* let's weigh the evidence */
 935         char seen[256];
 936         unsigned char un_char = 0, last_un_char;
 937         char *send = strchr(s,']');
 938         char tmpbuf[sizeof tokenbuf * 4];
 939
 940         if (!send)              /* has to be an expression */
 941             return TRUE;
 942
 943         Zero(seen,256,char);
 944         if (*s == '$')
 945             weight -= 3;
 946         else if (isDIGIT(*s)) {
 947             if (s[1] != ']') {
 948                 if (isDIGIT(s[1]) && s[2] == ']')
 949                     weight -= 10;
 950             }
 951             else
 952                 weight -= 100;
 953         }
 954         for (; s < send; s++) {
 955             last_un_char = un_char;
 956             un_char = (unsigned char)*s;
 957             switch (*s) {
 958             case '@':
 959             case '&':
 960             case '$':
 961                 weight -= seen[un_char] * 10;
 962                 if (isALNUM(s[1])) {
 963                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
 964                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
 965                         weight -= 100;
 966                     else
 967                         weight -= 10;
 968                 }
 969                 else if (*s == '$' && s[1] &&
 970                   strchr("[#!%*<>()-=",s[1])) {
 971                     if (/*{*/ strchr("])} =",s[2]))
 972                         weight -= 10;
 973                     else
 974                         weight -= 1;
 975                 }
 976                 break;
 977             case '\\':
 978                 un_char = 254;
 979                 if (s[1]) {
 980                     if (strchr("wds]",s[1]))
 981                         weight += 100;
 982                     else if (seen['\''] || seen['"'])
 983                         weight += 1;
 984                     else if (strchr("rnftbxcav",s[1]))
 985                         weight += 40;
 986                     else if (isDIGIT(s[1])) {
 987                         weight += 40;
 988                         while (s[1] && isDIGIT(s[1]))
 989                             s++;
 990                     }
 991                 }
 992                 else
 993                     weight += 100;
 994                 break;
 995             case '-':
 996                 if (s[1] == '\\')
 997                     weight += 50;
 998                 if (strchr("aA01! ",last_un_char))
 999                     weight += 30;
1000                 if (strchr("zZ79~",s[1]))
1001                     weight += 30;
1002                 break;
1003             default:
1004                 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1005                         isALPHA(*s) && s[1] && isALPHA(s[1])) {
1006                     char *d = tmpbuf;
1007                     while (isALPHA(*s))
1008                         *d++ = *s++;
1009                     *d = '\0';
1010                     if (keyword(tmpbuf, d - tmpbuf))
1011                         weight -= 150;
1012                 }
1013                 if (un_char == last_un_char + 1)
1014                     weight += 5;
1015                 weight -= seen[un_char];
1016                 break;
1017             }
1018             seen[un_char]++;
1019         }
1020         if (weight >= 0)        /* probably a character class */
1021             return FALSE;
1022     }
1023
1024     return TRUE;
1025 }
1026
1027 static int
1028 intuit_method(start,gv)
1029 char *start;
1030 GV *gv;
1031 {
1032     char *s = start + (*start == '$');
1033     char tmpbuf[sizeof tokenbuf];
1034     STRLEN len;
1035     GV* indirgv;
1036
1037     if (gv) {
1038         if (GvIO(gv))
1039             return 0;
1040         if (!GvCVu(gv))
1041             gv = 0;
1042     }
1043     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1044     if (*start == '$') {
1045         if (gv || last_lop_op == OP_PRINT || isUPPER(*tokenbuf))
1046             return 0;
1047         s = skipspace(s);
1048         bufptr = start;
1049         expect = XREF;
1050         return *s == '(' ? FUNCMETH : METHOD;
1051     }
1052     if (!keyword(tmpbuf, len)) {
1053         indirgv = gv_fetchpv(tmpbuf,FALSE, SVt_PVCV);
1054         if (indirgv && GvCVu(indirgv))
1055             return 0;
1056         /* filehandle or package name makes it a method */
1057         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1058             s = skipspace(s);
1059             if ((bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1060                 return 0;       /* no assumptions -- "=>" quotes bearword */
1061             nextval[nexttoke].opval =
1062                 (OP*)newSVOP(OP_CONST, 0,
1063                             newSVpv(tmpbuf,0));
1064             nextval[nexttoke].opval->op_private =
1065                 OPpCONST_BARE;
1066             expect = XTERM;
1067             force_next(WORD);
1068             bufptr = s;
1069             return *s == '(' ? FUNCMETH : METHOD;
1070         }
1071     }
1072     return 0;
1073 }
1074
1075 static char*
1076 incl_perldb()
1077 {
1078     if (perldb) {
1079         char *pdb = getenv("PERL5DB");
1080
1081         if (pdb)
1082             return pdb;
1083         return "BEGIN { require 'perl5db.pl' }";
1084     }
1085     return "";
1086 }
1087
1088
1089 /* Encoded script support. filter_add() effectively inserts a
1090  * 'pre-processing' function into the current source input stream.
1091  * Note that the filter function only applies to the current source file
1092  * (e.g., it will not affect files 'require'd or 'use'd by this one).
1093  *
1094  * The datasv parameter (which may be NULL) can be used to pass
1095  * private data to this instance of the filter. The filter function
1096  * can recover the SV using the FILTER_DATA macro and use it to
1097  * store private buffers and state information.
1098  *
1099  * The supplied datasv parameter is upgraded to a PVIO type
1100  * and the IoDIRP field is used to store the function pointer.
1101  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1102  * private use must be set using malloc'd pointers.
1103  */
1104 static int filter_debug = 0;
1105
1106 SV *
1107 filter_add(funcp, datasv)
1108     filter_t funcp;
1109     SV *datasv;
1110 {
1111     if (!funcp){ /* temporary handy debugging hack to be deleted */
1112         filter_debug = atoi((char*)datasv);
1113         return NULL;
1114     }
1115     if (!rsfp_filters)
1116         rsfp_filters = newAV();
1117     if (!datasv)
1118         datasv = newSV(0);
1119     if (!SvUPGRADE(datasv, SVt_PVIO))
1120         die("Can't upgrade filter_add data to SVt_PVIO");
1121     IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1122     if (filter_debug)
1123         warn("filter_add func %p (%s)", funcp, SvPV(datasv,na));
1124     av_unshift(rsfp_filters, 1);
1125     av_store(rsfp_filters, 0, datasv) ;
1126     return(datasv);
1127 }
1128
1129
1130 /* Delete most recently added instance of this filter function. */
1131 void
1132 filter_del(funcp)
1133     filter_t funcp;
1134 {
1135     if (filter_debug)
1136         warn("filter_del func %p", funcp);
1137     if (!rsfp_filters || AvFILL(rsfp_filters)<0)
1138         return;
1139     /* if filter is on top of stack (usual case) just pop it off */
1140     if (IoDIRP(FILTER_DATA(0)) == (void*)funcp){
1141         /* sv_free(av_pop(rsfp_filters)); */
1142         sv_free(av_shift(rsfp_filters));
1143
1144         return;
1145     }
1146     /* we need to search for the correct entry and clear it     */
1147     die("filter_del can only delete in reverse order (currently)");
1148 }
1149
1150
1151 /* Invoke the n'th filter function for the current rsfp.         */
1152 I32
1153 filter_read(idx, buf_sv, maxlen)
1154     int idx;
1155     SV *buf_sv;
1156     int maxlen;         /* 0 = read one text line */
1157 {
1158     filter_t funcp;
1159     SV *datasv = NULL;
1160
1161     if (!rsfp_filters)
1162         return -1;
1163     if (idx > AvFILL(rsfp_filters)){       /* Any more filters? */
1164         /* Provide a default input filter to make life easy.    */
1165         /* Note that we append to the line. This is handy.      */
1166         if (filter_debug)
1167             warn("filter_read %d: from rsfp\n", idx);
1168         if (maxlen) {
1169             /* Want a block */
1170             int len ;
1171             int old_len = SvCUR(buf_sv) ;
1172
1173             /* ensure buf_sv is large enough */
1174             SvGROW(buf_sv, old_len + maxlen) ;
1175             if ((len = PerlIO_read(rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1176                 if (PerlIO_error(rsfp))
1177                     return -1;          /* error */
1178                 else
1179                     return 0 ;          /* end of file */
1180             }
1181             SvCUR_set(buf_sv, old_len + len) ;
1182         } else {
1183             /* Want a line */
1184             if (sv_gets(buf_sv, rsfp, SvCUR(buf_sv)) == NULL) {
1185                 if (PerlIO_error(rsfp))
1186                     return -1;          /* error */
1187                 else
1188                     return 0 ;          /* end of file */
1189             }
1190         }
1191         return SvCUR(buf_sv);
1192     }
1193     /* Skip this filter slot if filter has been deleted */
1194     if ( (datasv = FILTER_DATA(idx)) == &sv_undef){
1195         if (filter_debug)
1196             warn("filter_read %d: skipped (filter deleted)\n", idx);
1197         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1198     }
1199     /* Get function pointer hidden within datasv        */
1200     funcp = (filter_t)IoDIRP(datasv);
1201     if (filter_debug)
1202         warn("filter_read %d: via function %p (%s)\n",
1203                 idx, funcp, SvPV(datasv,na));
1204     /* Call function. The function is expected to       */
1205     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
1206     /* Return: <0:error, =0:eof, >0:not eof             */
1207     return (*funcp)(idx, buf_sv, maxlen);
1208 }
1209
1210 static char *
1211 filter_gets(sv,fp, append)
1212 register SV *sv;
1213 register PerlIO *fp;
1214 STRLEN append;
1215 {
1216     if (rsfp_filters) {
1217
1218         if (!append)
1219             SvCUR_set(sv, 0);   /* start with empty line        */
1220         if (FILTER_READ(0, sv, 0) > 0)
1221             return ( SvPVX(sv) ) ;
1222         else
1223             return Nullch ;
1224     }
1225     else
1226         return (sv_gets(sv, fp, append));
1227
1228 }
1229
1230
1231 #ifdef DEBUGGING
1232     static char* exp_name[] =
1233         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1234 #endif
1235
1236 EXT int yychar;         /* last token */
1237
1238 int
1239 yylex()
1240 {
1241     dTHR;
1242     register char *s;
1243     register char *d;
1244     register I32 tmp;
1245     STRLEN len;
1246
1247     if (pending_ident) {
1248         char pit = pending_ident;
1249         pending_ident = 0;
1250
1251         if (in_my) {
1252             if (strchr(tokenbuf,':'))
1253                 croak(no_myglob,tokenbuf);
1254             yylval.opval = newOP(OP_PADANY, 0);
1255             yylval.opval->op_targ = pad_allocmy(tokenbuf);
1256             return PRIVATEREF;
1257         }
1258
1259         if (!strchr(tokenbuf,':')) {
1260 #ifdef USE_THREADS
1261             /* Check for single character per-thread magicals */
1262             if (tokenbuf[0] == '$' && tokenbuf[2] == '\0'
1263                 && (tmp = find_thread_magical(&tokenbuf[1])) != NOT_IN_PAD) {
1264                 yylval.opval = newOP(OP_SPECIFIC, 0);
1265                 yylval.opval->op_targ = tmp;
1266                 return PRIVATEREF;
1267             }
1268 #endif /* USE_THREADS */
1269             if ((tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) {
1270                 if (last_lop_op == OP_SORT &&
1271                     tokenbuf[0] == '$' &&
1272                     (tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
1273                     && !tokenbuf[2])
1274                 {
1275                     for (d = in_eval ? oldoldbufptr : linestart;
1276                          d < bufend && *d != '\n';
1277                          d++)
1278                     {
1279                         if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1280                             croak("Can't use \"my %s\" in sort comparison",
1281                                   tokenbuf);
1282                         }
1283                     }
1284                 }
1285
1286                 yylval.opval = newOP(OP_PADANY, 0);
1287                 yylval.opval->op_targ = tmp;
1288                 return PRIVATEREF;
1289             }
1290         }
1291
1292         /* Force them to make up their mind on "@foo". */
1293         if (pit == '@' && lex_state != LEX_NORMAL && !lex_brackets) {
1294             GV *gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV);
1295             if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1296                 yyerror(form("In string, %s now must be written as \\%s",
1297                              tokenbuf, tokenbuf));
1298         }
1299
1300         yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0));
1301         yylval.opval->op_private = OPpCONST_ENTERED;
1302         gv_fetchpv(tokenbuf+1, in_eval ? GV_ADDMULTI : TRUE,
1303                    ((tokenbuf[0] == '$') ? SVt_PV
1304                     : (tokenbuf[0] == '@') ? SVt_PVAV
1305                     : SVt_PVHV));
1306         return WORD;
1307     }
1308
1309     switch (lex_state) {
1310 #ifdef COMMENTARY
1311     case LEX_NORMAL:            /* Some compilers will produce faster */
1312     case LEX_INTERPNORMAL:      /* code if we comment these out. */
1313         break;
1314 #endif
1315
1316     case LEX_KNOWNEXT:
1317         nexttoke--;
1318         yylval = nextval[nexttoke];
1319         if (!nexttoke) {
1320             lex_state = lex_defer;
1321             expect = lex_expect;
1322             lex_defer = LEX_NORMAL;
1323         }
1324         return(nexttype[nexttoke]);
1325
1326     case LEX_INTERPCASEMOD:
1327 #ifdef DEBUGGING
1328         if (bufptr != bufend && *bufptr != '\\')
1329             croak("panic: INTERPCASEMOD");
1330 #endif
1331         if (bufptr == bufend || bufptr[1] == 'E') {
1332             char oldmod;
1333             if (lex_casemods) {
1334                 oldmod = lex_casestack[--lex_casemods];
1335                 lex_casestack[lex_casemods] = '\0';
1336                 if (bufptr != bufend && strchr("LUQ", oldmod)) {
1337                     bufptr += 2;
1338                     lex_state = LEX_INTERPCONCAT;
1339                 }
1340                 return ')';
1341             }
1342             if (bufptr != bufend)
1343                 bufptr += 2;
1344             lex_state = LEX_INTERPCONCAT;
1345             return yylex();
1346         }
1347         else {
1348             s = bufptr + 1;
1349             if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1350                 tmp = *s, *s = s[2], s[2] = tmp;        /* misordered... */
1351             if (strchr("LU", *s) &&
1352                 (strchr(lex_casestack, 'L') || strchr(lex_casestack, 'U')))
1353             {
1354                 lex_casestack[--lex_casemods] = '\0';
1355                 return ')';
1356             }
1357             if (lex_casemods > 10) {
1358                 char* newlb = Renew(lex_casestack, lex_casemods + 2, char);
1359                 if (newlb != lex_casestack) {
1360                     SAVEFREEPV(newlb);
1361                     lex_casestack = newlb;
1362                 }
1363             }
1364             lex_casestack[lex_casemods++] = *s;
1365             lex_casestack[lex_casemods] = '\0';
1366             lex_state = LEX_INTERPCONCAT;
1367             nextval[nexttoke].ival = 0;
1368             force_next('(');
1369             if (*s == 'l')
1370                 nextval[nexttoke].ival = OP_LCFIRST;
1371             else if (*s == 'u')
1372                 nextval[nexttoke].ival = OP_UCFIRST;
1373             else if (*s == 'L')
1374                 nextval[nexttoke].ival = OP_LC;
1375             else if (*s == 'U')
1376                 nextval[nexttoke].ival = OP_UC;
1377             else if (*s == 'Q')
1378                 nextval[nexttoke].ival = OP_QUOTEMETA;
1379             else
1380                 croak("panic: yylex");
1381             bufptr = s + 1;
1382             force_next(FUNC);
1383             if (lex_starts) {
1384                 s = bufptr;
1385                 lex_starts = 0;
1386                 Aop(OP_CONCAT);
1387             }
1388             else
1389                 return yylex();
1390         }
1391
1392     case LEX_INTERPPUSH:
1393         return sublex_push();
1394
1395     case LEX_INTERPSTART:
1396         if (bufptr == bufend)
1397             return sublex_done();
1398         expect = XTERM;
1399         lex_dojoin = (*bufptr == '@');
1400         lex_state = LEX_INTERPNORMAL;
1401         if (lex_dojoin) {
1402             nextval[nexttoke].ival = 0;
1403             force_next(',');
1404             force_ident("\"", '$');
1405             nextval[nexttoke].ival = 0;
1406             force_next('$');
1407             nextval[nexttoke].ival = 0;
1408             force_next('(');
1409             nextval[nexttoke].ival = OP_JOIN;   /* emulate join($", ...) */
1410             force_next(FUNC);
1411         }
1412         if (lex_starts++) {
1413             s = bufptr;
1414             Aop(OP_CONCAT);
1415         }
1416         return yylex();
1417
1418     case LEX_INTERPENDMAYBE:
1419         if (intuit_more(bufptr)) {
1420             lex_state = LEX_INTERPNORMAL;       /* false alarm, more expr */
1421             break;
1422         }
1423         /* FALL THROUGH */
1424
1425     case LEX_INTERPEND:
1426         if (lex_dojoin) {
1427             lex_dojoin = FALSE;
1428             lex_state = LEX_INTERPCONCAT;
1429             return ')';
1430         }
1431         /* FALLTHROUGH */
1432     case LEX_INTERPCONCAT:
1433 #ifdef DEBUGGING
1434         if (lex_brackets)
1435             croak("panic: INTERPCONCAT");
1436 #endif
1437         if (bufptr == bufend)
1438             return sublex_done();
1439
1440         if (SvIVX(linestr) == '\'') {
1441             SV *sv = newSVsv(linestr);
1442             if (!lex_inpat)
1443                 sv = q(sv);
1444             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1445             s = bufend;
1446         }
1447         else {
1448             s = scan_const(bufptr);
1449             if (*s == '\\')
1450                 lex_state = LEX_INTERPCASEMOD;
1451             else
1452                 lex_state = LEX_INTERPSTART;
1453         }
1454
1455         if (s != bufptr) {
1456             nextval[nexttoke] = yylval;
1457             expect = XTERM;
1458             force_next(THING);
1459             if (lex_starts++)
1460                 Aop(OP_CONCAT);
1461             else {
1462                 bufptr = s;
1463                 return yylex();
1464             }
1465         }
1466
1467         return yylex();
1468     case LEX_FORMLINE:
1469         lex_state = LEX_NORMAL;
1470         s = scan_formline(bufptr);
1471         if (!lex_formbrack)
1472             goto rightbracket;
1473         OPERATOR(';');
1474     }
1475
1476     s = bufptr;
1477     oldoldbufptr = oldbufptr;
1478     oldbufptr = s;
1479     DEBUG_p( {
1480         PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[expect], s);
1481     } )
1482
1483   retry:
1484     switch (*s) {
1485     default:
1486         croak("Unrecognized character \\%03o", *s & 255);
1487     case 4:
1488     case 26:
1489         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
1490     case 0:
1491         if (!rsfp) {
1492             last_uni = 0;
1493             last_lop = 0;
1494             if (lex_brackets)
1495                 yyerror("Missing right bracket");
1496             TOKEN(0);
1497         }
1498         if (s++ < bufend)
1499             goto retry;                 /* ignore stray nulls */
1500         last_uni = 0;
1501         last_lop = 0;
1502         if (!in_eval && !preambled) {
1503             preambled = TRUE;
1504             sv_setpv(linestr,incl_perldb());
1505             if (SvCUR(linestr))
1506                 sv_catpv(linestr,";");
1507             if (preambleav){
1508                 while(AvFILL(preambleav) >= 0) {
1509                     SV *tmpsv = av_shift(preambleav);
1510                     sv_catsv(linestr, tmpsv);
1511                     sv_catpv(linestr, ";");
1512                     sv_free(tmpsv);
1513                 }
1514                 sv_free((SV*)preambleav);
1515                 preambleav = NULL;
1516             }
1517             if (minus_n || minus_p) {
1518                 sv_catpv(linestr, "LINE: while (<>) {");
1519                 if (minus_l)
1520                     sv_catpv(linestr,"chomp;");
1521                 if (minus_a) {
1522                     GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1523                     if (gv)
1524                         GvIMPORTED_AV_on(gv);
1525                     if (minus_F) {
1526                         if (strchr("/'\"", *splitstr)
1527                               && strchr(splitstr + 1, *splitstr))
1528                             sv_catpvf(linestr, "@F=split(%s);", splitstr);
1529                         else {
1530                             char delim;
1531                             s = "'~#\200\1'"; /* surely one char is unused...*/
1532                             while (s[1] && strchr(splitstr, *s))  s++;
1533                             delim = *s;
1534                             sv_catpvf(linestr, "@F=split(%s%c",
1535                                       "q" + (delim == '\''), delim);
1536                             for (s = splitstr; *s; s++) {
1537                                 if (*s == '\\')
1538                                     sv_catpvn(linestr, "\\", 1);
1539                                 sv_catpvn(linestr, s, 1);
1540                             }
1541                             sv_catpvf(linestr, "%c);", delim);
1542                         }
1543                     }
1544                     else
1545                         sv_catpv(linestr,"@F=split(' ');");
1546                 }
1547             }
1548             sv_catpv(linestr, "\n");
1549             oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1550             bufend = SvPVX(linestr) + SvCUR(linestr);
1551             if (PERLDB_LINE && curstash != debstash) {
1552                 SV *sv = NEWSV(85,0);
1553
1554                 sv_upgrade(sv, SVt_PVMG);
1555                 sv_setsv(sv,linestr);
1556                 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1557             }
1558             goto retry;
1559         }
1560         do {
1561             if ((s = filter_gets(linestr, rsfp, 0)) == Nullch) {
1562               fake_eof:
1563                 if (rsfp) {
1564                     if (preprocess && !in_eval)
1565                         (void)my_pclose(rsfp);
1566                     else if ((PerlIO *)rsfp == PerlIO_stdin())
1567                         PerlIO_clearerr(rsfp);
1568                     else
1569                         (void)PerlIO_close(rsfp);
1570                     if (e_fp == rsfp)
1571                         e_fp = Nullfp;
1572                     rsfp = Nullfp;
1573                 }
1574                 if (!in_eval && (minus_n || minus_p)) {
1575                     sv_setpv(linestr,minus_p ? ";}continue{print" : "");
1576                     sv_catpv(linestr,";}");
1577                     oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1578                     bufend = SvPVX(linestr) + SvCUR(linestr);
1579                     minus_n = minus_p = 0;
1580                     goto retry;
1581                 }
1582                 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1583                 sv_setpv(linestr,"");
1584                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
1585             }
1586             if (doextract) {
1587                 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1588                     doextract = FALSE;
1589
1590                 /* Incest with pod. */
1591                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1592                     sv_setpv(linestr, "");
1593                     oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1594                     bufend = SvPVX(linestr) + SvCUR(linestr);
1595                     doextract = FALSE;
1596                 }
1597             }
1598             incline(s);
1599         } while (doextract);
1600         oldoldbufptr = oldbufptr = bufptr = linestart = s;
1601         if (PERLDB_LINE && curstash != debstash) {
1602             SV *sv = NEWSV(85,0);
1603
1604             sv_upgrade(sv, SVt_PVMG);
1605             sv_setsv(sv,linestr);
1606             av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1607         }
1608         bufend = SvPVX(linestr) + SvCUR(linestr);
1609         if (curcop->cop_line == 1) {
1610             while (s < bufend && isSPACE(*s))
1611                 s++;
1612             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1613                 s++;
1614             d = Nullch;
1615             if (!in_eval) {
1616                 if (*s == '#' && *(s+1) == '!')
1617                     d = s + 2;
1618 #ifdef ALTERNATE_SHEBANG
1619                 else {
1620                     static char as[] = ALTERNATE_SHEBANG;
1621                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
1622                         d = s + (sizeof(as) - 1);
1623                 }
1624 #endif /* ALTERNATE_SHEBANG */
1625             }
1626             if (d) {
1627                 char *ipath;
1628                 char *ipathend;
1629
1630                 while (isSPACE(*d))
1631                     d++;
1632                 ipath = d;
1633                 while (*d && !isSPACE(*d))
1634                     d++;
1635                 ipathend = d;
1636
1637 #ifdef ARG_ZERO_IS_SCRIPT
1638                 if (ipathend > ipath) {
1639                     /*
1640                      * HP-UX (at least) sets argv[0] to the script name,
1641                      * which makes $^X incorrect.  And Digital UNIX and Linux,
1642                      * at least, set argv[0] to the basename of the Perl
1643                      * interpreter. So, having found "#!", we'll set it right.
1644                      */
1645                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
1646                     assert(SvPOK(x) || SvGMAGICAL(x));
1647                     if (sv_eq(x, GvSV(curcop->cop_filegv))) {
1648                         sv_setpvn(x, ipath, ipathend - ipath);
1649                         SvSETMAGIC(x);
1650                     }
1651                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
1652                 }
1653 #endif /* ARG_ZERO_IS_SCRIPT */
1654
1655                 /*
1656                  * Look for options.
1657                  */
1658                 d = instr(s,"perl -");
1659                 if (!d)
1660                     d = instr(s,"perl");
1661 #ifdef ALTERNATE_SHEBANG
1662                 /*
1663                  * If the ALTERNATE_SHEBANG on this system starts with a
1664                  * character that can be part of a Perl expression, then if
1665                  * we see it but not "perl", we're probably looking at the
1666                  * start of Perl code, not a request to hand off to some
1667                  * other interpreter.  Similarly, if "perl" is there, but
1668                  * not in the first 'word' of the line, we assume the line
1669                  * contains the start of the Perl program.
1670                  */
1671                 if (d && *s != '#') {
1672                     char *c = ipath;
1673                     while (*c && !strchr("; \t\r\n\f\v#", *c))
1674                         c++;
1675                     if (c < d)
1676                         d = Nullch;     /* "perl" not in first word; ignore */
1677                     else
1678                         *s = '#';       /* Don't try to parse shebang line */
1679                 }
1680 #endif /* ALTERNATE_SHEBANG */
1681                 if (!d &&
1682                     *s == '#' &&
1683                     ipathend > ipath &&
1684                     !minus_c &&
1685                     !instr(s,"indir") &&
1686                     instr(origargv[0],"perl"))
1687                 {
1688                     char **newargv;
1689
1690                     *ipathend = '\0';
1691                     s = ipathend + 1;
1692                     while (s < bufend && isSPACE(*s))
1693                         s++;
1694                     if (s < bufend) {
1695                         Newz(899,newargv,origargc+3,char*);
1696                         newargv[1] = s;
1697                         while (s < bufend && !isSPACE(*s))
1698                             s++;
1699                         *s = '\0';
1700                         Copy(origargv+1, newargv+2, origargc+1, char*);
1701                     }
1702                     else
1703                         newargv = origargv;
1704                     newargv[0] = ipath;
1705                     execv(ipath, newargv);
1706                     croak("Can't exec %s", ipath);
1707                 }
1708                 if (d) {
1709                     U32 oldpdb = perldb;
1710                     bool oldn = minus_n;
1711                     bool oldp = minus_p;
1712
1713                     while (*d && !isSPACE(*d)) d++;
1714                     while (*d == ' ' || *d == '\t') d++;
1715
1716                     if (*d++ == '-') {
1717                         do {
1718                             if (*d == 'M' || *d == 'm') {
1719                                 char *m = d;
1720                                 while (*d && !isSPACE(*d)) d++;
1721                                 croak("Too late for \"-%.*s\" option",
1722                                       (int)(d - m), m);
1723                             }
1724                             d = moreswitches(d);
1725                         } while (d);
1726                         if (PERLDB_LINE && !oldpdb ||
1727                             ( minus_n || minus_p ) && !(oldn || oldp) )
1728                               /* if we have already added "LINE: while (<>) {",
1729                                  we must not do it again */
1730                         {
1731                             sv_setpv(linestr, "");
1732                             oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1733                             bufend = SvPVX(linestr) + SvCUR(linestr);
1734                             preambled = FALSE;
1735                             if (PERLDB_LINE)
1736                                 (void)gv_fetchfile(origfilename);
1737                             goto retry;
1738                         }
1739                     }
1740                 }
1741             }
1742         }
1743         if (lex_formbrack && lex_brackets <= lex_formbrack) {
1744             bufptr = s;
1745             lex_state = LEX_FORMLINE;
1746             return yylex();
1747         }
1748         goto retry;
1749     case '\r':
1750         warn("Illegal character \\%03o (carriage return)", '\r');
1751         croak(
1752       "(Maybe you didn't strip carriage returns after a network transfer?)\n");
1753     case ' ': case '\t': case '\f': case 013:
1754         s++;
1755         goto retry;
1756     case '#':
1757     case '\n':
1758         if (lex_state != LEX_NORMAL || (in_eval && !rsfp)) {
1759             d = bufend;
1760             while (s < d && *s != '\n')
1761                 s++;
1762             if (s < d)
1763                 s++;
1764             incline(s);
1765             if (lex_formbrack && lex_brackets <= lex_formbrack) {
1766                 bufptr = s;
1767                 lex_state = LEX_FORMLINE;
1768                 return yylex();
1769             }
1770         }
1771         else {
1772             *s = '\0';
1773             bufend = s;
1774         }
1775         goto retry;
1776     case '-':
1777         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
1778             s++;
1779             bufptr = s;
1780             tmp = *s++;
1781
1782             while (s < bufend && (*s == ' ' || *s == '\t'))
1783                 s++;
1784
1785             if (strnEQ(s,"=>",2)) {
1786                 if (dowarn)
1787                     warn("Ambiguous use of -%c => resolved to \"-%c\" =>",
1788                         (int)tmp, (int)tmp);
1789                 s = force_word(bufptr,WORD,FALSE,FALSE,FALSE);
1790                 OPERATOR('-');          /* unary minus */
1791             }
1792             last_uni = oldbufptr;
1793             last_lop_op = OP_FTEREAD;   /* good enough */
1794             switch (tmp) {
1795             case 'r': FTST(OP_FTEREAD);
1796             case 'w': FTST(OP_FTEWRITE);
1797             case 'x': FTST(OP_FTEEXEC);
1798             case 'o': FTST(OP_FTEOWNED);
1799             case 'R': FTST(OP_FTRREAD);
1800             case 'W': FTST(OP_FTRWRITE);
1801             case 'X': FTST(OP_FTREXEC);
1802             case 'O': FTST(OP_FTROWNED);
1803             case 'e': FTST(OP_FTIS);
1804             case 'z': FTST(OP_FTZERO);
1805             case 's': FTST(OP_FTSIZE);
1806             case 'f': FTST(OP_FTFILE);
1807             case 'd': FTST(OP_FTDIR);
1808             case 'l': FTST(OP_FTLINK);
1809             case 'p': FTST(OP_FTPIPE);
1810             case 'S': FTST(OP_FTSOCK);
1811             case 'u': FTST(OP_FTSUID);
1812             case 'g': FTST(OP_FTSGID);
1813             case 'k': FTST(OP_FTSVTX);
1814             case 'b': FTST(OP_FTBLK);
1815             case 'c': FTST(OP_FTCHR);
1816             case 't': FTST(OP_FTTTY);
1817             case 'T': FTST(OP_FTTEXT);
1818             case 'B': FTST(OP_FTBINARY);
1819             case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
1820             case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
1821             case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
1822             default:
1823                 croak("Unrecognized file test: -%c", (int)tmp);
1824                 break;
1825             }
1826         }
1827         tmp = *s++;
1828         if (*s == tmp) {
1829             s++;
1830             if (expect == XOPERATOR)
1831                 TERM(POSTDEC);
1832             else
1833                 OPERATOR(PREDEC);
1834         }
1835         else if (*s == '>') {
1836             s++;
1837             s = skipspace(s);
1838             if (isIDFIRST(*s)) {
1839                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
1840                 TOKEN(ARROW);
1841             }
1842             else if (*s == '$')
1843                 OPERATOR(ARROW);
1844             else
1845                 TERM(ARROW);
1846         }
1847         if (expect == XOPERATOR)
1848             Aop(OP_SUBTRACT);
1849         else {
1850             if (isSPACE(*s) || !isSPACE(*bufptr))
1851                 check_uni();
1852             OPERATOR('-');              /* unary minus */
1853         }
1854
1855     case '+':
1856         tmp = *s++;
1857         if (*s == tmp) {
1858             s++;
1859             if (expect == XOPERATOR)
1860                 TERM(POSTINC);
1861             else
1862                 OPERATOR(PREINC);
1863         }
1864         if (expect == XOPERATOR)
1865             Aop(OP_ADD);
1866         else {
1867             if (isSPACE(*s) || !isSPACE(*bufptr))
1868                 check_uni();
1869             OPERATOR('+');
1870         }
1871
1872     case '*':
1873         if (expect != XOPERATOR) {
1874             s = scan_ident(s, bufend, tokenbuf, sizeof tokenbuf, TRUE);
1875             expect = XOPERATOR;
1876             force_ident(tokenbuf, '*');
1877             if (!*tokenbuf)
1878                 PREREF('*');
1879             TERM('*');
1880         }
1881         s++;
1882         if (*s == '*') {
1883             s++;
1884             PWop(OP_POW);
1885         }
1886         Mop(OP_MULTIPLY);
1887
1888     case '%':
1889         if (expect == XOPERATOR) {
1890             ++s;
1891             Mop(OP_MODULO);
1892         }
1893         tokenbuf[0] = '%';
1894         s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, TRUE);
1895         if (!tokenbuf[1]) {
1896             if (s == bufend)
1897                 yyerror("Final % should be \\% or %name");
1898             PREREF('%');
1899         }
1900         pending_ident = '%';
1901         TERM('%');
1902
1903     case '^':
1904         s++;
1905         BOop(OP_BIT_XOR);
1906     case '[':
1907         lex_brackets++;
1908         /* FALL THROUGH */
1909     case '~':
1910     case ',':
1911         tmp = *s++;
1912         OPERATOR(tmp);
1913     case ':':
1914         if (s[1] == ':') {
1915             len = 0;
1916             goto just_a_word;
1917         }
1918         s++;
1919         OPERATOR(':');
1920     case '(':
1921         s++;
1922         if (last_lop == oldoldbufptr || last_uni == oldoldbufptr)
1923             oldbufptr = oldoldbufptr;           /* allow print(STDOUT 123) */
1924         else
1925             expect = XTERM;
1926         TOKEN('(');
1927     case ';':
1928         if (curcop->cop_line < copline)
1929             copline = curcop->cop_line;
1930         tmp = *s++;
1931         OPERATOR(tmp);
1932     case ')':
1933         tmp = *s++;
1934         s = skipspace(s);
1935         if (*s == '{')
1936             PREBLOCK(tmp);
1937         TERM(tmp);
1938     case ']':
1939         s++;
1940         if (lex_brackets <= 0)
1941             yyerror("Unmatched right bracket");
1942         else
1943             --lex_brackets;
1944         if (lex_state == LEX_INTERPNORMAL) {
1945             if (lex_brackets == 0) {
1946                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
1947                     lex_state = LEX_INTERPEND;
1948             }
1949         }
1950         TERM(']');
1951     case '{':
1952       leftbracket:
1953         s++;
1954         if (lex_brackets > 100) {
1955             char* newlb = Renew(lex_brackstack, lex_brackets + 1, char);
1956             if (newlb != lex_brackstack) {
1957                 SAVEFREEPV(newlb);
1958                 lex_brackstack = newlb;
1959             }
1960         }
1961         switch (expect) {
1962         case XTERM:
1963             if (lex_formbrack) {
1964                 s--;
1965                 PRETERMBLOCK(DO);
1966             }
1967             if (oldoldbufptr == last_lop)
1968                 lex_brackstack[lex_brackets++] = XTERM;
1969             else
1970                 lex_brackstack[lex_brackets++] = XOPERATOR;
1971             OPERATOR(HASHBRACK);
1972         case XOPERATOR:
1973             while (s < bufend && (*s == ' ' || *s == '\t'))
1974                 s++;
1975             d = s;
1976             tokenbuf[0] = '\0';
1977             if (d < bufend && *d == '-') {
1978                 tokenbuf[0] = '-';
1979                 d++;
1980                 while (d < bufend && (*d == ' ' || *d == '\t'))
1981                     d++;
1982             }
1983             if (d < bufend && isIDFIRST(*d)) {
1984                 d = scan_word(d, tokenbuf + 1, sizeof tokenbuf - 1,
1985                               FALSE, &len);
1986                 while (d < bufend && (*d == ' ' || *d == '\t'))
1987                     d++;
1988                 if (*d == '}') {
1989                     char minus = (tokenbuf[0] == '-');
1990                     if (dowarn &&
1991                         (keyword(tokenbuf + 1, len) ||
1992                          (minus && len == 1 && isALPHA(tokenbuf[1])) ||
1993                          perl_get_cv(tokenbuf + 1, FALSE) ))
1994                         warn("Ambiguous use of {%s} resolved to {\"%s\"}",
1995                              tokenbuf + !minus, tokenbuf + !minus);
1996                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
1997                     if (minus)
1998                         force_next('-');
1999                 }
2000             }
2001             /* FALL THROUGH */
2002         case XBLOCK:
2003             lex_brackstack[lex_brackets++] = XSTATE;
2004             expect = XSTATE;
2005             break;
2006         case XTERMBLOCK:
2007             lex_brackstack[lex_brackets++] = XOPERATOR;
2008             expect = XSTATE;
2009             break;
2010         default: {
2011                 char *t;
2012                 if (oldoldbufptr == last_lop)
2013                     lex_brackstack[lex_brackets++] = XTERM;
2014                 else
2015                     lex_brackstack[lex_brackets++] = XOPERATOR;
2016                 s = skipspace(s);
2017                 if (*s == '}')
2018                     OPERATOR(HASHBRACK);
2019                 /* This hack serves to disambiguate a pair of curlies
2020                  * as being a block or an anon hash.  Normally, expectation
2021                  * determines that, but in cases where we're not in a
2022                  * position to expect anything in particular (like inside
2023                  * eval"") we have to resolve the ambiguity.  This code
2024                  * covers the case where the first term in the curlies is a
2025                  * quoted string.  Most other cases need to be explicitly
2026                  * disambiguated by prepending a `+' before the opening
2027                  * curly in order to force resolution as an anon hash.
2028                  *
2029                  * XXX should probably propagate the outer expectation
2030                  * into eval"" to rely less on this hack, but that could
2031                  * potentially break current behavior of eval"".
2032                  * GSAR 97-07-21
2033                  */
2034                 t = s;
2035                 if (*s == '\'' || *s == '"' || *s == '`') {
2036                     /* common case: get past first string, handling escapes */
2037                     for (t++; t < bufend && *t != *s;)
2038                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
2039                             t++;
2040                     t++;
2041                 }
2042                 else if (*s == 'q') {
2043                     if (++t < bufend
2044                         && (!isALNUM(*t)
2045                             || ((*t == 'q' || *t == 'x') && ++t < bufend
2046                                 && !isALNUM(*t)))) {
2047                         char *tmps;
2048                         char open, close, term;
2049                         I32 brackets = 1;
2050
2051                         while (t < bufend && isSPACE(*t))
2052                             t++;
2053                         term = *t;
2054                         open = term;
2055                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2056                             term = tmps[5];
2057                         close = term;
2058                         if (open == close)
2059                             for (t++; t < bufend; t++) {
2060                                 if (*t == '\\' && t+1 < bufend && open != '\\')
2061                                     t++;
2062                                 else if (*t == open)
2063                                     break;
2064                             }
2065                         else
2066                             for (t++; t < bufend; t++) {
2067                                 if (*t == '\\' && t+1 < bufend)
2068                                     t++;
2069                                 else if (*t == close && --brackets <= 0)
2070                                     break;
2071                                 else if (*t == open)
2072                                     brackets++;
2073                             }
2074                     }
2075                     t++;
2076                 }
2077                 else if (isALPHA(*s)) {
2078                     for (t++; t < bufend && isALNUM(*t); t++) ;
2079                 }
2080                 while (t < bufend && isSPACE(*t))
2081                     t++;
2082                 /* if comma follows first term, call it an anon hash */
2083                 /* XXX it could be a comma expression with loop modifiers */
2084                 if (t < bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2085                                    || (*t == '=' && t[1] == '>')))
2086                     OPERATOR(HASHBRACK);
2087                 if (expect == XREF)
2088                     expect = XTERM;
2089                 else {
2090                     lex_brackstack[lex_brackets-1] = XSTATE;
2091                     expect = XSTATE;
2092                 }
2093             }
2094             break;
2095         }
2096         yylval.ival = curcop->cop_line;
2097         if (isSPACE(*s) || *s == '#')
2098             copline = NOLINE;   /* invalidate current command line number */
2099         TOKEN('{');
2100     case '}':
2101       rightbracket:
2102         s++;
2103         if (lex_brackets <= 0)
2104             yyerror("Unmatched right bracket");
2105         else
2106             expect = (expectation)lex_brackstack[--lex_brackets];
2107         if (lex_brackets < lex_formbrack)
2108             lex_formbrack = 0;
2109         if (lex_state == LEX_INTERPNORMAL) {
2110             if (lex_brackets == 0) {
2111                 if (lex_fakebrack) {
2112                     lex_state = LEX_INTERPEND;
2113                     bufptr = s;
2114                     return yylex();             /* ignore fake brackets */
2115                 }
2116                 if (*s == '-' && s[1] == '>')
2117                     lex_state = LEX_INTERPENDMAYBE;
2118                 else if (*s != '[' && *s != '{')
2119                     lex_state = LEX_INTERPEND;
2120             }
2121         }
2122         if (lex_brackets < lex_fakebrack) {
2123             bufptr = s;
2124             lex_fakebrack = 0;
2125             return yylex();             /* ignore fake brackets */
2126         }
2127         force_next('}');
2128         TOKEN(';');
2129     case '&':
2130         s++;
2131         tmp = *s++;
2132         if (tmp == '&')
2133             AOPERATOR(ANDAND);
2134         s--;
2135         if (expect == XOPERATOR) {
2136             if (dowarn && isALPHA(*s) && bufptr == linestart) {
2137                 curcop->cop_line--;
2138                 warn(warn_nosemi);
2139                 curcop->cop_line++;
2140             }
2141             BAop(OP_BIT_AND);
2142         }
2143
2144         s = scan_ident(s - 1, bufend, tokenbuf, sizeof tokenbuf, TRUE);
2145         if (*tokenbuf) {
2146             expect = XOPERATOR;
2147             force_ident(tokenbuf, '&');
2148         }
2149         else
2150             PREREF('&');
2151         yylval.ival = (OPpENTERSUB_AMPER<<8);
2152         TERM('&');
2153
2154     case '|':
2155         s++;
2156         tmp = *s++;
2157         if (tmp == '|')
2158             AOPERATOR(OROR);
2159         s--;
2160         BOop(OP_BIT_OR);
2161     case '=':
2162         s++;
2163         tmp = *s++;
2164         if (tmp == '=')
2165             Eop(OP_EQ);
2166         if (tmp == '>')
2167             OPERATOR(',');
2168         if (tmp == '~')
2169             PMop(OP_MATCH);
2170         if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2171             warn("Reversed %c= operator",(int)tmp);
2172         s--;
2173         if (expect == XSTATE && isALPHA(tmp) &&
2174                 (s == linestart+1 || s[-2] == '\n') )
2175         {
2176             if (in_eval && !rsfp) {
2177                 d = bufend;
2178                 while (s < d) {
2179                     if (*s++ == '\n') {
2180                         incline(s);
2181                         if (strnEQ(s,"=cut",4)) {
2182                             s = strchr(s,'\n');
2183                             if (s)
2184                                 s++;
2185                             else
2186                                 s = d;
2187                             incline(s);
2188                             goto retry;
2189                         }
2190                     }
2191                 }
2192                 goto retry;
2193             }
2194             s = bufend;
2195             doextract = TRUE;
2196             goto retry;
2197         }
2198         if (lex_brackets < lex_formbrack) {
2199             char *t;
2200             for (t = s; *t == ' ' || *t == '\t'; t++) ;
2201             if (*t == '\n' || *t == '#') {
2202                 s--;
2203                 expect = XBLOCK;
2204                 goto leftbracket;
2205             }
2206         }
2207         yylval.ival = 0;
2208         OPERATOR(ASSIGNOP);
2209     case '!':
2210         s++;
2211         tmp = *s++;
2212         if (tmp == '=')
2213             Eop(OP_NE);
2214         if (tmp == '~')
2215             PMop(OP_NOT);
2216         s--;
2217         OPERATOR('!');
2218     case '<':
2219         if (expect != XOPERATOR) {
2220             if (s[1] != '<' && !strchr(s,'>'))
2221                 check_uni();
2222             if (s[1] == '<')
2223                 s = scan_heredoc(s);
2224             else
2225                 s = scan_inputsymbol(s);
2226             TERM(sublex_start());
2227         }
2228         s++;
2229         tmp = *s++;
2230         if (tmp == '<')
2231             SHop(OP_LEFT_SHIFT);
2232         if (tmp == '=') {
2233             tmp = *s++;
2234             if (tmp == '>')
2235                 Eop(OP_NCMP);
2236             s--;
2237             Rop(OP_LE);
2238         }
2239         s--;
2240         Rop(OP_LT);
2241     case '>':
2242         s++;
2243         tmp = *s++;
2244         if (tmp == '>')
2245             SHop(OP_RIGHT_SHIFT);
2246         if (tmp == '=')
2247             Rop(OP_GE);
2248         s--;
2249         Rop(OP_GT);
2250
2251     case '$':
2252         CLINE;
2253
2254         if (expect == XOPERATOR) {
2255             if (lex_formbrack && lex_brackets == lex_formbrack) {
2256                 expect = XTERM;
2257                 depcom();
2258                 return ','; /* grandfather non-comma-format format */
2259             }
2260         }
2261
2262         if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
2263             if (expect == XOPERATOR)
2264                 no_op("Array length", bufptr);
2265             tokenbuf[0] = '@';
2266             s = scan_ident(s + 1, bufend, tokenbuf + 1, sizeof tokenbuf - 1,
2267                            FALSE);
2268             if (!tokenbuf[1])
2269                 PREREF(DOLSHARP);
2270             expect = XOPERATOR;
2271             pending_ident = '#';
2272             TOKEN(DOLSHARP);
2273         }
2274
2275         if (expect == XOPERATOR)
2276             no_op("Scalar", bufptr);
2277         tokenbuf[0] = '$';
2278         s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2279         if (!tokenbuf[1]) {
2280             if (s == bufend)
2281                 yyerror("Final $ should be \\$ or $name");
2282             PREREF('$');
2283         }
2284
2285         /* This kludge not intended to be bulletproof. */
2286         if (tokenbuf[1] == '[' && !tokenbuf[2]) {
2287             yylval.opval = newSVOP(OP_CONST, 0,
2288                                    newSViv((IV)compiling.cop_arybase));
2289             yylval.opval->op_private = OPpCONST_ARYBASE;
2290             TERM(THING);
2291         }
2292
2293         d = s;
2294         if (lex_state == LEX_NORMAL)
2295             s = skipspace(s);
2296
2297         if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2298             char *t;
2299             if (*s == '[') {
2300                 tokenbuf[0] = '@';
2301                 if (dowarn) {
2302                     for(t = s + 1;
2303                         isSPACE(*t) || isALNUM(*t) || *t == '$';
2304                         t++) ;
2305                     if (*t++ == ',') {
2306                         bufptr = skipspace(bufptr);
2307                         while (t < bufend && *t != ']')
2308                             t++;
2309                         warn("Multidimensional syntax %.*s not supported",
2310                              (t - bufptr) + 1, bufptr);
2311                     }
2312                 }
2313             }
2314             else if (*s == '{') {
2315                 tokenbuf[0] = '%';
2316                 if (dowarn && strEQ(tokenbuf+1, "SIG") &&
2317                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
2318                 {
2319                     char tmpbuf[sizeof tokenbuf];
2320                     STRLEN len;
2321                     for (t++; isSPACE(*t); t++) ;
2322                     if (isIDFIRST(*t)) {
2323                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2324                         if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2325                             warn("You need to quote \"%s\"", tmpbuf);
2326                     }
2327                 }
2328             }
2329         }
2330
2331         expect = XOPERATOR;
2332         if (lex_state == LEX_NORMAL && isSPACE(*d)) {
2333             bool islop = (last_lop == oldoldbufptr);
2334             if (!islop || last_lop_op == OP_GREPSTART)
2335                 expect = XOPERATOR;
2336             else if (strchr("$@\"'`q", *s))
2337                 expect = XTERM;         /* e.g. print $fh "foo" */
2338             else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2339                 expect = XTERM;         /* e.g. print $fh &sub */
2340             else if (isIDFIRST(*s)) {
2341                 char tmpbuf[sizeof tokenbuf];
2342                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2343                 if (tmp = keyword(tmpbuf, len)) {
2344                     /* binary operators exclude handle interpretations */
2345                     switch (tmp) {
2346                     case -KEY_x:
2347                     case -KEY_eq:
2348                     case -KEY_ne:
2349                     case -KEY_gt:
2350                     case -KEY_lt:
2351                     case -KEY_ge:
2352                     case -KEY_le:
2353                     case -KEY_cmp:
2354                         break;
2355                     default:
2356                         expect = XTERM; /* e.g. print $fh length() */
2357                         break;
2358                     }
2359                 }
2360                 else {
2361                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2362                     if (gv && GvCVu(gv))
2363                         expect = XTERM; /* e.g. print $fh subr() */
2364                 }
2365             }
2366             else if (isDIGIT(*s))
2367                 expect = XTERM;         /* e.g. print $fh 3 */
2368             else if (*s == '.' && isDIGIT(s[1]))
2369                 expect = XTERM;         /* e.g. print $fh .3 */
2370             else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2371                 expect = XTERM;         /* e.g. print $fh -1 */
2372             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2373                 expect = XTERM;         /* print $fh <<"EOF" */
2374         }
2375         pending_ident = '$';
2376         TOKEN('$');
2377
2378     case '@':
2379         if (expect == XOPERATOR)
2380             no_op("Array", s);
2381         tokenbuf[0] = '@';
2382         s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2383         if (!tokenbuf[1]) {
2384             if (s == bufend)
2385                 yyerror("Final @ should be \\@ or @name");
2386             PREREF('@');
2387         }
2388         if (lex_state == LEX_NORMAL)
2389             s = skipspace(s);
2390         if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2391             if (*s == '{')
2392                 tokenbuf[0] = '%';
2393
2394             /* Warn about @ where they meant $. */
2395             if (dowarn) {
2396                 if (*s == '[' || *s == '{') {
2397                     char *t = s + 1;
2398                     while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2399                         t++;
2400                     if (*t == '}' || *t == ']') {
2401                         t++;
2402                         bufptr = skipspace(bufptr);
2403                         warn("Scalar value %.*s better written as $%.*s",
2404                             t-bufptr, bufptr, t-bufptr-1, bufptr+1);
2405                     }
2406                 }
2407             }
2408         }
2409         pending_ident = '@';
2410         TERM('@');
2411
2412     case '/':                   /* may either be division or pattern */
2413     case '?':                   /* may either be conditional or pattern */
2414         if (expect != XOPERATOR) {
2415             check_uni();
2416             s = scan_pat(s);
2417             TERM(sublex_start());
2418         }
2419         tmp = *s++;
2420         if (tmp == '/')
2421             Mop(OP_DIVIDE);
2422         OPERATOR(tmp);
2423
2424     case '.':
2425         if (lex_formbrack && lex_brackets == lex_formbrack && s[1] == '\n' &&
2426                 (s == linestart || s[-1] == '\n') ) {
2427             lex_formbrack = 0;
2428             expect = XSTATE;
2429             goto rightbracket;
2430         }
2431         if (expect == XOPERATOR || !isDIGIT(s[1])) {
2432             tmp = *s++;
2433             if (*s == tmp) {
2434                 s++;
2435                 if (*s == tmp) {
2436                     s++;
2437                     yylval.ival = OPf_SPECIAL;
2438                 }
2439                 else
2440                     yylval.ival = 0;
2441                 OPERATOR(DOTDOT);
2442             }
2443             if (expect != XOPERATOR)
2444                 check_uni();
2445             Aop(OP_CONCAT);
2446         }
2447         /* FALL THROUGH */
2448     case '0': case '1': case '2': case '3': case '4':
2449     case '5': case '6': case '7': case '8': case '9':
2450         s = scan_num(s);
2451         if (expect == XOPERATOR)
2452             no_op("Number",s);
2453         TERM(THING);
2454
2455     case '\'':
2456         s = scan_str(s);
2457         if (expect == XOPERATOR) {
2458             if (lex_formbrack && lex_brackets == lex_formbrack) {
2459                 expect = XTERM;
2460                 depcom();
2461                 return ',';     /* grandfather non-comma-format format */
2462             }
2463             else
2464                 no_op("String",s);
2465         }
2466         if (!s)
2467             missingterm((char*)0);
2468         yylval.ival = OP_CONST;
2469         TERM(sublex_start());
2470
2471     case '"':
2472         s = scan_str(s);
2473         if (expect == XOPERATOR) {
2474             if (lex_formbrack && lex_brackets == lex_formbrack) {
2475                 expect = XTERM;
2476                 depcom();
2477                 return ',';     /* grandfather non-comma-format format */
2478             }
2479             else
2480                 no_op("String",s);
2481         }
2482         if (!s)
2483             missingterm((char*)0);
2484         yylval.ival = OP_CONST;
2485         for (d = SvPV(lex_stuff, len); len; len--, d++) {
2486             if (*d == '$' || *d == '@' || *d == '\\') {
2487                 yylval.ival = OP_STRINGIFY;
2488                 break;
2489             }
2490         }
2491         TERM(sublex_start());
2492
2493     case '`':
2494         s = scan_str(s);
2495         if (expect == XOPERATOR)
2496             no_op("Backticks",s);
2497         if (!s)
2498             missingterm((char*)0);
2499         yylval.ival = OP_BACKTICK;
2500         set_csh();
2501         TERM(sublex_start());
2502
2503     case '\\':
2504         s++;
2505         if (dowarn && lex_inwhat && isDIGIT(*s))
2506             warn("Can't use \\%c to mean $%c in expression", *s, *s);
2507         if (expect == XOPERATOR)
2508             no_op("Backslash",s);
2509         OPERATOR(REFGEN);
2510
2511     case 'x':
2512         if (isDIGIT(s[1]) && expect == XOPERATOR) {
2513             s++;
2514             Mop(OP_REPEAT);
2515         }
2516         goto keylookup;
2517
2518     case '_':
2519     case 'a': case 'A':
2520     case 'b': case 'B':
2521     case 'c': case 'C':
2522     case 'd': case 'D':
2523     case 'e': case 'E':
2524     case 'f': case 'F':
2525     case 'g': case 'G':
2526     case 'h': case 'H':
2527     case 'i': case 'I':
2528     case 'j': case 'J':
2529     case 'k': case 'K':
2530     case 'l': case 'L':
2531     case 'm': case 'M':
2532     case 'n': case 'N':
2533     case 'o': case 'O':
2534     case 'p': case 'P':
2535     case 'q': case 'Q':
2536     case 'r': case 'R':
2537     case 's': case 'S':
2538     case 't': case 'T':
2539     case 'u': case 'U':
2540     case 'v': case 'V':
2541     case 'w': case 'W':
2542               case 'X':
2543     case 'y': case 'Y':
2544     case 'z': case 'Z':
2545
2546       keylookup:
2547         bufptr = s;
2548         s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
2549
2550         /* Some keywords can be followed by any delimiter, including ':' */
2551         tmp = (len == 1 && strchr("msyq", tokenbuf[0]) ||
2552                len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') ||
2553                             (tokenbuf[0] == 'q' &&
2554                              strchr("qwx", tokenbuf[1]))));
2555
2556         /* x::* is just a word, unless x is "CORE" */
2557         if (!tmp && *s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE"))
2558             goto just_a_word;
2559
2560         d = s;
2561         while (d < bufend && isSPACE(*d))
2562                 d++;    /* no comments skipped here, or s### is misparsed */
2563
2564         /* Is this a label? */
2565         if (!tmp && expect == XSTATE
2566               && d < bufend && *d == ':' && *(d + 1) != ':') {
2567             s = d + 1;
2568             yylval.pval = savepv(tokenbuf);
2569             CLINE;
2570             TOKEN(LABEL);
2571         }
2572
2573         /* Check for keywords */
2574         tmp = keyword(tokenbuf, len);
2575
2576         /* Is this a word before a => operator? */
2577         if (strnEQ(d,"=>",2)) {
2578             CLINE;
2579             if (dowarn && (tmp || perl_get_cv(tokenbuf, FALSE)))
2580                 warn("Ambiguous use of %s => resolved to \"%s\" =>",
2581                         tokenbuf, tokenbuf);
2582             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
2583             yylval.opval->op_private = OPpCONST_BARE;
2584             TERM(WORD);
2585         }
2586
2587         if (tmp < 0) {                  /* second-class keyword? */
2588             GV* gv;
2589             if (expect != XOPERATOR &&
2590                 (*s != ':' || s[1] != ':') &&
2591                 (gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) &&
2592                 GvIMPORTED_CV(gv))
2593             {
2594                 tmp = 0;
2595             }
2596             else
2597                 tmp = -tmp;
2598         }
2599
2600       reserved_word:
2601         switch (tmp) {
2602
2603         default:                        /* not a keyword */
2604           just_a_word: {
2605                 GV *gv;
2606                 SV *sv;
2607                 char lastchar = (bufptr == oldoldbufptr ? 0 : bufptr[-1]);
2608
2609                 /* Get the rest if it looks like a package qualifier */
2610
2611                 if (*s == '\'' || *s == ':' && s[1] == ':') {
2612                     s = scan_word(s, tokenbuf + len, sizeof tokenbuf - len,
2613                                   TRUE, &len);
2614                     if (!len)
2615                         croak("Bad name after %s::", tokenbuf);
2616                 }
2617
2618                 if (expect == XOPERATOR) {
2619                     if (bufptr == linestart) {
2620                         curcop->cop_line--;
2621                         warn(warn_nosemi);
2622                         curcop->cop_line++;
2623                     }
2624                     else
2625                         no_op("Bareword",s);
2626                 }
2627
2628                 /* Look for a subroutine with this name in current package. */
2629
2630                 gv = gv_fetchpv(tokenbuf,FALSE, SVt_PVCV);
2631
2632                 /* Presume this is going to be a bareword of some sort. */
2633
2634                 CLINE;
2635                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
2636                 yylval.opval->op_private = OPpCONST_BARE;
2637
2638                 /* See if it's the indirect object for a list operator. */
2639
2640                 if (oldoldbufptr &&
2641                     oldoldbufptr < bufptr &&
2642                     (oldoldbufptr == last_lop || oldoldbufptr == last_uni) &&
2643                     /* NO SKIPSPACE BEFORE HERE! */
2644                     (expect == XREF ||
2645                      (opargs[last_lop_op] >> OASHIFT & 7) == OA_FILEREF) )
2646                 {
2647                     bool immediate_paren = *s == '(';
2648
2649                     /* (Now we can afford to cross potential line boundary.) */
2650                     s = skipspace(s);
2651
2652                     /* Two barewords in a row may indicate method call. */
2653
2654                     if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2655                         return tmp;
2656
2657                     /* If not a declared subroutine, it's an indirect object. */
2658                     /* (But it's an indir obj regardless for sort.) */
2659
2660                     if ((last_lop_op == OP_SORT ||
2661                          (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2662                         (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
2663                         expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
2664                         goto bareword;
2665                     }
2666                 }
2667
2668                 /* If followed by a paren, it's certainly a subroutine. */
2669
2670                 expect = XOPERATOR;
2671                 s = skipspace(s);
2672                 if (*s == '(') {
2673                     CLINE;
2674                     if (gv && GvCVu(gv)) {
2675                         for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2676                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2677                             s = d + 1;
2678                             goto its_constant;
2679                         }
2680                     }
2681                     nextval[nexttoke].opval = yylval.opval;
2682                     expect = XOPERATOR;
2683                     force_next(WORD);
2684                     yylval.ival = 0;
2685                     TOKEN('&');
2686                 }
2687
2688                 /* If followed by var or block, call it a method (unless sub) */
2689
2690                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
2691                     last_lop = oldbufptr;
2692                     last_lop_op = OP_METHOD;
2693                     PREBLOCK(METHOD);
2694                 }
2695
2696                 /* If followed by a bareword, see if it looks like indir obj. */
2697
2698                 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
2699                     return tmp;
2700
2701                 /* Not a method, so call it a subroutine (if defined) */
2702
2703                 if (gv && GvCVu(gv)) {
2704                     CV* cv;
2705                     if (lastchar == '-')
2706                         warn("Ambiguous use of -%s resolved as -&%s()",
2707                                 tokenbuf, tokenbuf);
2708                     last_lop = oldbufptr;
2709                     last_lop_op = OP_ENTERSUB;
2710                     /* Check for a constant sub */
2711                     cv = GvCV(gv);
2712                     if ((sv = cv_const_sv(cv))) {
2713                   its_constant:
2714                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
2715                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
2716                         yylval.opval->op_private = 0;
2717                         TOKEN(WORD);
2718                     }
2719
2720                     /* Resolve to GV now. */
2721                     op_free(yylval.opval);
2722                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
2723                     /* Is there a prototype? */
2724                     if (SvPOK(cv)) {
2725                         STRLEN len;
2726                         char *proto = SvPV((SV*)cv, len);
2727                         if (!len)
2728                             TERM(FUNC0SUB);
2729                         if (strEQ(proto, "$"))
2730                             OPERATOR(UNIOPSUB);
2731                         if (*proto == '&' && *s == '{') {
2732                             sv_setpv(subname,"__ANON__");
2733                             PREBLOCK(LSTOPSUB);
2734                         }
2735                     }
2736                     nextval[nexttoke].opval = yylval.opval;
2737                     expect = XTERM;
2738                     force_next(WORD);
2739                     TOKEN(NOAMP);
2740                 }
2741
2742                 if (hints & HINT_STRICT_SUBS &&
2743                     lastchar != '-' &&
2744                     strnNE(s,"->",2) &&
2745                     last_lop_op != OP_TRUNCATE &&  /* S/F prototype in opcode.pl */
2746                     last_lop_op != OP_ACCEPT &&
2747                     last_lop_op != OP_PIPE_OP &&
2748                     last_lop_op != OP_SOCKPAIR)
2749                 {
2750                     warn(
2751                      "Bareword \"%s\" not allowed while \"strict subs\" in use",
2752                         tokenbuf);
2753                     ++error_count;
2754                 }
2755
2756                 /* Call it a bare word */
2757
2758             bareword:
2759                 if (dowarn) {
2760                     if (lastchar != '-') {
2761                         for (d = tokenbuf; *d && isLOWER(*d); d++) ;
2762                         if (!*d)
2763                             warn(warn_reserved, tokenbuf);
2764                     }
2765                 }
2766                 if (lastchar && strchr("*%&", lastchar)) {
2767                     warn("Operator or semicolon missing before %c%s",
2768                         lastchar, tokenbuf);
2769                     warn("Ambiguous use of %c resolved as operator %c",
2770                         lastchar, lastchar);
2771                 }
2772                 TOKEN(WORD);
2773             }
2774
2775         case KEY___FILE__:
2776             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
2777                                         newSVsv(GvSV(curcop->cop_filegv)));
2778             TERM(THING);
2779
2780         case KEY___LINE__:
2781             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
2782                                     newSVpvf("%ld", (long)curcop->cop_line));
2783             TERM(THING);
2784
2785         case KEY___PACKAGE__:
2786             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
2787                                         (curstash
2788                                          ? newSVsv(curstname)
2789                                          : &sv_undef));
2790             TERM(THING);
2791
2792         case KEY___DATA__:
2793         case KEY___END__: {
2794             GV *gv;
2795
2796             /*SUPPRESS 560*/
2797             if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
2798                 char *pname = "main";
2799                 if (tokenbuf[2] == 'D')
2800                     pname = HvNAME(curstash ? curstash : defstash);
2801                 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
2802                 GvMULTI_on(gv);
2803                 if (!GvIO(gv))
2804                     GvIOp(gv) = newIO();
2805                 IoIFP(GvIOp(gv)) = rsfp;
2806 #if defined(HAS_FCNTL) && defined(F_SETFD)
2807                 {
2808                     int fd = PerlIO_fileno(rsfp);
2809                     fcntl(fd,F_SETFD,fd >= 3);
2810                 }
2811 #endif
2812                 /* Mark this internal pseudo-handle as clean */
2813                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
2814                 if (preprocess)
2815                     IoTYPE(GvIOp(gv)) = '|';
2816                 else if ((PerlIO*)rsfp == PerlIO_stdin())
2817                     IoTYPE(GvIOp(gv)) = '-';
2818                 else
2819                     IoTYPE(GvIOp(gv)) = '<';
2820                 rsfp = Nullfp;
2821             }
2822             goto fake_eof;
2823         }
2824
2825         case KEY_AUTOLOAD:
2826         case KEY_DESTROY:
2827         case KEY_BEGIN:
2828         case KEY_END:
2829         case KEY_INIT:
2830             if (expect == XSTATE) {
2831                 s = bufptr;
2832                 goto really_sub;
2833             }
2834             goto just_a_word;
2835
2836         case KEY_CORE:
2837             if (*s == ':' && s[1] == ':') {
2838                 s += 2;
2839                 d = s;
2840                 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
2841                 tmp = keyword(tokenbuf, len);
2842                 if (tmp < 0)
2843                     tmp = -tmp;
2844                 goto reserved_word;
2845             }
2846             goto just_a_word;
2847
2848         case KEY_abs:
2849             UNI(OP_ABS);
2850
2851         case KEY_alarm:
2852             UNI(OP_ALARM);
2853
2854         case KEY_accept:
2855             LOP(OP_ACCEPT,XTERM);
2856
2857         case KEY_and:
2858             OPERATOR(ANDOP);
2859
2860         case KEY_atan2:
2861             LOP(OP_ATAN2,XTERM);
2862
2863         case KEY_bind:
2864             LOP(OP_BIND,XTERM);
2865
2866         case KEY_binmode:
2867             UNI(OP_BINMODE);
2868
2869         case KEY_bless:
2870             LOP(OP_BLESS,XTERM);
2871
2872         case KEY_chop:
2873             UNI(OP_CHOP);
2874
2875         case KEY_continue:
2876             PREBLOCK(CONTINUE);
2877
2878         case KEY_chdir:
2879             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
2880             UNI(OP_CHDIR);
2881
2882         case KEY_close:
2883             UNI(OP_CLOSE);
2884
2885         case KEY_closedir:
2886             UNI(OP_CLOSEDIR);
2887
2888         case KEY_cmp:
2889             Eop(OP_SCMP);
2890
2891         case KEY_caller:
2892             UNI(OP_CALLER);
2893
2894         case KEY_crypt:
2895 #ifdef FCRYPT
2896             if (!cryptseen++)
2897                 init_des();
2898 #endif
2899             LOP(OP_CRYPT,XTERM);
2900
2901         case KEY_chmod:
2902             if (dowarn) {
2903                 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
2904                 if (*d != '0' && isDIGIT(*d))
2905                     yywarn("chmod: mode argument is missing initial 0");
2906             }
2907             LOP(OP_CHMOD,XTERM);
2908
2909         case KEY_chown:
2910             LOP(OP_CHOWN,XTERM);
2911
2912         case KEY_connect:
2913             LOP(OP_CONNECT,XTERM);
2914
2915         case KEY_chr:
2916             UNI(OP_CHR);
2917
2918         case KEY_cos:
2919             UNI(OP_COS);
2920
2921         case KEY_chroot:
2922             UNI(OP_CHROOT);
2923
2924         case KEY_do:
2925             s = skipspace(s);
2926             if (*s == '{')
2927                 PRETERMBLOCK(DO);
2928             if (*s != '\'')
2929                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
2930             OPERATOR(DO);
2931
2932         case KEY_die:
2933             hints |= HINT_BLOCK_SCOPE;
2934             LOP(OP_DIE,XTERM);
2935
2936         case KEY_defined:
2937             UNI(OP_DEFINED);
2938
2939         case KEY_delete:
2940             UNI(OP_DELETE);
2941
2942         case KEY_dbmopen:
2943             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
2944             LOP(OP_DBMOPEN,XTERM);
2945
2946         case KEY_dbmclose:
2947             UNI(OP_DBMCLOSE);
2948
2949         case KEY_dump:
2950             s = force_word(s,WORD,TRUE,FALSE,FALSE);
2951             LOOPX(OP_DUMP);
2952
2953         case KEY_else:
2954             PREBLOCK(ELSE);
2955
2956         case KEY_elsif:
2957             yylval.ival = curcop->cop_line;
2958             OPERATOR(ELSIF);
2959
2960         case KEY_eq:
2961             Eop(OP_SEQ);
2962
2963         case KEY_exists:
2964             UNI(OP_EXISTS);
2965
2966         case KEY_exit:
2967             UNI(OP_EXIT);
2968
2969         case KEY_eval:
2970             s = skipspace(s);
2971             expect = (*s == '{') ? XTERMBLOCK : XTERM;
2972             UNIBRACK(OP_ENTEREVAL);
2973
2974         case KEY_eof:
2975             UNI(OP_EOF);
2976
2977         case KEY_exp:
2978             UNI(OP_EXP);
2979
2980         case KEY_each:
2981             UNI(OP_EACH);
2982
2983         case KEY_exec:
2984             set_csh();
2985             LOP(OP_EXEC,XREF);
2986
2987         case KEY_endhostent:
2988             FUN0(OP_EHOSTENT);
2989
2990         case KEY_endnetent:
2991             FUN0(OP_ENETENT);
2992
2993         case KEY_endservent:
2994             FUN0(OP_ESERVENT);
2995
2996         case KEY_endprotoent:
2997             FUN0(OP_EPROTOENT);
2998
2999         case KEY_endpwent:
3000             FUN0(OP_EPWENT);
3001
3002         case KEY_endgrent:
3003             FUN0(OP_EGRENT);
3004
3005         case KEY_for:
3006         case KEY_foreach:
3007             yylval.ival = curcop->cop_line;
3008             s = skipspace(s);
3009             if (isIDFIRST(*s)) {
3010                 char *p = s;
3011                 if ((bufend - p) >= 3 &&
3012                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3013                     p += 2;
3014                 p = skipspace(p);
3015                 if (isIDFIRST(*p))
3016                     croak("Missing $ on loop variable");
3017             }
3018             OPERATOR(FOR);
3019
3020         case KEY_formline:
3021             LOP(OP_FORMLINE,XTERM);
3022
3023         case KEY_fork:
3024             FUN0(OP_FORK);
3025
3026         case KEY_fcntl:
3027             LOP(OP_FCNTL,XTERM);
3028
3029         case KEY_fileno:
3030             UNI(OP_FILENO);
3031
3032         case KEY_flock:
3033             LOP(OP_FLOCK,XTERM);
3034
3035         case KEY_gt:
3036             Rop(OP_SGT);
3037
3038         case KEY_ge:
3039             Rop(OP_SGE);
3040
3041         case KEY_grep:
3042             LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3043
3044         case KEY_goto:
3045             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3046             LOOPX(OP_GOTO);
3047
3048         case KEY_gmtime:
3049             UNI(OP_GMTIME);
3050
3051         case KEY_getc:
3052             UNI(OP_GETC);
3053
3054         case KEY_getppid:
3055             FUN0(OP_GETPPID);
3056
3057         case KEY_getpgrp:
3058             UNI(OP_GETPGRP);
3059
3060         case KEY_getpriority:
3061             LOP(OP_GETPRIORITY,XTERM);
3062
3063         case KEY_getprotobyname:
3064             UNI(OP_GPBYNAME);
3065
3066         case KEY_getprotobynumber:
3067             LOP(OP_GPBYNUMBER,XTERM);
3068
3069         case KEY_getprotoent:
3070             FUN0(OP_GPROTOENT);
3071
3072         case KEY_getpwent:
3073             FUN0(OP_GPWENT);
3074
3075         case KEY_getpwnam:
3076             UNI(OP_GPWNAM);
3077
3078         case KEY_getpwuid:
3079             UNI(OP_GPWUID);
3080
3081         case KEY_getpeername:
3082             UNI(OP_GETPEERNAME);
3083
3084         case KEY_gethostbyname:
3085             UNI(OP_GHBYNAME);
3086
3087         case KEY_gethostbyaddr:
3088             LOP(OP_GHBYADDR,XTERM);
3089
3090         case KEY_gethostent:
3091             FUN0(OP_GHOSTENT);
3092
3093         case KEY_getnetbyname:
3094             UNI(OP_GNBYNAME);
3095
3096         case KEY_getnetbyaddr:
3097             LOP(OP_GNBYADDR,XTERM);
3098
3099         case KEY_getnetent:
3100             FUN0(OP_GNETENT);
3101
3102         case KEY_getservbyname:
3103             LOP(OP_GSBYNAME,XTERM);
3104
3105         case KEY_getservbyport:
3106             LOP(OP_GSBYPORT,XTERM);
3107
3108         case KEY_getservent:
3109             FUN0(OP_GSERVENT);
3110
3111         case KEY_getsockname:
3112             UNI(OP_GETSOCKNAME);
3113
3114         case KEY_getsockopt:
3115             LOP(OP_GSOCKOPT,XTERM);
3116
3117         case KEY_getgrent:
3118             FUN0(OP_GGRENT);
3119
3120         case KEY_getgrnam:
3121             UNI(OP_GGRNAM);
3122
3123         case KEY_getgrgid:
3124             UNI(OP_GGRGID);
3125
3126         case KEY_getlogin:
3127             FUN0(OP_GETLOGIN);
3128
3129         case KEY_glob:
3130             set_csh();
3131             LOP(OP_GLOB,XTERM);
3132
3133         case KEY_hex:
3134             UNI(OP_HEX);
3135
3136         case KEY_if:
3137             yylval.ival = curcop->cop_line;
3138             OPERATOR(IF);
3139
3140         case KEY_index:
3141             LOP(OP_INDEX,XTERM);
3142
3143         case KEY_int:
3144             UNI(OP_INT);
3145
3146         case KEY_ioctl:
3147             LOP(OP_IOCTL,XTERM);
3148
3149         case KEY_join:
3150             LOP(OP_JOIN,XTERM);
3151
3152         case KEY_keys:
3153             UNI(OP_KEYS);
3154
3155         case KEY_kill:
3156             LOP(OP_KILL,XTERM);
3157
3158         case KEY_last:
3159             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3160             LOOPX(OP_LAST);
3161
3162         case KEY_lc:
3163             UNI(OP_LC);
3164
3165         case KEY_lcfirst:
3166             UNI(OP_LCFIRST);
3167
3168         case KEY_local:
3169             OPERATOR(LOCAL);
3170
3171         case KEY_length:
3172             UNI(OP_LENGTH);
3173
3174         case KEY_lt:
3175             Rop(OP_SLT);
3176
3177         case KEY_le:
3178             Rop(OP_SLE);
3179
3180         case KEY_localtime:
3181             UNI(OP_LOCALTIME);
3182
3183         case KEY_log:
3184             UNI(OP_LOG);
3185
3186         case KEY_link:
3187             LOP(OP_LINK,XTERM);
3188
3189         case KEY_listen:
3190             LOP(OP_LISTEN,XTERM);
3191
3192         case KEY_lock:
3193             UNI(OP_LOCK);
3194
3195         case KEY_lstat:
3196             UNI(OP_LSTAT);
3197
3198         case KEY_m:
3199             s = scan_pat(s);
3200             TERM(sublex_start());
3201
3202         case KEY_map:
3203             LOP(OP_MAPSTART,XREF);
3204
3205         case KEY_mkdir:
3206             LOP(OP_MKDIR,XTERM);
3207
3208         case KEY_msgctl:
3209             LOP(OP_MSGCTL,XTERM);
3210
3211         case KEY_msgget:
3212             LOP(OP_MSGGET,XTERM);
3213
3214         case KEY_msgrcv:
3215             LOP(OP_MSGRCV,XTERM);
3216
3217         case KEY_msgsnd:
3218             LOP(OP_MSGSND,XTERM);
3219
3220         case KEY_my:
3221             in_my = TRUE;
3222             s = skipspace(s);
3223             if (isIDFIRST(*s)) {
3224                 s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
3225                 in_my_stash = gv_stashpv(tokenbuf, FALSE);
3226                 if (!in_my_stash) {
3227                     char tmpbuf[1024];
3228                     bufptr = s;
3229                     sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
3230                     yyerror(tmpbuf);
3231                 }
3232             }
3233             OPERATOR(MY);
3234
3235         case KEY_next:
3236             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3237             LOOPX(OP_NEXT);
3238
3239         case KEY_ne:
3240             Eop(OP_SNE);
3241
3242         case KEY_no:
3243             if (expect != XSTATE)
3244                 yyerror("\"no\" not allowed in expression");
3245             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3246             s = force_version(s);
3247             yylval.ival = 0;
3248             OPERATOR(USE);
3249
3250         case KEY_not:
3251             OPERATOR(NOTOP);
3252
3253         case KEY_open:
3254             s = skipspace(s);
3255             if (isIDFIRST(*s)) {
3256                 char *t;
3257                 for (d = s; isALNUM(*d); d++) ;
3258                 t = skipspace(d);
3259                 if (strchr("|&*+-=!?:.", *t))
3260                     warn("Precedence problem: open %.*s should be open(%.*s)",
3261                         d-s,s, d-s,s);
3262             }
3263             LOP(OP_OPEN,XTERM);
3264
3265         case KEY_or:
3266             yylval.ival = OP_OR;
3267             OPERATOR(OROP);
3268
3269         case KEY_ord:
3270             UNI(OP_ORD);
3271
3272         case KEY_oct:
3273             UNI(OP_OCT);
3274
3275         case KEY_opendir:
3276             LOP(OP_OPEN_DIR,XTERM);
3277
3278         case KEY_print:
3279             checkcomma(s,tokenbuf,"filehandle");
3280             LOP(OP_PRINT,XREF);
3281
3282         case KEY_printf:
3283             checkcomma(s,tokenbuf,"filehandle");
3284             LOP(OP_PRTF,XREF);
3285
3286         case KEY_prototype:
3287             UNI(OP_PROTOTYPE);
3288
3289         case KEY_push:
3290             LOP(OP_PUSH,XTERM);
3291
3292         case KEY_pop:
3293             UNI(OP_POP);
3294
3295         case KEY_pos:
3296             UNI(OP_POS);
3297
3298         case KEY_pack:
3299             LOP(OP_PACK,XTERM);
3300
3301         case KEY_package:
3302             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3303             OPERATOR(PACKAGE);
3304
3305         case KEY_pipe:
3306             LOP(OP_PIPE_OP,XTERM);
3307
3308         case KEY_q:
3309             s = scan_str(s);
3310             if (!s)
3311                 missingterm((char*)0);
3312             yylval.ival = OP_CONST;
3313             TERM(sublex_start());
3314
3315         case KEY_quotemeta:
3316             UNI(OP_QUOTEMETA);
3317
3318         case KEY_qw:
3319             s = scan_str(s);
3320             if (!s)
3321                 missingterm((char*)0);
3322             if (dowarn && SvLEN(lex_stuff)) {
3323                 d = SvPV_force(lex_stuff, len);
3324                 for (; len; --len, ++d) {
3325                     if (*d == ',') {
3326                         warn("Possible attempt to separate words with commas");
3327                         break;
3328                     }
3329                     if (*d == '#') {
3330                         warn("Possible attempt to put comments in qw() list");
3331                         break;
3332                     }
3333                 }
3334             }
3335             force_next(')');
3336             nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, q(lex_stuff));
3337             lex_stuff = Nullsv;
3338             force_next(THING);
3339             force_next(',');
3340             nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3341             force_next(THING);
3342             force_next('(');
3343             yylval.ival = OP_SPLIT;
3344             CLINE;
3345             expect = XTERM;
3346             bufptr = s;
3347             last_lop = oldbufptr;
3348             last_lop_op = OP_SPLIT;
3349             return FUNC;
3350
3351         case KEY_qq:
3352             s = scan_str(s);
3353             if (!s)
3354                 missingterm((char*)0);
3355             yylval.ival = OP_STRINGIFY;
3356             if (SvIVX(lex_stuff) == '\'')
3357                 SvIVX(lex_stuff) = 0;   /* qq'$foo' should intepolate */
3358             TERM(sublex_start());
3359
3360         case KEY_qx:
3361             s = scan_str(s);
3362             if (!s)
3363                 missingterm((char*)0);
3364             yylval.ival = OP_BACKTICK;
3365             set_csh();
3366             TERM(sublex_start());
3367
3368         case KEY_return:
3369             OLDLOP(OP_RETURN);
3370
3371         case KEY_require:
3372             *tokenbuf = '\0';
3373             s = force_word(s,WORD,TRUE,TRUE,FALSE);
3374             if (isIDFIRST(*tokenbuf))
3375                 gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
3376             else if (*s == '<')
3377                 yyerror("<> should be quotes");
3378             UNI(OP_REQUIRE);
3379
3380         case KEY_reset:
3381             UNI(OP_RESET);
3382
3383         case KEY_redo:
3384             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3385             LOOPX(OP_REDO);
3386
3387         case KEY_rename:
3388             LOP(OP_RENAME,XTERM);
3389
3390         case KEY_rand:
3391             UNI(OP_RAND);
3392
3393         case KEY_rmdir:
3394             UNI(OP_RMDIR);
3395
3396         case KEY_rindex:
3397             LOP(OP_RINDEX,XTERM);
3398
3399         case KEY_read:
3400             LOP(OP_READ,XTERM);
3401
3402         case KEY_readdir:
3403             UNI(OP_READDIR);
3404
3405         case KEY_readline:
3406             set_csh();
3407             UNI(OP_READLINE);
3408
3409         case KEY_readpipe:
3410             set_csh();
3411             UNI(OP_BACKTICK);
3412
3413         case KEY_rewinddir:
3414             UNI(OP_REWINDDIR);
3415
3416         case KEY_recv:
3417             LOP(OP_RECV,XTERM);
3418
3419         case KEY_reverse:
3420             LOP(OP_REVERSE,XTERM);
3421
3422         case KEY_readlink:
3423             UNI(OP_READLINK);
3424
3425         case KEY_ref:
3426             UNI(OP_REF);
3427
3428         case KEY_s:
3429             s = scan_subst(s);
3430             if (yylval.opval)
3431                 TERM(sublex_start());
3432             else
3433                 TOKEN(1);       /* force error */
3434
3435         case KEY_chomp:
3436             UNI(OP_CHOMP);
3437
3438         case KEY_scalar:
3439             UNI(OP_SCALAR);
3440
3441         case KEY_select:
3442             LOP(OP_SELECT,XTERM);
3443
3444         case KEY_seek:
3445             LOP(OP_SEEK,XTERM);
3446
3447         case KEY_semctl:
3448             LOP(OP_SEMCTL,XTERM);
3449
3450         case KEY_semget:
3451             LOP(OP_SEMGET,XTERM);
3452
3453         case KEY_semop:
3454             LOP(OP_SEMOP,XTERM);
3455
3456         case KEY_send:
3457             LOP(OP_SEND,XTERM);
3458
3459         case KEY_setpgrp:
3460             LOP(OP_SETPGRP,XTERM);
3461
3462         case KEY_setpriority:
3463             LOP(OP_SETPRIORITY,XTERM);
3464
3465         case KEY_sethostent:
3466             UNI(OP_SHOSTENT);
3467
3468         case KEY_setnetent:
3469             UNI(OP_SNETENT);
3470
3471         case KEY_setservent:
3472             UNI(OP_SSERVENT);
3473
3474         case KEY_setprotoent:
3475             UNI(OP_SPROTOENT);
3476
3477         case KEY_setpwent:
3478             FUN0(OP_SPWENT);
3479
3480         case KEY_setgrent:
3481             FUN0(OP_SGRENT);
3482
3483         case KEY_seekdir:
3484             LOP(OP_SEEKDIR,XTERM);
3485
3486         case KEY_setsockopt:
3487             LOP(OP_SSOCKOPT,XTERM);
3488
3489         case KEY_shift:
3490             UNI(OP_SHIFT);
3491
3492         case KEY_shmctl:
3493             LOP(OP_SHMCTL,XTERM);
3494
3495         case KEY_shmget:
3496             LOP(OP_SHMGET,XTERM);
3497
3498         case KEY_shmread:
3499             LOP(OP_SHMREAD,XTERM);
3500
3501         case KEY_shmwrite:
3502             LOP(OP_SHMWRITE,XTERM);
3503
3504         case KEY_shutdown:
3505             LOP(OP_SHUTDOWN,XTERM);
3506
3507         case KEY_sin:
3508             UNI(OP_SIN);
3509
3510         case KEY_sleep:
3511             UNI(OP_SLEEP);
3512
3513         case KEY_socket:
3514             LOP(OP_SOCKET,XTERM);
3515
3516         case KEY_socketpair:
3517             LOP(OP_SOCKPAIR,XTERM);
3518
3519         case KEY_sort:
3520             checkcomma(s,tokenbuf,"subroutine name");
3521             s = skipspace(s);
3522             if (*s == ';' || *s == ')')         /* probably a close */
3523                 croak("sort is now a reserved word");
3524             expect = XTERM;
3525             s = force_word(s,WORD,TRUE,TRUE,TRUE);
3526             LOP(OP_SORT,XREF);
3527
3528         case KEY_split:
3529             LOP(OP_SPLIT,XTERM);
3530
3531         case KEY_sprintf:
3532             LOP(OP_SPRINTF,XTERM);
3533
3534         case KEY_splice:
3535             LOP(OP_SPLICE,XTERM);
3536
3537         case KEY_sqrt:
3538             UNI(OP_SQRT);
3539
3540         case KEY_srand:
3541             UNI(OP_SRAND);
3542
3543         case KEY_stat:
3544             UNI(OP_STAT);
3545
3546         case KEY_study:
3547             sawstudy++;
3548             UNI(OP_STUDY);
3549
3550         case KEY_substr:
3551             LOP(OP_SUBSTR,XTERM);
3552
3553         case KEY_format:
3554         case KEY_sub:
3555           really_sub:
3556             s = skipspace(s);
3557
3558             if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3559                 char tmpbuf[sizeof tokenbuf];
3560                 expect = XBLOCK;
3561                 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3562                 if (strchr(tmpbuf, ':'))
3563                     sv_setpv(subname, tmpbuf);
3564                 else {
3565                     sv_setsv(subname,curstname);
3566                     sv_catpvn(subname,"::",2);
3567                     sv_catpvn(subname,tmpbuf,len);
3568                 }
3569                 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3570                 s = skipspace(s);
3571             }
3572             else {
3573                 expect = XTERMBLOCK;
3574                 sv_setpv(subname,"?");
3575             }
3576
3577             if (tmp == KEY_format) {
3578                 s = skipspace(s);
3579                 if (*s == '=')
3580                     lex_formbrack = lex_brackets + 1;
3581                 OPERATOR(FORMAT);
3582             }
3583
3584             /* Look for a prototype */
3585             if (*s == '(') {
3586                 char *p;
3587
3588                 s = scan_str(s);
3589                 if (!s) {
3590                     if (lex_stuff)
3591                         SvREFCNT_dec(lex_stuff);
3592                     lex_stuff = Nullsv;
3593                     croak("Prototype not terminated");
3594                 }
3595                 /* strip spaces */
3596                 d = SvPVX(lex_stuff);
3597                 tmp = 0;
3598                 for (p = d; *p; ++p) {
3599                     if (!isSPACE(*p))
3600                         d[tmp++] = *p;
3601                 }
3602                 d[tmp] = '\0';
3603                 SvCUR(lex_stuff) = tmp;
3604
3605                 nexttoke++;
3606                 nextval[1] = nextval[0];
3607                 nexttype[1] = nexttype[0];
3608                 nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff);
3609                 nexttype[0] = THING;
3610                 if (nexttoke == 1) {
3611                     lex_defer = lex_state;
3612                     lex_expect = expect;
3613                     lex_state = LEX_KNOWNEXT;
3614                 }
3615                 lex_stuff = Nullsv;
3616             }
3617
3618             if (*SvPV(subname,na) == '?') {
3619                 sv_setpv(subname,"__ANON__");
3620                 TOKEN(ANONSUB);
3621             }
3622             PREBLOCK(SUB);
3623
3624         case KEY_system:
3625             set_csh();
3626             LOP(OP_SYSTEM,XREF);
3627
3628         case KEY_symlink:
3629             LOP(OP_SYMLINK,XTERM);
3630
3631         case KEY_syscall:
3632             LOP(OP_SYSCALL,XTERM);
3633
3634         case KEY_sysopen:
3635             LOP(OP_SYSOPEN,XTERM);
3636
3637         case KEY_sysseek:
3638             LOP(OP_SYSSEEK,XTERM);
3639
3640         case KEY_sysread:
3641             LOP(OP_SYSREAD,XTERM);
3642
3643         case KEY_syswrite:
3644             LOP(OP_SYSWRITE,XTERM);
3645
3646         case KEY_tr:
3647             s = scan_trans(s);
3648             TERM(sublex_start());
3649
3650         case KEY_tell:
3651             UNI(OP_TELL);
3652
3653         case KEY_telldir:
3654             UNI(OP_TELLDIR);
3655
3656         case KEY_tie:
3657             LOP(OP_TIE,XTERM);
3658
3659         case KEY_tied:
3660             UNI(OP_TIED);
3661
3662         case KEY_time:
3663             FUN0(OP_TIME);
3664
3665         case KEY_times:
3666             FUN0(OP_TMS);
3667
3668         case KEY_truncate:
3669             LOP(OP_TRUNCATE,XTERM);
3670
3671         case KEY_uc:
3672             UNI(OP_UC);
3673
3674         case KEY_ucfirst:
3675             UNI(OP_UCFIRST);
3676
3677         case KEY_untie:
3678             UNI(OP_UNTIE);
3679
3680         case KEY_until:
3681             yylval.ival = curcop->cop_line;
3682             OPERATOR(UNTIL);
3683
3684         case KEY_unless:
3685             yylval.ival = curcop->cop_line;
3686             OPERATOR(UNLESS);
3687
3688         case KEY_unlink:
3689             LOP(OP_UNLINK,XTERM);
3690
3691         case KEY_undef:
3692             UNI(OP_UNDEF);
3693
3694         case KEY_unpack:
3695             LOP(OP_UNPACK,XTERM);
3696
3697         case KEY_utime:
3698             LOP(OP_UTIME,XTERM);
3699
3700         case KEY_umask:
3701             if (dowarn) {
3702                 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3703                 if (*d != '0' && isDIGIT(*d))
3704                     yywarn("umask: argument is missing initial 0");
3705             }
3706             UNI(OP_UMASK);
3707
3708         case KEY_unshift:
3709             LOP(OP_UNSHIFT,XTERM);
3710
3711         case KEY_use:
3712             if (expect != XSTATE)
3713                 yyerror("\"use\" not allowed in expression");
3714             s = skipspace(s);
3715             if(isDIGIT(*s)) {
3716                 s = force_version(s);
3717                 if(*s == ';' || (s = skipspace(s), *s == ';')) {
3718                     nextval[nexttoke].opval = Nullop;
3719                     force_next(WORD);
3720                 }
3721             }
3722             else {
3723                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3724                 s = force_version(s);
3725             }
3726             yylval.ival = 1;
3727             OPERATOR(USE);
3728
3729         case KEY_values:
3730             UNI(OP_VALUES);
3731
3732         case KEY_vec:
3733             sawvec = TRUE;
3734             LOP(OP_VEC,XTERM);
3735
3736         case KEY_while:
3737             yylval.ival = curcop->cop_line;
3738             OPERATOR(WHILE);
3739
3740         case KEY_warn:
3741             hints |= HINT_BLOCK_SCOPE;
3742             LOP(OP_WARN,XTERM);
3743
3744         case KEY_wait:
3745             FUN0(OP_WAIT);
3746
3747         case KEY_waitpid:
3748             LOP(OP_WAITPID,XTERM);
3749
3750         case KEY_wantarray:
3751             FUN0(OP_WANTARRAY);
3752
3753         case KEY_write:
3754             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
3755             UNI(OP_ENTERWRITE);
3756
3757         case KEY_x:
3758             if (expect == XOPERATOR)
3759                 Mop(OP_REPEAT);
3760             check_uni();
3761             goto just_a_word;
3762
3763         case KEY_xor:
3764             yylval.ival = OP_XOR;
3765             OPERATOR(OROP);
3766
3767         case KEY_y:
3768             s = scan_trans(s);
3769             TERM(sublex_start());
3770         }
3771     }
3772 }
3773
3774 I32
3775 keyword(d, len)
3776 register char *d;
3777 I32 len;
3778 {
3779     switch (*d) {
3780     case '_':
3781         if (d[1] == '_') {
3782             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
3783             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
3784             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
3785             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
3786             if (strEQ(d,"__END__"))             return KEY___END__;
3787         }
3788         break;
3789     case 'A':
3790         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
3791         break;
3792     case 'a':
3793         switch (len) {
3794         case 3:
3795             if (strEQ(d,"and"))                 return -KEY_and;
3796             if (strEQ(d,"abs"))                 return -KEY_abs;
3797             break;
3798         case 5:
3799             if (strEQ(d,"alarm"))               return -KEY_alarm;
3800             if (strEQ(d,"atan2"))               return -KEY_atan2;
3801             break;
3802         case 6:
3803             if (strEQ(d,"accept"))              return -KEY_accept;
3804             break;
3805         }
3806         break;
3807     case 'B':
3808         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
3809         break;
3810     case 'b':
3811         if (strEQ(d,"bless"))                   return -KEY_bless;
3812         if (strEQ(d,"bind"))                    return -KEY_bind;
3813         if (strEQ(d,"binmode"))                 return -KEY_binmode;
3814         break;
3815     case 'C':
3816         if (strEQ(d,"CORE"))                    return -KEY_CORE;
3817         break;
3818     case 'c':
3819         switch (len) {
3820         case 3:
3821             if (strEQ(d,"cmp"))                 return -KEY_cmp;
3822             if (strEQ(d,"chr"))                 return -KEY_chr;
3823             if (strEQ(d,"cos"))                 return -KEY_cos;
3824             break;
3825         case 4:
3826             if (strEQ(d,"chop"))                return KEY_chop;
3827             break;
3828         case 5:
3829             if (strEQ(d,"close"))               return -KEY_close;
3830             if (strEQ(d,"chdir"))               return -KEY_chdir;
3831             if (strEQ(d,"chomp"))               return KEY_chomp;
3832             if (strEQ(d,"chmod"))               return -KEY_chmod;
3833             if (strEQ(d,"chown"))               return -KEY_chown;
3834             if (strEQ(d,"crypt"))               return -KEY_crypt;
3835             break;
3836         case 6:
3837             if (strEQ(d,"chroot"))              return -KEY_chroot;
3838             if (strEQ(d,"caller"))              return -KEY_caller;
3839             break;
3840         case 7:
3841             if (strEQ(d,"connect"))             return -KEY_connect;
3842             break;
3843         case 8:
3844             if (strEQ(d,"closedir"))            return -KEY_closedir;
3845             if (strEQ(d,"continue"))            return -KEY_continue;
3846             break;
3847         }
3848         break;
3849     case 'D':
3850         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
3851         break;
3852     case 'd':
3853         switch (len) {
3854         case 2:
3855             if (strEQ(d,"do"))                  return KEY_do;
3856             break;
3857         case 3:
3858             if (strEQ(d,"die"))                 return -KEY_die;
3859             break;
3860         case 4:
3861             if (strEQ(d,"dump"))                return -KEY_dump;
3862             break;
3863         case 6:
3864             if (strEQ(d,"delete"))              return KEY_delete;
3865             break;
3866         case 7:
3867             if (strEQ(d,"defined"))             return KEY_defined;
3868             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
3869             break;
3870         case 8:
3871             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
3872             break;
3873         }
3874         break;
3875     case 'E':
3876         if (strEQ(d,"EQ")) { deprecate(d);      return -KEY_eq;}
3877         if (strEQ(d,"END"))                     return KEY_END;
3878         break;
3879     case 'e':
3880         switch (len) {
3881         case 2:
3882             if (strEQ(d,"eq"))                  return -KEY_eq;
3883             break;
3884         case 3:
3885             if (strEQ(d,"eof"))                 return -KEY_eof;
3886             if (strEQ(d,"exp"))                 return -KEY_exp;
3887             break;
3888         case 4:
3889             if (strEQ(d,"else"))                return KEY_else;
3890             if (strEQ(d,"exit"))                return -KEY_exit;
3891             if (strEQ(d,"eval"))                return KEY_eval;
3892             if (strEQ(d,"exec"))                return -KEY_exec;
3893             if (strEQ(d,"each"))                return KEY_each;
3894             break;
3895         case 5:
3896             if (strEQ(d,"elsif"))               return KEY_elsif;
3897             break;
3898         case 6:
3899             if (strEQ(d,"exists"))              return KEY_exists;
3900             if (strEQ(d,"elseif")) warn("elseif should be elsif");
3901             break;
3902         case 8:
3903             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
3904             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
3905             break;
3906         case 9:
3907             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
3908             break;
3909         case 10:
3910             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
3911             if (strEQ(d,"endservent"))          return -KEY_endservent;
3912             break;
3913         case 11:
3914             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
3915             break;
3916         }
3917         break;
3918     case 'f':
3919         switch (len) {
3920         case 3:
3921             if (strEQ(d,"for"))                 return KEY_for;
3922             break;
3923         case 4:
3924             if (strEQ(d,"fork"))                return -KEY_fork;
3925             break;
3926         case 5:
3927             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
3928             if (strEQ(d,"flock"))               return -KEY_flock;
3929             break;
3930         case 6:
3931             if (strEQ(d,"format"))              return KEY_format;
3932             if (strEQ(d,"fileno"))              return -KEY_fileno;
3933             break;
3934         case 7:
3935             if (strEQ(d,"foreach"))             return KEY_foreach;
3936             break;
3937         case 8:
3938             if (strEQ(d,"formline"))            return -KEY_formline;
3939             break;
3940         }
3941         break;
3942     case 'G':
3943         if (len == 2) {
3944             if (strEQ(d,"GT")) { deprecate(d);  return -KEY_gt;}
3945             if (strEQ(d,"GE")) { deprecate(d);  return -KEY_ge;}
3946         }
3947         break;
3948     case 'g':
3949         if (strnEQ(d,"get",3)) {
3950             d += 3;
3951             if (*d == 'p') {
3952                 switch (len) {
3953                 case 7:
3954                     if (strEQ(d,"ppid"))        return -KEY_getppid;
3955                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
3956                     break;
3957                 case 8:
3958                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
3959                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
3960                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
3961                     break;
3962                 case 11:
3963                     if (strEQ(d,"peername"))    return -KEY_getpeername;
3964                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
3965                     if (strEQ(d,"priority"))    return -KEY_getpriority;
3966                     break;
3967                 case 14:
3968                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
3969                     break;
3970                 case 16:
3971                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
3972                     break;
3973                 }
3974             }
3975             else if (*d == 'h') {
3976                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
3977                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
3978                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
3979             }
3980             else if (*d == 'n') {
3981                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
3982                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
3983                 if (strEQ(d,"netent"))          return -KEY_getnetent;
3984             }
3985             else if (*d == 's') {
3986                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
3987                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
3988                 if (strEQ(d,"servent"))         return -KEY_getservent;
3989                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
3990                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
3991             }
3992             else if (*d == 'g') {
3993                 if (strEQ(d,"grent"))           return -KEY_getgrent;
3994                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
3995                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
3996             }
3997             else if (*d == 'l') {
3998                 if (strEQ(d,"login"))           return -KEY_getlogin;
3999             }
4000             else if (strEQ(d,"c"))              return -KEY_getc;
4001             break;
4002         }
4003         switch (len) {
4004         case 2:
4005             if (strEQ(d,"gt"))                  return -KEY_gt;
4006             if (strEQ(d,"ge"))                  return -KEY_ge;
4007             break;
4008         case 4:
4009             if (strEQ(d,"grep"))                return KEY_grep;
4010             if (strEQ(d,"goto"))                return KEY_goto;
4011             if (strEQ(d,"glob"))                return KEY_glob;
4012             break;
4013         case 6:
4014             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
4015             break;
4016         }
4017         break;
4018     case 'h':
4019         if (strEQ(d,"hex"))                     return -KEY_hex;
4020         break;
4021     case 'I':
4022         if (strEQ(d,"INIT"))                    return KEY_INIT;
4023         break;
4024     case 'i':
4025         switch (len) {
4026         case 2:
4027             if (strEQ(d,"if"))                  return KEY_if;
4028             break;
4029         case 3:
4030             if (strEQ(d,"int"))                 return -KEY_int;
4031             break;
4032         case 5:
4033             if (strEQ(d,"index"))               return -KEY_index;
4034             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
4035             break;
4036         }
4037         break;
4038     case 'j':
4039         if (strEQ(d,"join"))                    return -KEY_join;
4040         break;
4041     case 'k':
4042         if (len == 4) {
4043             if (strEQ(d,"keys"))                return KEY_keys;
4044             if (strEQ(d,"kill"))                return -KEY_kill;
4045         }
4046         break;
4047     case 'L':
4048         if (len == 2) {
4049             if (strEQ(d,"LT")) { deprecate(d);  return -KEY_lt;}
4050             if (strEQ(d,"LE")) { deprecate(d);  return -KEY_le;}
4051         }
4052         break;
4053     case 'l':
4054         switch (len) {
4055         case 2:
4056             if (strEQ(d,"lt"))                  return -KEY_lt;
4057             if (strEQ(d,"le"))                  return -KEY_le;
4058             if (strEQ(d,"lc"))                  return -KEY_lc;
4059             break;
4060         case 3:
4061             if (strEQ(d,"log"))                 return -KEY_log;
4062             break;
4063         case 4:
4064             if (strEQ(d,"last"))                return KEY_last;
4065             if (strEQ(d,"link"))                return -KEY_link;
4066             if (strEQ(d,"lock"))                return -KEY_lock;
4067             break;
4068         case 5:
4069             if (strEQ(d,"local"))               return KEY_local;
4070             if (strEQ(d,"lstat"))               return -KEY_lstat;
4071             break;
4072         case 6:
4073             if (strEQ(d,"length"))              return -KEY_length;
4074             if (strEQ(d,"listen"))              return -KEY_listen;
4075             break;
4076         case 7:
4077             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
4078             break;
4079         case 9:
4080             if (strEQ(d,"localtime"))           return -KEY_localtime;
4081             break;
4082         }
4083         break;
4084     case 'm':
4085         switch (len) {
4086         case 1:                                 return KEY_m;
4087         case 2:
4088             if (strEQ(d,"my"))                  return KEY_my;
4089             break;
4090         case 3:
4091             if (strEQ(d,"map"))                 return KEY_map;
4092             break;
4093         case 5:
4094             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
4095             break;
4096         case 6:
4097             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
4098             if (strEQ(d,"msgget"))              return -KEY_msgget;
4099             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
4100             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
4101             break;
4102         }
4103         break;
4104     case 'N':
4105         if (strEQ(d,"NE")) { deprecate(d);      return -KEY_ne;}
4106         break;
4107     case 'n':
4108         if (strEQ(d,"next"))                    return KEY_next;
4109         if (strEQ(d,"ne"))                      return -KEY_ne;
4110         if (strEQ(d,"not"))                     return -KEY_not;
4111         if (strEQ(d,"no"))                      return KEY_no;
4112         break;
4113     case 'o':
4114         switch (len) {
4115         case 2:
4116             if (strEQ(d,"or"))                  return -KEY_or;
4117             break;
4118         case 3:
4119             if (strEQ(d,"ord"))                 return -KEY_ord;
4120             if (strEQ(d,"oct"))                 return -KEY_oct;
4121             break;
4122         case 4:
4123             if (strEQ(d,"open"))                return -KEY_open;
4124             break;
4125         case 7:
4126             if (strEQ(d,"opendir"))             return -KEY_opendir;
4127             break;
4128         }
4129         break;
4130     case 'p':
4131         switch (len) {
4132         case 3:
4133             if (strEQ(d,"pop"))                 return KEY_pop;
4134             if (strEQ(d,"pos"))                 return KEY_pos;
4135             break;
4136         case 4:
4137             if (strEQ(d,"push"))                return KEY_push;
4138             if (strEQ(d,"pack"))                return -KEY_pack;
4139             if (strEQ(d,"pipe"))                return -KEY_pipe;
4140             break;
4141         case 5:
4142             if (strEQ(d,"print"))               return KEY_print;
4143             break;
4144         case 6:
4145             if (strEQ(d,"printf"))              return KEY_printf;
4146             break;
4147         case 7:
4148             if (strEQ(d,"package"))             return KEY_package;
4149             break;
4150         case 9:
4151             if (strEQ(d,"prototype"))           return KEY_prototype;
4152         }
4153         break;
4154     case 'q':
4155         if (len <= 2) {
4156             if (strEQ(d,"q"))                   return KEY_q;
4157             if (strEQ(d,"qq"))                  return KEY_qq;
4158             if (strEQ(d,"qw"))                  return KEY_qw;
4159             if (strEQ(d,"qx"))                  return KEY_qx;
4160         }
4161         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
4162         break;
4163     case 'r':
4164         switch (len) {
4165         case 3:
4166             if (strEQ(d,"ref"))                 return -KEY_ref;
4167             break;
4168         case 4:
4169             if (strEQ(d,"read"))                return -KEY_read;
4170             if (strEQ(d,"rand"))                return -KEY_rand;
4171             if (strEQ(d,"recv"))                return -KEY_recv;
4172             if (strEQ(d,"redo"))                return KEY_redo;
4173             break;
4174         case 5:
4175             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
4176             if (strEQ(d,"reset"))               return -KEY_reset;
4177             break;
4178         case 6:
4179             if (strEQ(d,"return"))              return KEY_return;
4180             if (strEQ(d,"rename"))              return -KEY_rename;
4181             if (strEQ(d,"rindex"))              return -KEY_rindex;
4182             break;
4183         case 7:
4184             if (strEQ(d,"require"))             return -KEY_require;
4185             if (strEQ(d,"reverse"))             return -KEY_reverse;
4186             if (strEQ(d,"readdir"))             return -KEY_readdir;
4187             break;
4188         case 8:
4189             if (strEQ(d,"readlink"))            return -KEY_readlink;
4190             if (strEQ(d,"readline"))            return -KEY_readline;
4191             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
4192             break;
4193         case 9:
4194             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
4195             break;
4196         }
4197         break;
4198     case 's':
4199         switch (d[1]) {
4200         case 0:                                 return KEY_s;
4201         case 'c':
4202             if (strEQ(d,"scalar"))              return KEY_scalar;
4203             break;
4204         case 'e':
4205             switch (len) {
4206             case 4:
4207                 if (strEQ(d,"seek"))            return -KEY_seek;
4208                 if (strEQ(d,"send"))            return -KEY_send;
4209                 break;
4210             case 5:
4211                 if (strEQ(d,"semop"))           return -KEY_semop;
4212                 break;
4213             case 6:
4214                 if (strEQ(d,"select"))          return -KEY_select;
4215                 if (strEQ(d,"semctl"))          return -KEY_semctl;
4216                 if (strEQ(d,"semget"))          return -KEY_semget;
4217                 break;
4218             case 7:
4219                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
4220                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
4221                 break;
4222             case 8:
4223                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
4224                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
4225                 break;
4226             case 9:
4227                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
4228                 break;
4229             case 10:
4230                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
4231                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
4232                 if (strEQ(d,"setservent"))      return -KEY_setservent;
4233                 break;
4234             case 11:
4235                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
4236                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
4237                 break;
4238             }
4239             break;
4240         case 'h':
4241             switch (len) {
4242             case 5:
4243                 if (strEQ(d,"shift"))           return KEY_shift;
4244                 break;
4245             case 6:
4246                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
4247                 if (strEQ(d,"shmget"))          return -KEY_shmget;
4248                 break;
4249             case 7:
4250                 if (strEQ(d,"shmread"))         return -KEY_shmread;
4251                 break;
4252             case 8:
4253                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
4254                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
4255                 break;
4256             }
4257             break;
4258         case 'i':
4259             if (strEQ(d,"sin"))                 return -KEY_sin;
4260             break;
4261         case 'l':
4262             if (strEQ(d,"sleep"))               return -KEY_sleep;
4263             break;
4264         case 'o':
4265             if (strEQ(d,"sort"))                return KEY_sort;
4266             if (strEQ(d,"socket"))              return -KEY_socket;
4267             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
4268             break;
4269         case 'p':
4270             if (strEQ(d,"split"))               return KEY_split;
4271             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
4272             if (strEQ(d,"splice"))              return KEY_splice;
4273             break;
4274         case 'q':
4275             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
4276             break;
4277         case 'r':
4278             if (strEQ(d,"srand"))               return -KEY_srand;
4279             break;
4280         case 't':
4281             if (strEQ(d,"stat"))                return -KEY_stat;
4282             if (strEQ(d,"study"))               return KEY_study;
4283             break;
4284         case 'u':
4285             if (strEQ(d,"substr"))              return -KEY_substr;
4286             if (strEQ(d,"sub"))                 return KEY_sub;
4287             break;
4288         case 'y':
4289             switch (len) {
4290             case 6:
4291                 if (strEQ(d,"system"))          return -KEY_system;
4292                 break;
4293             case 7:
4294                 if (strEQ(d,"symlink"))         return -KEY_symlink;
4295                 if (strEQ(d,"syscall"))         return -KEY_syscall;
4296                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
4297                 if (strEQ(d,"sysread"))         return -KEY_sysread;
4298                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
4299                 break;
4300             case 8:
4301                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
4302                 break;
4303             }
4304             break;
4305         }
4306         break;
4307     case 't':
4308         switch (len) {
4309         case 2:
4310             if (strEQ(d,"tr"))                  return KEY_tr;
4311             break;
4312         case 3:
4313             if (strEQ(d,"tie"))                 return KEY_tie;
4314             break;
4315         case 4:
4316             if (strEQ(d,"tell"))                return -KEY_tell;
4317             if (strEQ(d,"tied"))                return KEY_tied;
4318             if (strEQ(d,"time"))                return -KEY_time;
4319             break;
4320         case 5:
4321             if (strEQ(d,"times"))               return -KEY_times;
4322             break;
4323         case 7:
4324             if (strEQ(d,"telldir"))             return -KEY_telldir;
4325             break;
4326         case 8:
4327             if (strEQ(d,"truncate"))            return -KEY_truncate;
4328             break;
4329         }
4330         break;
4331     case 'u':
4332         switch (len) {
4333         case 2:
4334             if (strEQ(d,"uc"))                  return -KEY_uc;
4335             break;
4336         case 3:
4337             if (strEQ(d,"use"))                 return KEY_use;
4338             break;
4339         case 5:
4340             if (strEQ(d,"undef"))               return KEY_undef;
4341             if (strEQ(d,"until"))               return KEY_until;
4342             if (strEQ(d,"untie"))               return KEY_untie;
4343             if (strEQ(d,"utime"))               return -KEY_utime;
4344             if (strEQ(d,"umask"))               return -KEY_umask;
4345             break;
4346         case 6:
4347             if (strEQ(d,"unless"))              return KEY_unless;
4348             if (strEQ(d,"unpack"))              return -KEY_unpack;
4349             if (strEQ(d,"unlink"))              return -KEY_unlink;
4350             break;
4351         case 7:
4352             if (strEQ(d,"unshift"))             return KEY_unshift;
4353             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
4354             break;
4355         }
4356         break;
4357     case 'v':
4358         if (strEQ(d,"values"))                  return -KEY_values;
4359         if (strEQ(d,"vec"))                     return -KEY_vec;
4360         break;
4361     case 'w':
4362         switch (len) {
4363         case 4:
4364             if (strEQ(d,"warn"))                return -KEY_warn;
4365             if (strEQ(d,"wait"))                return -KEY_wait;
4366             break;
4367         case 5:
4368             if (strEQ(d,"while"))               return KEY_while;
4369             if (strEQ(d,"write"))               return -KEY_write;
4370             break;
4371         case 7:
4372             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
4373             break;
4374         case 9:
4375             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
4376             break;
4377         }
4378         break;
4379     case 'x':
4380         if (len == 1)                           return -KEY_x;
4381         if (strEQ(d,"xor"))                     return -KEY_xor;
4382         break;
4383     case 'y':
4384         if (len == 1)                           return KEY_y;
4385         break;
4386     case 'z':
4387         break;
4388     }
4389     return 0;
4390 }
4391
4392 static void
4393 checkcomma(s,name,what)
4394 register char *s;
4395 char *name;
4396 char *what;
4397 {
4398     char *w;
4399
4400     if (dowarn && *s == ' ' && s[1] == '(') {   /* XXX gotta be a better way */
4401         int level = 1;
4402         for (w = s+2; *w && level; w++) {
4403             if (*w == '(')
4404                 ++level;
4405             else if (*w == ')')
4406                 --level;
4407         }
4408         if (*w)
4409             for (; *w && isSPACE(*w); w++) ;
4410         if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4411             warn("%s (...) interpreted as function",name);
4412     }
4413     while (s < bufend && isSPACE(*s))
4414         s++;
4415     if (*s == '(')
4416         s++;
4417     while (s < bufend && isSPACE(*s))
4418         s++;
4419     if (isIDFIRST(*s)) {
4420         w = s++;
4421         while (isALNUM(*s))
4422             s++;
4423         while (s < bufend && isSPACE(*s))
4424             s++;
4425         if (*s == ',') {
4426             int kw;
4427             *s = '\0';
4428             kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4429             *s = ',';
4430             if (kw)
4431                 return;
4432             croak("No comma allowed after %s", what);
4433         }
4434     }
4435 }
4436
4437 static char *
4438 scan_word(s, dest, destlen, allow_package, slp)
4439 register char *s;
4440 char *dest;
4441 STRLEN destlen;
4442 int allow_package;
4443 STRLEN *slp;
4444 {
4445     register char *d = dest;
4446     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
4447     for (;;) {
4448         if (d >= e)
4449             croak(ident_too_long);
4450         if (isALNUM(*s))
4451             *d++ = *s++;
4452         else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4453             *d++ = ':';
4454             *d++ = ':';
4455             s++;
4456         }
4457         else if (*s == ':' && s[1] == ':' && allow_package && isIDFIRST(s[2])) {
4458             *d++ = *s++;
4459             *d++ = *s++;
4460         }
4461         else {
4462             *d = '\0';
4463             *slp = d - dest;
4464             return s;
4465         }
4466     }
4467 }
4468
4469 static char *
4470 scan_ident(s, send, dest, destlen, ck_uni)
4471 register char *s;
4472 register char *send;
4473 char *dest;
4474 STRLEN destlen;
4475 I32 ck_uni;
4476 {
4477     register char *d;
4478     register char *e;
4479     char *bracket = 0;
4480     char funny = *s++;
4481
4482     if (lex_brackets == 0)
4483         lex_fakebrack = 0;
4484     if (isSPACE(*s))
4485         s = skipspace(s);
4486     d = dest;
4487     e = d + destlen - 3;        /* two-character token, ending NUL */
4488     if (isDIGIT(*s)) {
4489         while (isDIGIT(*s)) {
4490             if (d >= e)
4491                 croak(ident_too_long);
4492             *d++ = *s++;
4493         }
4494     }
4495     else {
4496         for (;;) {
4497             if (d >= e)
4498                 croak(ident_too_long);
4499             if (isALNUM(*s))
4500                 *d++ = *s++;
4501             else if (*s == '\'' && isIDFIRST(s[1])) {
4502                 *d++ = ':';
4503                 *d++ = ':';
4504                 s++;
4505             }
4506             else if (*s == ':' && s[1] == ':') {
4507                 *d++ = *s++;
4508                 *d++ = *s++;
4509             }
4510             else
4511                 break;
4512         }
4513     }
4514     *d = '\0';
4515     d = dest;
4516     if (*d) {
4517         if (lex_state != LEX_NORMAL)
4518             lex_state = LEX_INTERPENDMAYBE;
4519         return s;
4520     }
4521     if (*s == '$' && s[1] &&
4522       (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4523     {
4524         if (isDIGIT(s[1]) && lex_state == LEX_INTERPNORMAL)
4525             deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4526         else
4527             return s;
4528     }
4529     if (*s == '{') {
4530         bracket = s;
4531         s++;
4532     }
4533     else if (ck_uni)
4534         check_uni();
4535     if (s < send)
4536         *d = *s++;
4537     d[1] = '\0';
4538     if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4539         *d = toCTRL(*s);
4540         s++;
4541     }
4542     if (bracket) {
4543         if (isSPACE(s[-1])) {
4544             while (s < send) {
4545                 char ch = *s++;
4546                 if (ch != ' ' && ch != '\t') {
4547                     *d = ch;
4548                     break;
4549                 }
4550             }
4551         }
4552         if (isIDFIRST(*d)) {
4553             d++;
4554             while (isALNUM(*s) || *s == ':')
4555                 *d++ = *s++;
4556             *d = '\0';
4557             while (s < send && (*s == ' ' || *s == '\t')) s++;
4558             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4559                 if (dowarn && keyword(dest, d - dest)) {
4560                     char *brack = *s == '[' ? "[...]" : "{...}";
4561                     warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4562                         funny, dest, brack, funny, dest, brack);
4563                 }
4564                 lex_fakebrack = lex_brackets+1;
4565                 bracket++;
4566                 lex_brackstack[lex_brackets++] = XOPERATOR;
4567                 return s;
4568             }
4569         }
4570         if (*s == '}') {
4571             s++;
4572             if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
4573                 lex_state = LEX_INTERPEND;
4574             if (funny == '#')
4575                 funny = '@';
4576             if (dowarn && lex_state == LEX_NORMAL &&
4577               (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4578                 warn("Ambiguous use of %c{%s} resolved to %c%s",
4579                     funny, dest, funny, dest);
4580         }
4581         else {
4582             s = bracket;                /* let the parser handle it */
4583             *dest = '\0';
4584         }
4585     }
4586     else if (lex_state == LEX_INTERPNORMAL && !lex_brackets && !intuit_more(s))
4587         lex_state = LEX_INTERPEND;
4588     return s;
4589 }
4590
4591 void pmflag(pmfl,ch)
4592 U16* pmfl;
4593 int ch;
4594 {
4595     if (ch == 'i')
4596         *pmfl |= PMf_FOLD;
4597     else if (ch == 'g')
4598         *pmfl |= PMf_GLOBAL;
4599     else if (ch == 'c')
4600         *pmfl |= PMf_CONTINUE;
4601     else if (ch == 'o')
4602         *pmfl |= PMf_KEEP;
4603     else if (ch == 'm')
4604         *pmfl |= PMf_MULTILINE;
4605     else if (ch == 's')
4606         *pmfl |= PMf_SINGLELINE;
4607     else if (ch == 'x')
4608         *pmfl |= PMf_EXTENDED;
4609 }
4610
4611 static char *
4612 scan_pat(start)
4613 char *start;
4614 {
4615     PMOP *pm;
4616     char *s;
4617
4618     s = scan_str(start);
4619     if (!s) {
4620         if (lex_stuff)
4621             SvREFCNT_dec(lex_stuff);
4622         lex_stuff = Nullsv;
4623         croak("Search pattern not terminated");
4624     }
4625
4626     pm = (PMOP*)newPMOP(OP_MATCH, 0);
4627     if (multi_open == '?')
4628         pm->op_pmflags |= PMf_ONCE;
4629     while (*s && strchr("iogcmsx", *s))
4630         pmflag(&pm->op_pmflags,*s++);
4631     pm->op_pmpermflags = pm->op_pmflags;
4632
4633     lex_op = (OP*)pm;
4634     yylval.ival = OP_MATCH;
4635     return s;
4636 }
4637
4638 static char *
4639 scan_subst(start)
4640 char *start;
4641 {
4642     register char *s;
4643     register PMOP *pm;
4644     I32 first_start;
4645     I32 es = 0;
4646
4647     yylval.ival = OP_NULL;
4648
4649     s = scan_str(start);
4650
4651     if (!s) {
4652         if (lex_stuff)
4653             SvREFCNT_dec(lex_stuff);
4654         lex_stuff = Nullsv;
4655         croak("Substitution pattern not terminated");
4656     }
4657
4658     if (s[-1] == multi_open)
4659         s--;
4660
4661     first_start = multi_start;
4662     s = scan_str(s);
4663     if (!s) {
4664         if (lex_stuff)
4665             SvREFCNT_dec(lex_stuff);
4666         lex_stuff = Nullsv;
4667         if (lex_repl)
4668             SvREFCNT_dec(lex_repl);
4669         lex_repl = Nullsv;
4670         croak("Substitution replacement not terminated");
4671     }
4672     multi_start = first_start;  /* so whole substitution is taken together */
4673
4674     pm = (PMOP*)newPMOP(OP_SUBST, 0);
4675     while (*s && strchr("iogcmsex", *s)) {
4676         if (*s == 'e') {
4677             s++;
4678             es++;
4679         }
4680         else
4681             pmflag(&pm->op_pmflags,*s++);
4682     }
4683
4684     if (es) {
4685         SV *repl;
4686         pm->op_pmflags |= PMf_EVAL;
4687         repl = newSVpv("",0);
4688         while (es-- > 0)
4689             sv_catpv(repl, es ? "eval " : "do ");
4690         sv_catpvn(repl, "{ ", 2);
4691         sv_catsv(repl, lex_repl);
4692         sv_catpvn(repl, " };", 2);
4693         SvCOMPILED_on(repl);
4694         SvREFCNT_dec(lex_repl);
4695         lex_repl = repl;
4696     }
4697
4698     pm->op_pmpermflags = pm->op_pmflags;
4699     lex_op = (OP*)pm;
4700     yylval.ival = OP_SUBST;
4701     return s;
4702 }
4703
4704 void
4705 hoistmust(pm)
4706 register PMOP *pm;
4707 {
4708     dTHR;
4709     if (!pm->op_pmshort && pm->op_pmregexp->regstart &&
4710         (!pm->op_pmregexp->regmust || pm->op_pmregexp->reganch & ROPT_ANCH)
4711        ) {
4712         if (!(pm->op_pmregexp->reganch & ROPT_ANCH))
4713             pm->op_pmflags |= PMf_SCANFIRST;
4714         pm->op_pmshort = SvREFCNT_inc(pm->op_pmregexp->regstart);
4715         pm->op_pmslen = SvCUR(pm->op_pmshort);
4716     }
4717     else if (pm->op_pmregexp->regmust) {/* is there a better short-circuit? */
4718         if (pm->op_pmshort &&
4719           sv_eq(pm->op_pmshort,pm->op_pmregexp->regmust))
4720         {
4721             if (pm->op_pmflags & PMf_SCANFIRST) {
4722                 SvREFCNT_dec(pm->op_pmshort);
4723                 pm->op_pmshort = Nullsv;
4724             }
4725             else {
4726                 SvREFCNT_dec(pm->op_pmregexp->regmust);
4727                 pm->op_pmregexp->regmust = Nullsv;
4728                 return;
4729             }
4730         }
4731         /* promote the better string */
4732         if ((!pm->op_pmshort &&
4733              !(pm->op_pmregexp->reganch & ROPT_ANCH_GPOS)) ||
4734             ((pm->op_pmflags & PMf_SCANFIRST) &&
4735              (SvCUR(pm->op_pmshort) < SvCUR(pm->op_pmregexp->regmust)))) {
4736             SvREFCNT_dec(pm->op_pmshort);               /* ok if null */
4737             pm->op_pmshort = pm->op_pmregexp->regmust;
4738             pm->op_pmslen = SvCUR(pm->op_pmshort);
4739             pm->op_pmregexp->regmust = Nullsv;
4740             pm->op_pmflags |= PMf_SCANFIRST;
4741         }
4742     }
4743 }
4744
4745 static char *
4746 scan_trans(start)
4747 char *start;
4748 {
4749     register char* s;
4750     OP *o;
4751     short *tbl;
4752     I32 squash;
4753     I32 delete;
4754     I32 complement;
4755
4756     yylval.ival = OP_NULL;
4757
4758     s = scan_str(start);
4759     if (!s) {
4760         if (lex_stuff)
4761             SvREFCNT_dec(lex_stuff);
4762         lex_stuff = Nullsv;
4763         croak("Translation pattern not terminated");
4764     }
4765     if (s[-1] == multi_open)
4766         s--;
4767
4768     s = scan_str(s);
4769     if (!s) {
4770         if (lex_stuff)
4771             SvREFCNT_dec(lex_stuff);
4772         lex_stuff = Nullsv;
4773         if (lex_repl)
4774             SvREFCNT_dec(lex_repl);
4775         lex_repl = Nullsv;
4776         croak("Translation replacement not terminated");
4777     }
4778
4779     New(803,tbl,256,short);
4780     o = newPVOP(OP_TRANS, 0, (char*)tbl);
4781
4782     complement = delete = squash = 0;
4783     while (*s == 'c' || *s == 'd' || *s == 's') {
4784         if (*s == 'c')
4785             complement = OPpTRANS_COMPLEMENT;
4786         else if (*s == 'd')
4787             delete = OPpTRANS_DELETE;
4788         else
4789             squash = OPpTRANS_SQUASH;
4790         s++;
4791     }
4792     o->op_private = delete|squash|complement;
4793
4794     lex_op = o;
4795     yylval.ival = OP_TRANS;
4796     return s;
4797 }
4798
4799 static char *
4800 scan_heredoc(s)
4801 register char *s;
4802 {
4803     dTHR;
4804     SV *herewas;
4805     I32 op_type = OP_SCALAR;
4806     I32 len;
4807     SV *tmpstr;
4808     char term;
4809     register char *d;
4810     register char *e;
4811     char *peek;
4812     int outer = (rsfp && !lex_inwhat);
4813
4814     s += 2;
4815     d = tokenbuf;
4816     e = tokenbuf + sizeof tokenbuf - 1;
4817     if (!outer)
4818         *d++ = '\n';
4819     for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
4820     if (*peek && strchr("`'\"",*peek)) {
4821         s = peek;
4822         term = *s++;
4823         s = delimcpy(d, e, s, bufend, term, &len);
4824         d += len;
4825         if (s < bufend)
4826             s++;
4827     }
4828     else {
4829         if (*s == '\\')
4830             s++, term = '\'';
4831         else
4832             term = '"';
4833         if (!isALNUM(*s))
4834             deprecate("bare << to mean <<\"\"");
4835         for (; isALNUM(*s); s++) {
4836             if (d < e)
4837                 *d++ = *s;
4838         }
4839     }
4840     if (d >= tokenbuf + sizeof tokenbuf - 1)
4841         croak("Delimiter for here document is too long");
4842     *d++ = '\n';
4843     *d = '\0';
4844     len = d - tokenbuf;
4845     d = "\n";
4846     if (outer || !(d=ninstr(s,bufend,d,d+1)))
4847         herewas = newSVpv(s,bufend-s);
4848     else
4849         s--, herewas = newSVpv(s,d-s);
4850     s += SvCUR(herewas);
4851
4852     tmpstr = NEWSV(87,80);
4853     sv_upgrade(tmpstr, SVt_PVIV);
4854     if (term == '\'') {
4855         op_type = OP_CONST;
4856         SvIVX(tmpstr) = -1;
4857     }
4858     else if (term == '`') {
4859         op_type = OP_BACKTICK;
4860         SvIVX(tmpstr) = '\\';
4861     }
4862
4863     CLINE;
4864     multi_start = curcop->cop_line;
4865     multi_open = multi_close = '<';
4866     term = *tokenbuf;
4867     if (!outer) {
4868         d = s;
4869         while (s < bufend &&
4870           (*s != term || memNE(s,tokenbuf,len)) ) {
4871             if (*s++ == '\n')
4872                 curcop->cop_line++;
4873         }
4874         if (s >= bufend) {
4875             curcop->cop_line = multi_start;
4876             missingterm(tokenbuf);
4877         }
4878         sv_setpvn(tmpstr,d+1,s-d);
4879         s += len - 1;
4880         sv_catpvn(herewas,s,bufend-s);
4881         sv_setsv(linestr,herewas);
4882         oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
4883         bufend = SvPVX(linestr) + SvCUR(linestr);
4884     }
4885     else
4886         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
4887     while (s >= bufend) {       /* multiple line string? */
4888         if (!outer ||
4889          !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
4890             curcop->cop_line = multi_start;
4891             missingterm(tokenbuf);
4892         }
4893         curcop->cop_line++;
4894         if (PERLDB_LINE && curstash != debstash) {
4895             SV *sv = NEWSV(88,0);
4896
4897             sv_upgrade(sv, SVt_PVMG);
4898             sv_setsv(sv,linestr);
4899             av_store(GvAV(curcop->cop_filegv),
4900               (I32)curcop->cop_line,sv);
4901         }
4902         bufend = SvPVX(linestr) + SvCUR(linestr);
4903         if (*s == term && memEQ(s,tokenbuf,len)) {
4904             s = bufend - 1;
4905             *s = ' ';
4906             sv_catsv(linestr,herewas);
4907             bufend = SvPVX(linestr) + SvCUR(linestr);
4908         }
4909         else {
4910             s = bufend;
4911             sv_catsv(tmpstr,linestr);
4912         }
4913     }
4914     multi_end = curcop->cop_line;
4915     s++;
4916     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
4917         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
4918         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
4919     }
4920     SvREFCNT_dec(herewas);
4921     lex_stuff = tmpstr;
4922     yylval.ival = op_type;
4923     return s;
4924 }
4925
4926 static char *
4927 scan_inputsymbol(start)
4928 char *start;
4929 {
4930     register char *s = start;
4931     register char *d;
4932     register char *e;
4933     I32 len;
4934
4935     d = tokenbuf;
4936     e = tokenbuf + sizeof tokenbuf;
4937     s = delimcpy(d, e, s + 1, bufend, '>', &len);
4938     if (len >= sizeof tokenbuf)
4939         croak("Excessively long <> operator");
4940     if (s >= bufend)
4941         croak("Unterminated <> operator");
4942     s++;
4943     if (*d == '$' && d[1]) d++;
4944     while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
4945         d++;
4946     if (d - tokenbuf != len) {
4947         yylval.ival = OP_GLOB;
4948         set_csh();
4949         s = scan_str(start);
4950         if (!s)
4951             croak("Glob not terminated");
4952         return s;
4953     }
4954     else {
4955         d = tokenbuf;
4956         if (!len)
4957             (void)strcpy(d,"ARGV");
4958         if (*d == '$') {
4959             I32 tmp;
4960             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
4961                 OP *o = newOP(OP_PADSV, 0);
4962                 o->op_targ = tmp;
4963                 lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
4964             }
4965             else {
4966                 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
4967                 lex_op = (OP*)newUNOP(OP_READLINE, 0,
4968                                         newUNOP(OP_RV2GV, 0,
4969                                             newUNOP(OP_RV2SV, 0,
4970                                                 newGVOP(OP_GV, 0, gv))));
4971             }
4972             yylval.ival = OP_NULL;
4973         }
4974         else {
4975             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
4976             lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
4977             yylval.ival = OP_NULL;
4978         }
4979     }
4980     return s;
4981 }
4982
4983 static char *
4984 scan_str(start)
4985 char *start;
4986 {
4987     dTHR;
4988     SV *sv;
4989     char *tmps;
4990     register char *s = start;
4991     register char term;
4992     register char *to;
4993     I32 brackets = 1;
4994
4995     if (isSPACE(*s))
4996         s = skipspace(s);
4997     CLINE;
4998     term = *s;
4999     multi_start = curcop->cop_line;
5000     multi_open = term;
5001     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5002         term = tmps[5];
5003     multi_close = term;
5004
5005     sv = NEWSV(87,80);
5006     sv_upgrade(sv, SVt_PVIV);
5007     SvIVX(sv) = term;
5008     (void)SvPOK_only(sv);               /* validate pointer */
5009     s++;
5010     for (;;) {
5011         SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
5012         to = SvPVX(sv)+SvCUR(sv);
5013         if (multi_open == multi_close) {
5014             for (; s < bufend; s++,to++) {
5015                 if (*s == '\n' && !rsfp)
5016                     curcop->cop_line++;
5017                 if (*s == '\\' && s+1 < bufend && term != '\\') {
5018                     if (s[1] == term)
5019                         s++;
5020                     else
5021                         *to++ = *s++;
5022                 }
5023                 else if (*s == term)
5024                     break;
5025                 *to = *s;
5026             }
5027         }
5028         else {
5029             for (; s < bufend; s++,to++) {
5030                 if (*s == '\n' && !rsfp)
5031                     curcop->cop_line++;
5032                 if (*s == '\\' && s+1 < bufend) {
5033                     if ((s[1] == multi_open) || (s[1] == multi_close))
5034                         s++;
5035                     else
5036                         *to++ = *s++;
5037                 }
5038                 else if (*s == multi_close && --brackets <= 0)
5039                     break;
5040                 else if (*s == multi_open)
5041                     brackets++;
5042                 *to = *s;
5043             }
5044         }
5045         *to = '\0';
5046         SvCUR_set(sv, to - SvPVX(sv));
5047
5048     if (s < bufend) break;      /* string ends on this line? */
5049
5050         if (!rsfp ||
5051          !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5052             sv_free(sv);
5053             curcop->cop_line = multi_start;
5054             return Nullch;
5055         }
5056         curcop->cop_line++;
5057         if (PERLDB_LINE && curstash != debstash) {
5058             SV *sv = NEWSV(88,0);
5059
5060             sv_upgrade(sv, SVt_PVMG);
5061             sv_setsv(sv,linestr);
5062             av_store(GvAV(curcop->cop_filegv),
5063               (I32)curcop->cop_line, sv);
5064         }
5065         bufend = SvPVX(linestr) + SvCUR(linestr);
5066     }
5067     multi_end = curcop->cop_line;
5068     s++;
5069     if (SvCUR(sv) + 5 < SvLEN(sv)) {
5070         SvLEN_set(sv, SvCUR(sv) + 1);
5071         Renew(SvPVX(sv), SvLEN(sv), char);
5072     }
5073     if (lex_stuff)
5074         lex_repl = sv;
5075     else
5076         lex_stuff = sv;
5077     return s;
5078 }
5079
5080 char *
5081 scan_num(start)
5082 char *start;
5083 {
5084     register char *s = start;
5085     register char *d;
5086     register char *e;
5087     I32 tryiv;
5088     double value;
5089     SV *sv;
5090     I32 floatit;
5091     char *lastub = 0;
5092     static char number_too_long[] = "Number too long";
5093
5094     switch (*s) {
5095     default:
5096         croak("panic: scan_num");
5097     case '0':
5098         {
5099             UV u;
5100             I32 shift;
5101             bool overflowed = FALSE;
5102
5103             if (s[1] == 'x') {
5104                 shift = 4;
5105                 s += 2;
5106             }
5107             else if (s[1] == '.')
5108                 goto decimal;
5109             else
5110                 shift = 3;
5111             u = 0;
5112             for (;;) {
5113                 UV n, b;
5114
5115                 switch (*s) {
5116                 default:
5117                     goto out;
5118                 case '_':
5119                     s++;
5120                     break;
5121                 case '8': case '9':
5122                     if (shift != 4)
5123                         yyerror("Illegal octal digit");
5124                     /* FALL THROUGH */
5125                 case '0': case '1': case '2': case '3': case '4':
5126                 case '5': case '6': case '7':
5127                     b = *s++ & 15;
5128                     goto digit;
5129                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5130                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5131                     if (shift != 4)
5132                         goto out;
5133                     b = (*s++ & 7) + 9;
5134                   digit:
5135                     n = u << shift;
5136                     if (!overflowed && (n >> shift) != u) {
5137                         warn("Integer overflow in %s number",
5138                              (shift == 4) ? "hex" : "octal");
5139                         overflowed = TRUE;
5140                     }
5141                     u = n | b;
5142                     break;
5143                 }
5144             }
5145           out:
5146             sv = NEWSV(92,0);
5147             sv_setuv(sv, u);
5148         }
5149         break;
5150     case '1': case '2': case '3': case '4': case '5':
5151     case '6': case '7': case '8': case '9': case '.':
5152       decimal:
5153         d = tokenbuf;
5154         e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
5155         floatit = FALSE;
5156         while (isDIGIT(*s) || *s == '_') {
5157             if (*s == '_') {
5158                 if (dowarn && lastub && s - lastub != 3)
5159                     warn("Misplaced _ in number");
5160                 lastub = ++s;
5161             }
5162             else {
5163                 if (d >= e)
5164                     croak(number_too_long);
5165                 *d++ = *s++;
5166             }
5167         }
5168         if (dowarn && lastub && s - lastub != 3)
5169             warn("Misplaced _ in number");
5170         if (*s == '.' && s[1] != '.') {
5171             floatit = TRUE;
5172             *d++ = *s++;
5173             for (; isDIGIT(*s) || *s == '_'; s++) {
5174                 if (d >= e)
5175                     croak(number_too_long);
5176                 if (*s != '_')
5177                     *d++ = *s;
5178             }
5179         }
5180         if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5181             floatit = TRUE;
5182             s++;
5183             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
5184             if (*s == '+' || *s == '-')
5185                 *d++ = *s++;
5186             while (isDIGIT(*s)) {
5187                 if (d >= e)
5188                     croak(number_too_long);
5189                 *d++ = *s++;
5190             }
5191         }
5192         *d = '\0';
5193         sv = NEWSV(92,0);
5194         SET_NUMERIC_STANDARD();
5195         value = atof(tokenbuf);
5196         tryiv = I_V(value);
5197         if (!floatit && (double)tryiv == value)
5198             sv_setiv(sv, tryiv);
5199         else
5200             sv_setnv(sv, value);
5201         break;
5202     }
5203
5204     yylval.opval = newSVOP(OP_CONST, 0, sv);
5205
5206     return s;
5207 }
5208
5209 static char *
5210 scan_formline(s)
5211 register char *s;
5212 {
5213     dTHR;
5214     register char *eol;
5215     register char *t;
5216     SV *stuff = newSVpv("",0);
5217     bool needargs = FALSE;
5218
5219     while (!needargs) {
5220         if (*s == '.' || *s == '}') {
5221             /*SUPPRESS 530*/
5222             for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5223             if (*t == '\n')
5224                 break;
5225         }
5226         if (in_eval && !rsfp) {
5227             eol = strchr(s,'\n');
5228             if (!eol++)
5229                 eol = bufend;
5230         }
5231         else
5232             eol = bufend = SvPVX(linestr) + SvCUR(linestr);
5233         if (*s != '#') {
5234             for (t = s; t < eol; t++) {
5235                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5236                     needargs = FALSE;
5237                     goto enough;        /* ~~ must be first line in formline */
5238                 }
5239                 if (*t == '@' || *t == '^')
5240                     needargs = TRUE;
5241             }
5242             sv_catpvn(stuff, s, eol-s);
5243         }
5244         s = eol;
5245         if (rsfp) {
5246             s = filter_gets(linestr, rsfp, 0);
5247             oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
5248             bufend = bufptr + SvCUR(linestr);
5249             if (!s) {
5250                 s = bufptr;
5251                 yyerror("Format not terminated");
5252                 break;
5253             }
5254         }
5255         incline(s);
5256     }
5257   enough:
5258     if (SvCUR(stuff)) {
5259         expect = XTERM;
5260         if (needargs) {
5261             lex_state = LEX_NORMAL;
5262             nextval[nexttoke].ival = 0;
5263             force_next(',');
5264         }
5265         else
5266             lex_state = LEX_FORMLINE;
5267         nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5268         force_next(THING);
5269         nextval[nexttoke].ival = OP_FORMLINE;
5270         force_next(LSTOP);
5271     }
5272     else {
5273         SvREFCNT_dec(stuff);
5274         lex_formbrack = 0;
5275         bufptr = s;
5276     }
5277     return s;
5278 }
5279
5280 static void
5281 set_csh()
5282 {
5283 #ifdef CSH
5284     if (!cshlen)
5285         cshlen = strlen(cshname);
5286 #endif
5287 }
5288
5289 I32
5290 start_subparse(is_format, flags)
5291 I32 is_format;
5292 U32 flags;
5293 {
5294     dTHR;
5295     I32 oldsavestack_ix = savestack_ix;
5296     CV* outsidecv = compcv;
5297     AV* comppadlist;
5298
5299     if (compcv) {
5300         assert(SvTYPE(compcv) == SVt_PVCV);
5301     }
5302     save_I32(&subline);
5303     save_item(subname);
5304     SAVEI32(padix);
5305     SAVESPTR(curpad);
5306     SAVESPTR(comppad);
5307     SAVESPTR(comppad_name);
5308     SAVESPTR(compcv);
5309     SAVEI32(comppad_name_fill);
5310     SAVEI32(min_intro_pending);
5311     SAVEI32(max_intro_pending);
5312     SAVEI32(pad_reset_pending);
5313
5314     compcv = (CV*)NEWSV(1104,0);
5315     sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
5316     CvFLAGS(compcv) |= flags;
5317
5318     comppad = newAV();
5319     av_push(comppad, Nullsv);
5320     curpad = AvARRAY(comppad);
5321     comppad_name = newAV();
5322     comppad_name_fill = 0;
5323     min_intro_pending = 0;
5324     padix = 0;
5325     subline = curcop->cop_line;
5326 #ifdef USE_THREADS
5327     av_store(comppad_name, 0, newSVpv("@_", 2));
5328     curpad[0] = (SV*)newAV();
5329     SvPADMY_on(curpad[0]);      /* XXX Needed? */
5330     CvOWNER(compcv) = 0;
5331     New(666, CvMUTEXP(compcv), 1, perl_mutex);
5332     MUTEX_INIT(CvMUTEXP(compcv));
5333 #endif /* USE_THREADS */
5334
5335     comppadlist = newAV();
5336     AvREAL_off(comppadlist);
5337     av_store(comppadlist, 0, (SV*)comppad_name);
5338     av_store(comppadlist, 1, (SV*)comppad);
5339
5340     CvPADLIST(compcv) = comppadlist;
5341     CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc((SV*)outsidecv);
5342 #ifdef USE_THREADS
5343     CvOWNER(compcv) = 0;
5344     New(666, CvMUTEXP(compcv), 1, perl_mutex);
5345     MUTEX_INIT(CvMUTEXP(compcv));
5346 #endif /* USE_THREADS */
5347
5348     return oldsavestack_ix;
5349 }
5350
5351 int
5352 yywarn(s)
5353 char *s;
5354 {
5355     dTHR;
5356     --error_count;
5357     in_eval |= 2;
5358     yyerror(s);
5359     in_eval &= ~2;
5360     return 0;
5361 }
5362
5363 int
5364 yyerror(s)
5365 char *s;
5366 {
5367     dTHR;
5368     char *where = NULL;
5369     char *context = NULL;
5370     int contlen = -1;
5371     SV *msg;
5372
5373     if (!yychar || (yychar == ';' && !rsfp))
5374         where = "at EOF";
5375     else if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
5376       oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
5377         while (isSPACE(*oldoldbufptr))
5378             oldoldbufptr++;
5379         context = oldoldbufptr;
5380         contlen = bufptr - oldoldbufptr;
5381     }
5382     else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
5383       oldbufptr != bufptr) {
5384         while (isSPACE(*oldbufptr))
5385             oldbufptr++;
5386         context = oldbufptr;
5387         contlen = bufptr - oldbufptr;
5388     }
5389     else if (yychar > 255)
5390         where = "next token ???";
5391     else if ((yychar & 127) == 127) {
5392         if (lex_state == LEX_NORMAL ||
5393            (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
5394             where = "at end of line";
5395         else if (lex_inpat)
5396             where = "within pattern";
5397         else
5398             where = "within string";
5399     }
5400     else {
5401         SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
5402         if (yychar < 32)
5403             sv_catpvf(where_sv, "^%c", toCTRL(yychar));
5404         else if (isPRINT_LC(yychar))
5405             sv_catpvf(where_sv, "%c", yychar);
5406         else
5407             sv_catpvf(where_sv, "\\%03o", yychar & 255);
5408         where = SvPVX(where_sv);
5409     }
5410     msg = sv_2mortal(newSVpv(s, 0));
5411     sv_catpvf(msg, " at %_ line %ld, ",
5412               GvSV(curcop->cop_filegv), (long)curcop->cop_line);
5413     if (context)
5414         sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
5415     else
5416         sv_catpvf(msg, "%s\n", where);
5417     if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
5418         sv_catpvf(msg,
5419         "  (Might be a runaway multi-line %c%c string starting on line %ld)\n",
5420                 (int)multi_open,(int)multi_close,(long)multi_start);
5421         multi_end = 0;
5422     }
5423     if (in_eval & 2)
5424         warn("%_", msg);
5425     else if (in_eval)
5426         sv_catsv(errsv, msg);
5427     else
5428         PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
5429     if (++error_count >= 10)
5430         croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
5431     in_my = 0;
5432     in_my_stash = Nullhv;
5433     return 0;
5434 }