toke.c

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