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