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