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