toke.c

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