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