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 | 8) : 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         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1206             len -= 2;
1207             tmpbuf[len] = '\0';
1208             goto bare_package;
1209         }
1210         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1211         if (indirgv && GvCVu(indirgv))
1212             return 0;
1213         /* filehandle or package name makes it a method */
1214         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1215             s = skipspace(s);
1216             if ((bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1217                 return 0;       /* no assumptions -- "=>" quotes bearword */
1218       bare_package:
1219             nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1220                                                    newSVpv(tmpbuf,0));
1221             nextval[nexttoke].opval->op_private = OPpCONST_BARE;
1222             expect = XTERM;
1223             force_next(WORD);
1224             bufptr = s;
1225             return *s == '(' ? FUNCMETH : METHOD;
1226         }
1227     }
1228     return 0;
1229 }
1230
1231 static char*
1232 incl_perldb(void)
1233 {
1234     if (perldb) {
1235         char *pdb = PerlEnv_getenv("PERL5DB");
1236
1237         if (pdb)
1238             return pdb;
1239         SETERRNO(0,SS$_NORMAL);
1240         return "BEGIN { require 'perl5db.pl' }";
1241     }
1242     return "";
1243 }
1244
1245
1246 /* Encoded script support. filter_add() effectively inserts a
1247  * 'pre-processing' function into the current source input stream.
1248  * Note that the filter function only applies to the current source file
1249  * (e.g., it will not affect files 'require'd or 'use'd by this one).
1250  *
1251  * The datasv parameter (which may be NULL) can be used to pass
1252  * private data to this instance of the filter. The filter function
1253  * can recover the SV using the FILTER_DATA macro and use it to
1254  * store private buffers and state information.
1255  *
1256  * The supplied datasv parameter is upgraded to a PVIO type
1257  * and the IoDIRP field is used to store the function pointer.
1258  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1259  * private use must be set using malloc'd pointers.
1260  */
1261 static int filter_debug = 0;
1262
1263 SV *
1264 filter_add(filter_t funcp, SV *datasv)
1265 {
1266     if (!funcp){ /* temporary handy debugging hack to be deleted */
1267         filter_debug = atoi((char*)datasv);
1268         return NULL;
1269     }
1270     if (!rsfp_filters)
1271         rsfp_filters = newAV();
1272     if (!datasv)
1273         datasv = NEWSV(255,0);
1274     if (!SvUPGRADE(datasv, SVt_PVIO))
1275         die("Can't upgrade filter_add data to SVt_PVIO");
1276     IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1277     if (filter_debug)
1278         warn("filter_add func %p (%s)", funcp, SvPV(datasv,na));
1279     av_unshift(rsfp_filters, 1);
1280     av_store(rsfp_filters, 0, datasv) ;
1281     return(datasv);
1282 }
1283
1284
1285 /* Delete most recently added instance of this filter function. */
1286 void
1287 filter_del(filter_t funcp)
1288 {
1289     if (filter_debug)
1290         warn("filter_del func %p", funcp);
1291     if (!rsfp_filters || AvFILLp(rsfp_filters)<0)
1292         return;
1293     /* if filter is on top of stack (usual case) just pop it off */
1294     if (IoDIRP(FILTER_DATA(AvFILLp(rsfp_filters))) == (void*)funcp){
1295         sv_free(av_pop(rsfp_filters));
1296
1297         return;
1298     }
1299     /* we need to search for the correct entry and clear it     */
1300     die("filter_del can only delete in reverse order (currently)");
1301 }
1302
1303
1304 /* Invoke the n'th filter function for the current rsfp.         */
1305 I32
1306 filter_read(int idx, SV *buf_sv, int maxlen)
1307
1308
1309                         /* 0 = read one text line */
1310 {
1311     filter_t funcp;
1312     SV *datasv = NULL;
1313
1314     if (!rsfp_filters)
1315         return -1;
1316     if (idx > AvFILLp(rsfp_filters)){       /* Any more filters?        */
1317         /* Provide a default input filter to make life easy.    */
1318         /* Note that we append to the line. This is handy.      */
1319         if (filter_debug)
1320             warn("filter_read %d: from rsfp\n", idx);
1321         if (maxlen) {
1322             /* Want a block */
1323             int len ;
1324             int old_len = SvCUR(buf_sv) ;
1325
1326             /* ensure buf_sv is large enough */
1327             SvGROW(buf_sv, old_len + maxlen) ;
1328             if ((len = PerlIO_read(rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1329                 if (PerlIO_error(rsfp))
1330                     return -1;          /* error */
1331                 else
1332                     return 0 ;          /* end of file */
1333             }
1334             SvCUR_set(buf_sv, old_len + len) ;
1335         } else {
1336             /* Want a line */
1337             if (sv_gets(buf_sv, rsfp, SvCUR(buf_sv)) == NULL) {
1338                 if (PerlIO_error(rsfp))
1339                     return -1;          /* error */
1340                 else
1341                     return 0 ;          /* end of file */
1342             }
1343         }
1344         return SvCUR(buf_sv);
1345     }
1346     /* Skip this filter slot if filter has been deleted */
1347     if ( (datasv = FILTER_DATA(idx)) == &sv_undef){
1348         if (filter_debug)
1349             warn("filter_read %d: skipped (filter deleted)\n", idx);
1350         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1351     }
1352     /* Get function pointer hidden within datasv        */
1353     funcp = (filter_t)IoDIRP(datasv);
1354     if (filter_debug)
1355         warn("filter_read %d: via function %p (%s)\n",
1356                 idx, funcp, SvPV(datasv,na));
1357     /* Call function. The function is expected to       */
1358     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
1359     /* Return: <0:error, =0:eof, >0:not eof             */
1360     return (*funcp)(idx, buf_sv, maxlen);
1361 }
1362
1363 static char *
1364 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1365 {
1366 #ifdef WIN32FILTER
1367     if (!rsfp_filters) {
1368         filter_add(win32_textfilter,NULL);
1369     }
1370 #endif
1371     if (rsfp_filters) {
1372
1373         if (!append)
1374             SvCUR_set(sv, 0);   /* start with empty line        */
1375         if (FILTER_READ(0, sv, 0) > 0)
1376             return ( SvPVX(sv) ) ;
1377         else
1378             return Nullch ;
1379     }
1380     else
1381         return (sv_gets(sv, fp, append));
1382 }
1383
1384
1385 #ifdef DEBUGGING
1386     static char* exp_name[] =
1387         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1388 #endif
1389
1390 EXT int yychar;         /* last token */
1391
1392 /*
1393   yylex
1394
1395   Works out what to call the token just pulled out of the input
1396   stream.  The yacc parser takes care of taking the ops we return and
1397   stitching them into a tree.
1398
1399   Returns:
1400     PRIVATEREF
1401
1402   Structure:
1403       if read an identifier
1404           if we're in a my declaration
1405               croak if they tried to say my($foo::bar)
1406               build the ops for a my() declaration
1407           if it's an access to a my() variable
1408               are we in a sort block?
1409                   croak if my($a); $a <=> $b
1410               build ops for access to a my() variable
1411           if in a dq string, and they've said @foo and we can't find @foo
1412               croak
1413           build ops for a bareword
1414       if we already built the token before, use it.
1415 */
1416
1417 int
1418 yylex(void)
1419 {
1420     dTHR;
1421     register char *s;
1422     register char *d;
1423     register I32 tmp;
1424     STRLEN len;
1425     GV *gv = Nullgv;
1426     GV **gvp = 0;
1427
1428     /* check if there's an identifier for us to look at */
1429     if (pending_ident) {
1430         /* pit holds the identifier we read and pending_ident is reset */
1431         char pit = pending_ident;
1432         pending_ident = 0;
1433
1434         /* if we're in a my(), we can't allow dynamics here.
1435            $foo'bar has already been turned into $foo::bar, so
1436            just check for colons.
1437
1438            if it's a legal name, the OP is a PADANY.
1439         */
1440         if (in_my) {
1441             if (strchr(tokenbuf,':'))
1442                 croak(no_myglob,tokenbuf);
1443
1444             yylval.opval = newOP(OP_PADANY, 0);
1445             yylval.opval->op_targ = pad_allocmy(tokenbuf);
1446             return PRIVATEREF;
1447         }
1448
1449         /*
1450            build the ops for accesses to a my() variable.
1451
1452            Deny my($a) or my($b) in a sort block, *if* $a or $b is
1453            then used in a comparison.  This catches most, but not
1454            all cases.  For instance, it catches
1455                sort { my($a); $a <=> $b }
1456            but not
1457                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1458            (although why you'd do that is anyone's guess).
1459         */
1460
1461         if (!strchr(tokenbuf,':')) {
1462 #ifdef USE_THREADS
1463             /* Check for single character per-thread SVs */
1464             if (tokenbuf[0] == '$' && tokenbuf[2] == '\0'
1465                 && !isALPHA(tokenbuf[1]) /* Rule out obvious non-threadsvs */
1466                 && (tmp = find_threadsv(&tokenbuf[1])) != NOT_IN_PAD)
1467             {
1468                 yylval.opval = newOP(OP_THREADSV, 0);
1469                 yylval.opval->op_targ = tmp;
1470                 return PRIVATEREF;
1471             }
1472 #endif /* USE_THREADS */
1473             if ((tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) {
1474                 /* if it's a sort block and they're naming $a or $b */
1475                 if (last_lop_op == OP_SORT &&
1476                     tokenbuf[0] == '$' &&
1477                     (tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
1478                     && !tokenbuf[2])
1479                 {
1480                     for (d = in_eval ? oldoldbufptr : linestart;
1481                          d < bufend && *d != '\n';
1482                          d++)
1483                     {
1484                         if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1485                             croak("Can't use \"my %s\" in sort comparison",
1486                                   tokenbuf);
1487                         }
1488                     }
1489                 }
1490
1491                 yylval.opval = newOP(OP_PADANY, 0);
1492                 yylval.opval->op_targ = tmp;
1493                 return PRIVATEREF;
1494             }
1495         }
1496
1497         /*
1498            Whine if they've said @foo in a doublequoted string,
1499            and @foo isn't a variable we can find in the symbol
1500            table.
1501         */
1502         if (pit == '@' && lex_state != LEX_NORMAL && !lex_brackets) {
1503             GV *gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV);
1504             if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1505                 yyerror(form("In string, %s now must be written as \\%s",
1506                              tokenbuf, tokenbuf));
1507         }
1508
1509         /* build ops for a bareword */
1510         yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0));
1511         yylval.opval->op_private = OPpCONST_ENTERED;
1512         gv_fetchpv(tokenbuf+1, in_eval ? (GV_ADDMULTI | 8) : TRUE,
1513                    ((tokenbuf[0] == '$') ? SVt_PV
1514                     : (tokenbuf[0] == '@') ? SVt_PVAV
1515                     : SVt_PVHV));
1516         return WORD;
1517     }
1518
1519     /* no identifier pending identification */
1520
1521     switch (lex_state) {
1522 #ifdef COMMENTARY
1523     case LEX_NORMAL:            /* Some compilers will produce faster */
1524     case LEX_INTERPNORMAL:      /* code if we comment these out. */
1525         break;
1526 #endif
1527
1528     /* when we're already built the next token, just pull it out the queue */
1529     case LEX_KNOWNEXT:
1530         nexttoke--;
1531         yylval = nextval[nexttoke];
1532         if (!nexttoke) {
1533             lex_state = lex_defer;
1534             expect = lex_expect;
1535             lex_defer = LEX_NORMAL;
1536         }
1537         return(nexttype[nexttoke]);
1538
1539     /* interpolated case modifiers like \L \U, including \Q and \E.
1540        when we get here, bufptr is at the \
1541     */
1542     case LEX_INTERPCASEMOD:
1543 #ifdef DEBUGGING
1544         if (bufptr != bufend && *bufptr != '\\')
1545             croak("panic: INTERPCASEMOD");
1546 #endif
1547         /* handle \E or end of string */
1548         if (bufptr == bufend || bufptr[1] == 'E') {
1549             char oldmod;
1550
1551             /* if at a \E */
1552             if (lex_casemods) {
1553                 oldmod = lex_casestack[--lex_casemods];
1554                 lex_casestack[lex_casemods] = '\0';
1555
1556                 if (bufptr != bufend && strchr("LUQ", oldmod)) {
1557                     bufptr += 2;
1558                     lex_state = LEX_INTERPCONCAT;
1559                 }
1560                 return ')';
1561             }
1562             if (bufptr != bufend)
1563                 bufptr += 2;
1564             lex_state = LEX_INTERPCONCAT;
1565             return yylex();
1566         }
1567         else {
1568             s = bufptr + 1;
1569             if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1570                 tmp = *s, *s = s[2], s[2] = tmp;        /* misordered... */
1571             if (strchr("LU", *s) &&
1572                 (strchr(lex_casestack, 'L') || strchr(lex_casestack, 'U')))
1573             {
1574                 lex_casestack[--lex_casemods] = '\0';
1575                 return ')';
1576             }
1577             if (lex_casemods > 10) {
1578                 char* newlb = Renew(lex_casestack, lex_casemods + 2, char);
1579                 if (newlb != lex_casestack) {
1580                     SAVEFREEPV(newlb);
1581                     lex_casestack = newlb;
1582                 }
1583             }
1584             lex_casestack[lex_casemods++] = *s;
1585             lex_casestack[lex_casemods] = '\0';
1586             lex_state = LEX_INTERPCONCAT;
1587             nextval[nexttoke].ival = 0;
1588             force_next('(');
1589             if (*s == 'l')
1590                 nextval[nexttoke].ival = OP_LCFIRST;
1591             else if (*s == 'u')
1592                 nextval[nexttoke].ival = OP_UCFIRST;
1593             else if (*s == 'L')
1594                 nextval[nexttoke].ival = OP_LC;
1595             else if (*s == 'U')
1596                 nextval[nexttoke].ival = OP_UC;
1597             else if (*s == 'Q')
1598                 nextval[nexttoke].ival = OP_QUOTEMETA;
1599             else
1600                 croak("panic: yylex");
1601             bufptr = s + 1;
1602             force_next(FUNC);
1603             if (lex_starts) {
1604                 s = bufptr;
1605                 lex_starts = 0;
1606                 Aop(OP_CONCAT);
1607             }
1608             else
1609                 return yylex();
1610         }
1611
1612     case LEX_INTERPPUSH:
1613         return sublex_push();
1614
1615     case LEX_INTERPSTART:
1616         if (bufptr == bufend)
1617             return sublex_done();
1618         expect = XTERM;
1619         lex_dojoin = (*bufptr == '@');
1620         lex_state = LEX_INTERPNORMAL;
1621         if (lex_dojoin) {
1622             nextval[nexttoke].ival = 0;
1623             force_next(',');
1624 #ifdef USE_THREADS
1625             nextval[nexttoke].opval = newOP(OP_THREADSV, 0);
1626             nextval[nexttoke].opval->op_targ = find_threadsv("\"");
1627             force_next(PRIVATEREF);
1628 #else
1629             force_ident("\"", '$');
1630 #endif /* USE_THREADS */
1631             nextval[nexttoke].ival = 0;
1632             force_next('$');
1633             nextval[nexttoke].ival = 0;
1634             force_next('(');
1635             nextval[nexttoke].ival = OP_JOIN;   /* emulate join($", ...) */
1636             force_next(FUNC);
1637         }
1638         if (lex_starts++) {
1639             s = bufptr;
1640             Aop(OP_CONCAT);
1641         }
1642         return yylex();
1643
1644     case LEX_INTERPENDMAYBE:
1645         if (intuit_more(bufptr)) {
1646             lex_state = LEX_INTERPNORMAL;       /* false alarm, more expr */
1647             break;
1648         }
1649         /* FALL THROUGH */
1650
1651     case LEX_INTERPEND:
1652         if (lex_dojoin) {
1653             lex_dojoin = FALSE;
1654             lex_state = LEX_INTERPCONCAT;
1655             return ')';
1656         }
1657         /* FALLTHROUGH */
1658     case LEX_INTERPCONCAT:
1659 #ifdef DEBUGGING
1660         if (lex_brackets)
1661             croak("panic: INTERPCONCAT");
1662 #endif
1663         if (bufptr == bufend)
1664             return sublex_done();
1665
1666         if (SvIVX(linestr) == '\'') {
1667             SV *sv = newSVsv(linestr);
1668             if (!lex_inpat)
1669                 sv = q(sv);
1670             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1671             s = bufend;
1672         }
1673         else {
1674             s = scan_const(bufptr);
1675             if (*s == '\\')
1676                 lex_state = LEX_INTERPCASEMOD;
1677             else
1678                 lex_state = LEX_INTERPSTART;
1679         }
1680
1681         if (s != bufptr) {
1682             nextval[nexttoke] = yylval;
1683             expect = XTERM;
1684             force_next(THING);
1685             if (lex_starts++)
1686                 Aop(OP_CONCAT);
1687             else {
1688                 bufptr = s;
1689                 return yylex();
1690             }
1691         }
1692
1693         return yylex();
1694     case LEX_FORMLINE:
1695         lex_state = LEX_NORMAL;
1696         s = scan_formline(bufptr);
1697         if (!lex_formbrack)
1698             goto rightbracket;
1699         OPERATOR(';');
1700     }
1701
1702     s = bufptr;
1703     oldoldbufptr = oldbufptr;
1704     oldbufptr = s;
1705     DEBUG_p( {
1706         PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[expect], s);
1707     } )
1708
1709   retry:
1710     switch (*s) {
1711     default:
1712         croak("Unrecognized character \\%03o", *s & 255);
1713     case 4:
1714     case 26:
1715         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
1716     case 0:
1717         if (!rsfp) {
1718             last_uni = 0;
1719             last_lop = 0;
1720             if (lex_brackets)
1721                 yyerror("Missing right bracket");
1722             TOKEN(0);
1723         }
1724         if (s++ < bufend)
1725             goto retry;                 /* ignore stray nulls */
1726         last_uni = 0;
1727         last_lop = 0;
1728         if (!in_eval && !preambled) {
1729             preambled = TRUE;
1730             sv_setpv(linestr,incl_perldb());
1731             if (SvCUR(linestr))
1732                 sv_catpv(linestr,";");
1733             if (preambleav){
1734                 while(AvFILLp(preambleav) >= 0) {
1735                     SV *tmpsv = av_shift(preambleav);
1736                     sv_catsv(linestr, tmpsv);
1737                     sv_catpv(linestr, ";");
1738                     sv_free(tmpsv);
1739                 }
1740                 sv_free((SV*)preambleav);
1741                 preambleav = NULL;
1742             }
1743             if (minus_n || minus_p) {
1744                 sv_catpv(linestr, "LINE: while (<>) {");
1745                 if (minus_l)
1746                     sv_catpv(linestr,"chomp;");
1747                 if (minus_a) {
1748                     GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1749                     if (gv)
1750                         GvIMPORTED_AV_on(gv);
1751                     if (minus_F) {
1752                         if (strchr("/'\"", *splitstr)
1753                               && strchr(splitstr + 1, *splitstr))
1754                             sv_catpvf(linestr, "@F=split(%s);", splitstr);
1755                         else {
1756                             char delim;
1757                             s = "'~#\200\1'"; /* surely one char is unused...*/
1758                             while (s[1] && strchr(splitstr, *s))  s++;
1759                             delim = *s;
1760                             sv_catpvf(linestr, "@F=split(%s%c",
1761                                       "q" + (delim == '\''), delim);
1762                             for (s = splitstr; *s; s++) {
1763                                 if (*s == '\\')
1764                                     sv_catpvn(linestr, "\\", 1);
1765                                 sv_catpvn(linestr, s, 1);
1766                             }
1767                             sv_catpvf(linestr, "%c);", delim);
1768                         }
1769                     }
1770                     else
1771                         sv_catpv(linestr,"@F=split(' ');");
1772                 }
1773             }
1774             sv_catpv(linestr, "\n");
1775             oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1776             bufend = SvPVX(linestr) + SvCUR(linestr);
1777             if (PERLDB_LINE && curstash != debstash) {
1778                 SV *sv = NEWSV(85,0);
1779
1780                 sv_upgrade(sv, SVt_PVMG);
1781                 sv_setsv(sv,linestr);
1782                 av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1783             }
1784             goto retry;
1785         }
1786         do {
1787             if ((s = filter_gets(linestr, rsfp, 0)) == Nullch) {
1788               fake_eof:
1789                 if (rsfp) {
1790                     if (preprocess && !in_eval)
1791                         (void)PerlProc_pclose(rsfp);
1792                     else if ((PerlIO *)rsfp == PerlIO_stdin())
1793                         PerlIO_clearerr(rsfp);
1794                     else
1795                         (void)PerlIO_close(rsfp);
1796                     if (e_fp == rsfp)
1797                         e_fp = Nullfp;
1798                     rsfp = Nullfp;
1799                 }
1800                 if (!in_eval && (minus_n || minus_p)) {
1801                     sv_setpv(linestr,minus_p ? ";}continue{print" : "");
1802                     sv_catpv(linestr,";}");
1803                     oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1804                     bufend = SvPVX(linestr) + SvCUR(linestr);
1805                     minus_n = minus_p = 0;
1806                     goto retry;
1807                 }
1808                 oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1809                 sv_setpv(linestr,"");
1810                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
1811             }
1812             if (doextract) {
1813                 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1814                     doextract = FALSE;
1815
1816                 /* Incest with pod. */
1817                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1818                     sv_setpv(linestr, "");
1819                     oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1820                     bufend = SvPVX(linestr) + SvCUR(linestr);
1821                     doextract = FALSE;
1822                 }
1823             }
1824             incline(s);
1825         } while (doextract);
1826         oldoldbufptr = oldbufptr = bufptr = linestart = s;
1827         if (PERLDB_LINE && curstash != debstash) {
1828             SV *sv = NEWSV(85,0);
1829
1830             sv_upgrade(sv, SVt_PVMG);
1831             sv_setsv(sv,linestr);
1832             av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
1833         }
1834         bufend = SvPVX(linestr) + SvCUR(linestr);
1835         if (curcop->cop_line == 1) {
1836             while (s < bufend && isSPACE(*s))
1837                 s++;
1838             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1839                 s++;
1840             d = Nullch;
1841             if (!in_eval) {
1842                 if (*s == '#' && *(s+1) == '!')
1843                     d = s + 2;
1844 #ifdef ALTERNATE_SHEBANG
1845                 else {
1846                     static char as[] = ALTERNATE_SHEBANG;
1847                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
1848                         d = s + (sizeof(as) - 1);
1849                 }
1850 #endif /* ALTERNATE_SHEBANG */
1851             }
1852             if (d) {
1853                 char *ipath;
1854                 char *ipathend;
1855
1856                 while (isSPACE(*d))
1857                     d++;
1858                 ipath = d;
1859                 while (*d && !isSPACE(*d))
1860                     d++;
1861                 ipathend = d;
1862
1863 #ifdef ARG_ZERO_IS_SCRIPT
1864                 if (ipathend > ipath) {
1865                     /*
1866                      * HP-UX (at least) sets argv[0] to the script name,
1867                      * which makes $^X incorrect.  And Digital UNIX and Linux,
1868                      * at least, set argv[0] to the basename of the Perl
1869                      * interpreter. So, having found "#!", we'll set it right.
1870                      */
1871                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
1872                     assert(SvPOK(x) || SvGMAGICAL(x));
1873                     if (sv_eq(x, GvSV(curcop->cop_filegv))) {
1874                         sv_setpvn(x, ipath, ipathend - ipath);
1875                         SvSETMAGIC(x);
1876                     }
1877                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
1878                 }
1879 #endif /* ARG_ZERO_IS_SCRIPT */
1880
1881                 /*
1882                  * Look for options.
1883                  */
1884                 d = instr(s,"perl -");
1885                 if (!d)
1886                     d = instr(s,"perl");
1887 #ifdef ALTERNATE_SHEBANG
1888                 /*
1889                  * If the ALTERNATE_SHEBANG on this system starts with a
1890                  * character that can be part of a Perl expression, then if
1891                  * we see it but not "perl", we're probably looking at the
1892                  * start of Perl code, not a request to hand off to some
1893                  * other interpreter.  Similarly, if "perl" is there, but
1894                  * not in the first 'word' of the line, we assume the line
1895                  * contains the start of the Perl program.
1896                  */
1897                 if (d && *s != '#') {
1898                     char *c = ipath;
1899                     while (*c && !strchr("; \t\r\n\f\v#", *c))
1900                         c++;
1901                     if (c < d)
1902                         d = Nullch;     /* "perl" not in first word; ignore */
1903                     else
1904                         *s = '#';       /* Don't try to parse shebang line */
1905                 }
1906 #endif /* ALTERNATE_SHEBANG */
1907                 if (!d &&
1908                     *s == '#' &&
1909                     ipathend > ipath &&
1910                     !minus_c &&
1911                     !instr(s,"indir") &&
1912                     instr(origargv[0],"perl"))
1913                 {
1914                     char **newargv;
1915
1916                     *ipathend = '\0';
1917                     s = ipathend + 1;
1918                     while (s < bufend && isSPACE(*s))
1919                         s++;
1920                     if (s < bufend) {
1921                         Newz(899,newargv,origargc+3,char*);
1922                         newargv[1] = s;
1923                         while (s < bufend && !isSPACE(*s))
1924                             s++;
1925                         *s = '\0';
1926                         Copy(origargv+1, newargv+2, origargc+1, char*);
1927                     }
1928                     else
1929                         newargv = origargv;
1930                     newargv[0] = ipath;
1931                     execv(ipath, newargv);
1932                     croak("Can't exec %s", ipath);
1933                 }
1934                 if (d) {
1935                     U32 oldpdb = perldb;
1936                     bool oldn = minus_n;
1937                     bool oldp = minus_p;
1938
1939                     while (*d && !isSPACE(*d)) d++;
1940                     while (*d == ' ' || *d == '\t') d++;
1941
1942                     if (*d++ == '-') {
1943                         do {
1944                             if (*d == 'M' || *d == 'm') {
1945                                 char *m = d;
1946                                 while (*d && !isSPACE(*d)) d++;
1947                                 croak("Too late for \"-%.*s\" option",
1948                                       (int)(d - m), m);
1949                             }
1950                             d = moreswitches(d);
1951                         } while (d);
1952                         if (PERLDB_LINE && !oldpdb ||
1953                             ( minus_n || minus_p ) && !(oldn || oldp) )
1954                               /* if we have already added "LINE: while (<>) {",
1955                                  we must not do it again */
1956                         {
1957                             sv_setpv(linestr, "");
1958                             oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
1959                             bufend = SvPVX(linestr) + SvCUR(linestr);
1960                             preambled = FALSE;
1961                             if (PERLDB_LINE)
1962                                 (void)gv_fetchfile(origfilename);
1963                             goto retry;
1964                         }
1965                     }
1966                 }
1967             }
1968         }
1969         if (lex_formbrack && lex_brackets <= lex_formbrack) {
1970             bufptr = s;
1971             lex_state = LEX_FORMLINE;
1972             return yylex();
1973         }
1974         goto retry;
1975     case '\r':
1976 #ifndef WIN32CHEAT
1977         warn("Illegal character \\%03o (carriage return)", '\r');
1978         croak(
1979       "(Maybe you didn't strip carriage returns after a network transfer?)\n");
1980 #endif
1981     case ' ': case '\t': case '\f': case 013:
1982         s++;
1983         goto retry;
1984     case '#':
1985     case '\n':
1986         if (lex_state != LEX_NORMAL || (in_eval && !rsfp)) {
1987             d = bufend;
1988             while (s < d && *s != '\n')
1989                 s++;
1990             if (s < d)
1991                 s++;
1992             incline(s);
1993             if (lex_formbrack && lex_brackets <= lex_formbrack) {
1994                 bufptr = s;
1995                 lex_state = LEX_FORMLINE;
1996                 return yylex();
1997             }
1998         }
1999         else {
2000             *s = '\0';
2001             bufend = s;
2002         }
2003         goto retry;
2004     case '-':
2005         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2006             s++;
2007             bufptr = s;
2008             tmp = *s++;
2009
2010             while (s < bufend && (*s == ' ' || *s == '\t'))
2011                 s++;
2012
2013             if (strnEQ(s,"=>",2)) {
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                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2216                     if (minus)
2217                         force_next('-');
2218                 }
2219             }
2220             /* FALL THROUGH */
2221         case XBLOCK:
2222             lex_brackstack[lex_brackets++] = XSTATE;
2223             expect = XSTATE;
2224             break;
2225         case XTERMBLOCK:
2226             lex_brackstack[lex_brackets++] = XOPERATOR;
2227             expect = XSTATE;
2228             break;
2229         default: {
2230                 char *t;
2231                 if (oldoldbufptr == last_lop)
2232                     lex_brackstack[lex_brackets++] = XTERM;
2233                 else
2234                     lex_brackstack[lex_brackets++] = XOPERATOR;
2235                 s = skipspace(s);
2236                 if (*s == '}') {
2237                     if (expect == XSTATE) {
2238                         lex_brackstack[lex_brackets-1] = XSTATE;
2239                         break;
2240                     }
2241                     OPERATOR(HASHBRACK);
2242                 }
2243                 /* This hack serves to disambiguate a pair of curlies
2244                  * as being a block or an anon hash.  Normally, expectation
2245                  * determines that, but in cases where we're not in a
2246                  * position to expect anything in particular (like inside
2247                  * eval"") we have to resolve the ambiguity.  This code
2248                  * covers the case where the first term in the curlies is a
2249                  * quoted string.  Most other cases need to be explicitly
2250                  * disambiguated by prepending a `+' before the opening
2251                  * curly in order to force resolution as an anon hash.
2252                  *
2253                  * XXX should probably propagate the outer expectation
2254                  * into eval"" to rely less on this hack, but that could
2255                  * potentially break current behavior of eval"".
2256                  * GSAR 97-07-21
2257                  */
2258                 t = s;
2259                 if (*s == '\'' || *s == '"' || *s == '`') {
2260                     /* common case: get past first string, handling escapes */
2261                     for (t++; t < bufend && *t != *s;)
2262                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
2263                             t++;
2264                     t++;
2265                 }
2266                 else if (*s == 'q') {
2267                     if (++t < bufend
2268                         && (!isALNUM(*t)
2269                             || ((*t == 'q' || *t == 'x') && ++t < bufend
2270                                 && !isALNUM(*t)))) {
2271                         char *tmps;
2272                         char open, close, term;
2273                         I32 brackets = 1;
2274
2275                         while (t < bufend && isSPACE(*t))
2276                             t++;
2277                         term = *t;
2278                         open = term;
2279                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2280                             term = tmps[5];
2281                         close = term;
2282                         if (open == close)
2283                             for (t++; t < bufend; t++) {
2284                                 if (*t == '\\' && t+1 < bufend && open != '\\')
2285                                     t++;
2286                                 else if (*t == open)
2287                                     break;
2288                             }
2289                         else
2290                             for (t++; t < bufend; t++) {
2291                                 if (*t == '\\' && t+1 < bufend)
2292                                     t++;
2293                                 else if (*t == close && --brackets <= 0)
2294                                     break;
2295                                 else if (*t == open)
2296                                     brackets++;
2297                             }
2298                     }
2299                     t++;
2300                 }
2301                 else if (isALPHA(*s)) {
2302                     for (t++; t < bufend && isALNUM(*t); t++) ;
2303                 }
2304                 while (t < bufend && isSPACE(*t))
2305                     t++;
2306                 /* if comma follows first term, call it an anon hash */
2307                 /* XXX it could be a comma expression with loop modifiers */
2308                 if (t < bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2309                                    || (*t == '=' && t[1] == '>')))
2310                     OPERATOR(HASHBRACK);
2311                 if (expect == XREF)
2312                     expect = XTERM;
2313                 else {
2314                     lex_brackstack[lex_brackets-1] = XSTATE;
2315                     expect = XSTATE;
2316                 }
2317             }
2318             break;
2319         }
2320         yylval.ival = curcop->cop_line;
2321         if (isSPACE(*s) || *s == '#')
2322             copline = NOLINE;   /* invalidate current command line number */
2323         TOKEN('{');
2324     case '}':
2325       rightbracket:
2326         s++;
2327         if (lex_brackets <= 0)
2328             yyerror("Unmatched right bracket");
2329         else
2330             expect = (expectation)lex_brackstack[--lex_brackets];
2331         if (lex_brackets < lex_formbrack)
2332             lex_formbrack = 0;
2333         if (lex_state == LEX_INTERPNORMAL) {
2334             if (lex_brackets == 0) {
2335                 if (lex_fakebrack) {
2336                     lex_state = LEX_INTERPEND;
2337                     bufptr = s;
2338                     return yylex();             /* ignore fake brackets */
2339                 }
2340                 if (*s == '-' && s[1] == '>')
2341                     lex_state = LEX_INTERPENDMAYBE;
2342                 else if (*s != '[' && *s != '{')
2343                     lex_state = LEX_INTERPEND;
2344             }
2345         }
2346         if (lex_brackets < lex_fakebrack) {
2347             bufptr = s;
2348             lex_fakebrack = 0;
2349             return yylex();             /* ignore fake brackets */
2350         }
2351         force_next('}');
2352         TOKEN(';');
2353     case '&':
2354         s++;
2355         tmp = *s++;
2356         if (tmp == '&')
2357             AOPERATOR(ANDAND);
2358         s--;
2359         if (expect == XOPERATOR) {
2360             if (dowarn && isALPHA(*s) && bufptr == linestart) {
2361                 curcop->cop_line--;
2362                 warn(warn_nosemi);
2363                 curcop->cop_line++;
2364             }
2365             BAop(OP_BIT_AND);
2366         }
2367
2368         s = scan_ident(s - 1, bufend, tokenbuf, sizeof tokenbuf, TRUE);
2369         if (*tokenbuf) {
2370             expect = XOPERATOR;
2371             force_ident(tokenbuf, '&');
2372         }
2373         else
2374             PREREF('&');
2375         yylval.ival = (OPpENTERSUB_AMPER<<8);
2376         TERM('&');
2377
2378     case '|':
2379         s++;
2380         tmp = *s++;
2381         if (tmp == '|')
2382             AOPERATOR(OROR);
2383         s--;
2384         BOop(OP_BIT_OR);
2385     case '=':
2386         s++;
2387         tmp = *s++;
2388         if (tmp == '=')
2389             Eop(OP_EQ);
2390         if (tmp == '>')
2391             OPERATOR(',');
2392         if (tmp == '~')
2393             PMop(OP_MATCH);
2394         if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2395             warn("Reversed %c= operator",(int)tmp);
2396         s--;
2397         if (expect == XSTATE && isALPHA(tmp) &&
2398                 (s == linestart+1 || s[-2] == '\n') )
2399         {
2400             if (in_eval && !rsfp) {
2401                 d = bufend;
2402                 while (s < d) {
2403                     if (*s++ == '\n') {
2404                         incline(s);
2405                         if (strnEQ(s,"=cut",4)) {
2406                             s = strchr(s,'\n');
2407                             if (s)
2408                                 s++;
2409                             else
2410                                 s = d;
2411                             incline(s);
2412                             goto retry;
2413                         }
2414                     }
2415                 }
2416                 goto retry;
2417             }
2418             s = bufend;
2419             doextract = TRUE;
2420             goto retry;
2421         }
2422         if (lex_brackets < lex_formbrack) {
2423             char *t;
2424             for (t = s; *t == ' ' || *t == '\t'; t++) ;
2425             if (*t == '\n' || *t == '#') {
2426                 s--;
2427                 expect = XBLOCK;
2428                 goto leftbracket;
2429             }
2430         }
2431         yylval.ival = 0;
2432         OPERATOR(ASSIGNOP);
2433     case '!':
2434         s++;
2435         tmp = *s++;
2436         if (tmp == '=')
2437             Eop(OP_NE);
2438         if (tmp == '~')
2439             PMop(OP_NOT);
2440         s--;
2441         OPERATOR('!');
2442     case '<':
2443         if (expect != XOPERATOR) {
2444             if (s[1] != '<' && !strchr(s,'>'))
2445                 check_uni();
2446             if (s[1] == '<')
2447                 s = scan_heredoc(s);
2448             else
2449                 s = scan_inputsymbol(s);
2450             TERM(sublex_start());
2451         }
2452         s++;
2453         tmp = *s++;
2454         if (tmp == '<')
2455             SHop(OP_LEFT_SHIFT);
2456         if (tmp == '=') {
2457             tmp = *s++;
2458             if (tmp == '>')
2459                 Eop(OP_NCMP);
2460             s--;
2461             Rop(OP_LE);
2462         }
2463         s--;
2464         Rop(OP_LT);
2465     case '>':
2466         s++;
2467         tmp = *s++;
2468         if (tmp == '>')
2469             SHop(OP_RIGHT_SHIFT);
2470         if (tmp == '=')
2471             Rop(OP_GE);
2472         s--;
2473         Rop(OP_GT);
2474
2475     case '$':
2476         CLINE;
2477
2478         if (expect == XOPERATOR) {
2479             if (lex_formbrack && lex_brackets == lex_formbrack) {
2480                 expect = XTERM;
2481                 depcom();
2482                 return ','; /* grandfather non-comma-format format */
2483             }
2484         }
2485
2486         if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
2487             if (expect == XOPERATOR)
2488                 no_op("Array length", bufptr);
2489             tokenbuf[0] = '@';
2490             s = scan_ident(s + 1, bufend, tokenbuf + 1, sizeof tokenbuf - 1,
2491                            FALSE);
2492             if (!tokenbuf[1])
2493                 PREREF(DOLSHARP);
2494             expect = XOPERATOR;
2495             pending_ident = '#';
2496             TOKEN(DOLSHARP);
2497         }
2498
2499         if (expect == XOPERATOR)
2500             no_op("Scalar", bufptr);
2501         tokenbuf[0] = '$';
2502         s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2503         if (!tokenbuf[1]) {
2504             if (s == bufend)
2505                 yyerror("Final $ should be \\$ or $name");
2506             PREREF('$');
2507         }
2508
2509         /* This kludge not intended to be bulletproof. */
2510         if (tokenbuf[1] == '[' && !tokenbuf[2]) {
2511             yylval.opval = newSVOP(OP_CONST, 0,
2512                                    newSViv((IV)compiling.cop_arybase));
2513             yylval.opval->op_private = OPpCONST_ARYBASE;
2514             TERM(THING);
2515         }
2516
2517         d = s;
2518         if (lex_state == LEX_NORMAL)
2519             s = skipspace(s);
2520
2521         if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2522             char *t;
2523             if (*s == '[') {
2524                 tokenbuf[0] = '@';
2525                 if (dowarn) {
2526                     for(t = s + 1;
2527                         isSPACE(*t) || isALNUM(*t) || *t == '$';
2528                         t++) ;
2529                     if (*t++ == ',') {
2530                         bufptr = skipspace(bufptr);
2531                         while (t < bufend && *t != ']')
2532                             t++;
2533                         warn("Multidimensional syntax %.*s not supported",
2534                              (t - bufptr) + 1, bufptr);
2535                     }
2536                 }
2537             }
2538             else if (*s == '{') {
2539                 tokenbuf[0] = '%';
2540                 if (dowarn && strEQ(tokenbuf+1, "SIG") &&
2541                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
2542                 {
2543                     char tmpbuf[sizeof tokenbuf];
2544                     STRLEN len;
2545                     for (t++; isSPACE(*t); t++) ;
2546                     if (isIDFIRST(*t)) {
2547                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2548                         if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2549                             warn("You need to quote \"%s\"", tmpbuf);
2550                     }
2551                 }
2552             }
2553         }
2554
2555         expect = XOPERATOR;
2556         if (lex_state == LEX_NORMAL && isSPACE(*d)) {
2557             bool islop = (last_lop == oldoldbufptr);
2558             if (!islop || last_lop_op == OP_GREPSTART)
2559                 expect = XOPERATOR;
2560             else if (strchr("$@\"'`q", *s))
2561                 expect = XTERM;         /* e.g. print $fh "foo" */
2562             else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2563                 expect = XTERM;         /* e.g. print $fh &sub */
2564             else if (isIDFIRST(*s)) {
2565                 char tmpbuf[sizeof tokenbuf];
2566                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2567                 if (tmp = keyword(tmpbuf, len)) {
2568                     /* binary operators exclude handle interpretations */
2569                     switch (tmp) {
2570                     case -KEY_x:
2571                     case -KEY_eq:
2572                     case -KEY_ne:
2573                     case -KEY_gt:
2574                     case -KEY_lt:
2575                     case -KEY_ge:
2576                     case -KEY_le:
2577                     case -KEY_cmp:
2578                         break;
2579                     default:
2580                         expect = XTERM; /* e.g. print $fh length() */
2581                         break;
2582                     }
2583                 }
2584                 else {
2585                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2586                     if (gv && GvCVu(gv))
2587                         expect = XTERM; /* e.g. print $fh subr() */
2588                 }
2589             }
2590             else if (isDIGIT(*s))
2591                 expect = XTERM;         /* e.g. print $fh 3 */
2592             else if (*s == '.' && isDIGIT(s[1]))
2593                 expect = XTERM;         /* e.g. print $fh .3 */
2594             else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2595                 expect = XTERM;         /* e.g. print $fh -1 */
2596             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2597                 expect = XTERM;         /* print $fh <<"EOF" */
2598         }
2599         pending_ident = '$';
2600         TOKEN('$');
2601
2602     case '@':
2603         if (expect == XOPERATOR)
2604             no_op("Array", s);
2605         tokenbuf[0] = '@';
2606         s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
2607         if (!tokenbuf[1]) {
2608             if (s == bufend)
2609                 yyerror("Final @ should be \\@ or @name");
2610             PREREF('@');
2611         }
2612         if (lex_state == LEX_NORMAL)
2613             s = skipspace(s);
2614         if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
2615             if (*s == '{')
2616                 tokenbuf[0] = '%';
2617
2618             /* Warn about @ where they meant $. */
2619             if (dowarn) {
2620                 if (*s == '[' || *s == '{') {
2621                     char *t = s + 1;
2622                     while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2623                         t++;
2624                     if (*t == '}' || *t == ']') {
2625                         t++;
2626                         bufptr = skipspace(bufptr);
2627                         warn("Scalar value %.*s better written as $%.*s",
2628                             t-bufptr, bufptr, t-bufptr-1, bufptr+1);
2629                     }
2630                 }
2631             }
2632         }
2633         pending_ident = '@';
2634         TERM('@');
2635
2636     case '/':                   /* may either be division or pattern */
2637     case '?':                   /* may either be conditional or pattern */
2638         if (expect != XOPERATOR) {
2639             /* Disable warning on "study /blah/" */
2640             if (oldoldbufptr == last_uni
2641                 && (*last_uni != 's' || s - last_uni < 5
2642                     || memNE(last_uni, "study", 5) || isALNUM(last_uni[5])))
2643                 check_uni();
2644             s = scan_pat(s);
2645             TERM(sublex_start());
2646         }
2647         tmp = *s++;
2648         if (tmp == '/')
2649             Mop(OP_DIVIDE);
2650         OPERATOR(tmp);
2651
2652     case '.':
2653         if (lex_formbrack && lex_brackets == lex_formbrack && s[1] == '\n' &&
2654                 (s == linestart || s[-1] == '\n') ) {
2655             lex_formbrack = 0;
2656             expect = XSTATE;
2657             goto rightbracket;
2658         }
2659         if (expect == XOPERATOR || !isDIGIT(s[1])) {
2660             tmp = *s++;
2661             if (*s == tmp) {
2662                 s++;
2663                 if (*s == tmp) {
2664                     s++;
2665                     yylval.ival = OPf_SPECIAL;
2666                 }
2667                 else
2668                     yylval.ival = 0;
2669                 OPERATOR(DOTDOT);
2670             }
2671             if (expect != XOPERATOR)
2672                 check_uni();
2673             Aop(OP_CONCAT);
2674         }
2675         /* FALL THROUGH */
2676     case '0': case '1': case '2': case '3': case '4':
2677     case '5': case '6': case '7': case '8': case '9':
2678         s = scan_num(s);
2679         if (expect == XOPERATOR)
2680             no_op("Number",s);
2681         TERM(THING);
2682
2683     case '\'':
2684         s = scan_str(s);
2685         if (expect == XOPERATOR) {
2686             if (lex_formbrack && lex_brackets == lex_formbrack) {
2687                 expect = XTERM;
2688                 depcom();
2689                 return ',';     /* grandfather non-comma-format format */
2690             }
2691             else
2692                 no_op("String",s);
2693         }
2694         if (!s)
2695             missingterm((char*)0);
2696         yylval.ival = OP_CONST;
2697         TERM(sublex_start());
2698
2699     case '"':
2700         s = scan_str(s);
2701         if (expect == XOPERATOR) {
2702             if (lex_formbrack && lex_brackets == lex_formbrack) {
2703                 expect = XTERM;
2704                 depcom();
2705                 return ',';     /* grandfather non-comma-format format */
2706             }
2707             else
2708                 no_op("String",s);
2709         }
2710         if (!s)
2711             missingterm((char*)0);
2712         yylval.ival = OP_CONST;
2713         for (d = SvPV(lex_stuff, len); len; len--, d++) {
2714             if (*d == '$' || *d == '@' || *d == '\\') {
2715                 yylval.ival = OP_STRINGIFY;
2716                 break;
2717             }
2718         }
2719         TERM(sublex_start());
2720
2721     case '`':
2722         s = scan_str(s);
2723         if (expect == XOPERATOR)
2724             no_op("Backticks",s);
2725         if (!s)
2726             missingterm((char*)0);
2727         yylval.ival = OP_BACKTICK;
2728         set_csh();
2729         TERM(sublex_start());
2730
2731     case '\\':
2732         s++;
2733         if (dowarn && lex_inwhat && isDIGIT(*s))
2734             warn("Can't use \\%c to mean $%c in expression", *s, *s);
2735         if (expect == XOPERATOR)
2736             no_op("Backslash",s);
2737         OPERATOR(REFGEN);
2738
2739     case 'x':
2740         if (isDIGIT(s[1]) && expect == XOPERATOR) {
2741             s++;
2742             Mop(OP_REPEAT);
2743         }
2744         goto keylookup;
2745
2746     case '_':
2747     case 'a': case 'A':
2748     case 'b': case 'B':
2749     case 'c': case 'C':
2750     case 'd': case 'D':
2751     case 'e': case 'E':
2752     case 'f': case 'F':
2753     case 'g': case 'G':
2754     case 'h': case 'H':
2755     case 'i': case 'I':
2756     case 'j': case 'J':
2757     case 'k': case 'K':
2758     case 'l': case 'L':
2759     case 'm': case 'M':
2760     case 'n': case 'N':
2761     case 'o': case 'O':
2762     case 'p': case 'P':
2763     case 'q': case 'Q':
2764     case 'r': case 'R':
2765     case 's': case 'S':
2766     case 't': case 'T':
2767     case 'u': case 'U':
2768     case 'v': case 'V':
2769     case 'w': case 'W':
2770               case 'X':
2771     case 'y': case 'Y':
2772     case 'z': case 'Z':
2773
2774       keylookup: {
2775         gv = Nullgv;
2776         gvp = 0;
2777
2778         bufptr = s;
2779         s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
2780
2781         /* Some keywords can be followed by any delimiter, including ':' */
2782         tmp = (len == 1 && strchr("msyq", tokenbuf[0]) ||
2783                len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') ||
2784                             (tokenbuf[0] == 'q' &&
2785                              strchr("qwx", tokenbuf[1]))));
2786
2787         /* x::* is just a word, unless x is "CORE" */
2788         if (!tmp && *s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE"))
2789             goto just_a_word;
2790
2791         d = s;
2792         while (d < bufend && isSPACE(*d))
2793                 d++;    /* no comments skipped here, or s### is misparsed */
2794
2795         /* Is this a label? */
2796         if (!tmp && expect == XSTATE
2797               && d < bufend && *d == ':' && *(d + 1) != ':') {
2798             s = d + 1;
2799             yylval.pval = savepv(tokenbuf);
2800             CLINE;
2801             TOKEN(LABEL);
2802         }
2803
2804         /* Check for keywords */
2805         tmp = keyword(tokenbuf, len);
2806
2807         /* Is this a word before a => operator? */
2808         if (strnEQ(d,"=>",2)) {
2809             CLINE;
2810             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
2811             yylval.opval->op_private = OPpCONST_BARE;
2812             TERM(WORD);
2813         }
2814
2815         if (tmp < 0) {                  /* second-class keyword? */
2816             if (expect != XOPERATOR && (*s != ':' || s[1] != ':') &&
2817                 (((gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) &&
2818                   GvCVu(gv) && GvIMPORTED_CV(gv)) ||
2819                  ((gvp = (GV**)hv_fetch(globalstash,tokenbuf,len,FALSE)) &&
2820                   (gv = *gvp) != (GV*)&sv_undef &&
2821                   GvCVu(gv) && GvIMPORTED_CV(gv))))
2822             {
2823                 tmp = 0;                /* overridden by importation */
2824             }
2825             else if (gv && !gvp
2826                      && -tmp==KEY_lock  /* XXX generalizable kludge */
2827                      && !hv_fetch(GvHVn(incgv), "Thread.pm", 9, FALSE))
2828             {
2829                 tmp = 0;                /* any sub overrides "weak" keyword */
2830             }
2831             else {
2832                 tmp = -tmp; gv = Nullgv; gvp = 0;
2833             }
2834         }
2835
2836       reserved_word:
2837         switch (tmp) {
2838
2839         default:                        /* not a keyword */
2840           just_a_word: {
2841                 SV *sv;
2842                 char lastchar = (bufptr == oldoldbufptr ? 0 : bufptr[-1]);
2843
2844                 /* Get the rest if it looks like a package qualifier */
2845
2846                 if (*s == '\'' || *s == ':' && s[1] == ':') {
2847                     STRLEN morelen;
2848                     s = scan_word(s, tokenbuf + len, sizeof tokenbuf - len,
2849                                   TRUE, &morelen);
2850                     if (!morelen)
2851                         croak("Bad name after %s::", tokenbuf);
2852                     len += morelen;
2853                 }
2854
2855                 if (expect == XOPERATOR) {
2856                     if (bufptr == linestart) {
2857                         curcop->cop_line--;
2858                         warn(warn_nosemi);
2859                         curcop->cop_line++;
2860                     }
2861                     else
2862                         no_op("Bareword",s);
2863                 }
2864
2865                 /* Look for a subroutine with this name in current package,
2866                    unless name is "Foo::", in which case Foo is a bearword
2867                    (and a package name). */
2868
2869                 if (len > 2 &&
2870                     tokenbuf[len - 2] == ':' && tokenbuf[len - 1] == ':')
2871                 {
2872                     if (dowarn && ! gv_fetchpv(tokenbuf, FALSE, SVt_PVHV))
2873                         warn("Bareword \"%s\" refers to nonexistent package",
2874                              tokenbuf);
2875                     len -= 2;
2876                     tokenbuf[len] = '\0';
2877                     gv = Nullgv;
2878                     gvp = 0;
2879                 }
2880                 else {
2881                     len = 0;
2882                     if (!gv)
2883                         gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV);
2884                 }
2885
2886                 /* if we saw a global override before, get the right name */
2887
2888                 if (gvp) {
2889                     sv = newSVpv("CORE::GLOBAL::",14);
2890                     sv_catpv(sv,tokenbuf);
2891                 }
2892                 else
2893                     sv = newSVpv(tokenbuf,0);
2894
2895                 /* Presume this is going to be a bareword of some sort. */
2896
2897                 CLINE;
2898                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2899                 yylval.opval->op_private = OPpCONST_BARE;
2900
2901                 /* And if "Foo::", then that's what it certainly is. */
2902
2903                 if (len)
2904                     goto safe_bareword;
2905
2906                 /* See if it's the indirect object for a list operator. */
2907
2908                 if (oldoldbufptr &&
2909                     oldoldbufptr < bufptr &&
2910                     (oldoldbufptr == last_lop || oldoldbufptr == last_uni) &&
2911                     /* NO SKIPSPACE BEFORE HERE! */
2912                     (expect == XREF ||
2913                      ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF) )
2914                 {
2915                     bool immediate_paren = *s == '(';
2916
2917                     /* (Now we can afford to cross potential line boundary.) */
2918                     s = skipspace(s);
2919
2920                     /* Two barewords in a row may indicate method call. */
2921
2922                     if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2923                         return tmp;
2924
2925                     /* If not a declared subroutine, it's an indirect object. */
2926                     /* (But it's an indir obj regardless for sort.) */
2927
2928                     if ((last_lop_op == OP_SORT ||
2929                          (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2930                         (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
2931                         expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
2932                         goto bareword;
2933                     }
2934                 }
2935
2936                 /* If followed by a paren, it's certainly a subroutine. */
2937
2938                 expect = XOPERATOR;
2939                 s = skipspace(s);
2940                 if (*s == '(') {
2941                     CLINE;
2942                     if (gv && GvCVu(gv)) {
2943                         for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2944                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2945                             s = d + 1;
2946                             goto its_constant;
2947                         }
2948                     }
2949                     nextval[nexttoke].opval = yylval.opval;
2950                     expect = XOPERATOR;
2951                     force_next(WORD);
2952                     yylval.ival = 0;
2953                     TOKEN('&');
2954                 }
2955
2956                 /* If followed by var or block, call it a method (unless sub) */
2957
2958                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
2959                     last_lop = oldbufptr;
2960                     last_lop_op = OP_METHOD;
2961                     PREBLOCK(METHOD);
2962                 }
2963
2964                 /* If followed by a bareword, see if it looks like indir obj. */
2965
2966                 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
2967                     return tmp;
2968
2969                 /* Not a method, so call it a subroutine (if defined) */
2970
2971                 if (gv && GvCVu(gv)) {
2972                     CV* cv;
2973                     if (lastchar == '-')
2974                         warn("Ambiguous use of -%s resolved as -&%s()",
2975                                 tokenbuf, tokenbuf);
2976                     last_lop = oldbufptr;
2977                     last_lop_op = OP_ENTERSUB;
2978                     /* Check for a constant sub */
2979                     cv = GvCV(gv);
2980                     if ((sv = cv_const_sv(cv))) {
2981                   its_constant:
2982                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
2983                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
2984                         yylval.opval->op_private = 0;
2985                         TOKEN(WORD);
2986                     }
2987
2988                     /* Resolve to GV now. */
2989                     op_free(yylval.opval);
2990                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
2991                     /* Is there a prototype? */
2992                     if (SvPOK(cv)) {
2993                         STRLEN len;
2994                         char *proto = SvPV((SV*)cv, len);
2995                         if (!len)
2996                             TERM(FUNC0SUB);
2997                         if (strEQ(proto, "$"))
2998                             OPERATOR(UNIOPSUB);
2999                         if (*proto == '&' && *s == '{') {
3000                             sv_setpv(subname,"__ANON__");
3001                             PREBLOCK(LSTOPSUB);
3002                         }
3003                     }
3004                     nextval[nexttoke].opval = yylval.opval;
3005                     expect = XTERM;
3006                     force_next(WORD);
3007                     TOKEN(NOAMP);
3008                 }
3009
3010                 if (hints & HINT_STRICT_SUBS &&
3011                     lastchar != '-' &&
3012                     strnNE(s,"->",2) &&
3013                     last_lop_op != OP_TRUNCATE &&  /* S/F prototype in opcode.pl */
3014                     last_lop_op != OP_ACCEPT &&
3015                     last_lop_op != OP_PIPE_OP &&
3016                     last_lop_op != OP_SOCKPAIR)
3017                 {
3018                     warn(
3019                      "Bareword \"%s\" not allowed while \"strict subs\" in use",
3020                         tokenbuf);
3021                     ++error_count;
3022                 }
3023
3024                 /* Call it a bare word */
3025
3026             bareword:
3027                 if (dowarn) {
3028                     if (lastchar != '-') {
3029                         for (d = tokenbuf; *d && isLOWER(*d); d++) ;
3030                         if (!*d)
3031                             warn(warn_reserved, tokenbuf);
3032                     }
3033                 }
3034
3035             safe_bareword:
3036                 if (lastchar && strchr("*%&", lastchar)) {
3037                     warn("Operator or semicolon missing before %c%s",
3038                         lastchar, tokenbuf);
3039                     warn("Ambiguous use of %c resolved as operator %c",
3040                         lastchar, lastchar);
3041                 }
3042                 TOKEN(WORD);
3043             }
3044
3045         case KEY___FILE__:
3046             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3047                                         newSVsv(GvSV(curcop->cop_filegv)));
3048             TERM(THING);
3049
3050         case KEY___LINE__:
3051             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3052                                     newSVpvf("%ld", (long)curcop->cop_line));
3053             TERM(THING);
3054
3055         case KEY___PACKAGE__:
3056             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3057                                         (curstash
3058                                          ? newSVsv(curstname)
3059                                          : &sv_undef));
3060             TERM(THING);
3061
3062         case KEY___DATA__:
3063         case KEY___END__: {
3064             GV *gv;
3065
3066             /*SUPPRESS 560*/
3067             if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
3068                 char *pname = "main";
3069                 if (tokenbuf[2] == 'D')
3070                     pname = HvNAME(curstash ? curstash : defstash);
3071                 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3072                 GvMULTI_on(gv);
3073                 if (!GvIO(gv))
3074                     GvIOp(gv) = newIO();
3075                 IoIFP(GvIOp(gv)) = rsfp;
3076 #if defined(HAS_FCNTL) && defined(F_SETFD)
3077                 {
3078                     int fd = PerlIO_fileno(rsfp);
3079                     fcntl(fd,F_SETFD,fd >= 3);
3080                 }
3081 #endif
3082                 /* Mark this internal pseudo-handle as clean */
3083                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3084                 if (preprocess)
3085                     IoTYPE(GvIOp(gv)) = '|';
3086                 else if ((PerlIO*)rsfp == PerlIO_stdin())
3087                     IoTYPE(GvIOp(gv)) = '-';
3088                 else
3089                     IoTYPE(GvIOp(gv)) = '<';
3090                 rsfp = Nullfp;
3091             }
3092             goto fake_eof;
3093         }
3094
3095         case KEY_AUTOLOAD:
3096         case KEY_DESTROY:
3097         case KEY_BEGIN:
3098         case KEY_END:
3099         case KEY_INIT:
3100             if (expect == XSTATE) {
3101                 s = bufptr;
3102                 goto really_sub;
3103             }
3104             goto just_a_word;
3105
3106         case KEY_CORE:
3107             if (*s == ':' && s[1] == ':') {
3108                 s += 2;
3109                 d = s;
3110                 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
3111                 tmp = keyword(tokenbuf, len);
3112                 if (tmp < 0)
3113                     tmp = -tmp;
3114                 goto reserved_word;
3115             }
3116             goto just_a_word;
3117
3118         case KEY_abs:
3119             UNI(OP_ABS);
3120
3121         case KEY_alarm:
3122             UNI(OP_ALARM);
3123
3124         case KEY_accept:
3125             LOP(OP_ACCEPT,XTERM);
3126
3127         case KEY_and:
3128             OPERATOR(ANDOP);
3129
3130         case KEY_atan2:
3131             LOP(OP_ATAN2,XTERM);
3132
3133         case KEY_bind:
3134             LOP(OP_BIND,XTERM);
3135
3136         case KEY_binmode:
3137             UNI(OP_BINMODE);
3138
3139         case KEY_bless:
3140             LOP(OP_BLESS,XTERM);
3141
3142         case KEY_chop:
3143             UNI(OP_CHOP);
3144
3145         case KEY_continue:
3146             PREBLOCK(CONTINUE);
3147
3148         case KEY_chdir:
3149             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
3150             UNI(OP_CHDIR);
3151
3152         case KEY_close:
3153             UNI(OP_CLOSE);
3154
3155         case KEY_closedir:
3156             UNI(OP_CLOSEDIR);
3157
3158         case KEY_cmp:
3159             Eop(OP_SCMP);
3160
3161         case KEY_caller:
3162             UNI(OP_CALLER);
3163
3164         case KEY_crypt:
3165 #ifdef FCRYPT
3166             if (!cryptseen++)
3167                 init_des();
3168 #endif
3169             LOP(OP_CRYPT,XTERM);
3170
3171         case KEY_chmod:
3172             if (dowarn) {
3173                 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3174                 if (*d != '0' && isDIGIT(*d))
3175                     yywarn("chmod: mode argument is missing initial 0");
3176             }
3177             LOP(OP_CHMOD,XTERM);
3178
3179         case KEY_chown:
3180             LOP(OP_CHOWN,XTERM);
3181
3182         case KEY_connect:
3183             LOP(OP_CONNECT,XTERM);
3184
3185         case KEY_chr:
3186             UNI(OP_CHR);
3187
3188         case KEY_cos:
3189             UNI(OP_COS);
3190
3191         case KEY_chroot:
3192             UNI(OP_CHROOT);
3193
3194         case KEY_do:
3195             s = skipspace(s);
3196             if (*s == '{')
3197                 PRETERMBLOCK(DO);
3198             if (*s != '\'')
3199                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3200             OPERATOR(DO);
3201
3202         case KEY_die:
3203             hints |= HINT_BLOCK_SCOPE;
3204             LOP(OP_DIE,XTERM);
3205
3206         case KEY_defined:
3207             UNI(OP_DEFINED);
3208
3209         case KEY_delete:
3210             UNI(OP_DELETE);
3211
3212         case KEY_dbmopen:
3213             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3214             LOP(OP_DBMOPEN,XTERM);
3215
3216         case KEY_dbmclose:
3217             UNI(OP_DBMCLOSE);
3218
3219         case KEY_dump:
3220             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3221             LOOPX(OP_DUMP);
3222
3223         case KEY_else:
3224             PREBLOCK(ELSE);
3225
3226         case KEY_elsif:
3227             yylval.ival = curcop->cop_line;
3228             OPERATOR(ELSIF);
3229
3230         case KEY_eq:
3231             Eop(OP_SEQ);
3232
3233         case KEY_exists:
3234             UNI(OP_EXISTS);
3235
3236         case KEY_exit:
3237             UNI(OP_EXIT);
3238
3239         case KEY_eval:
3240             s = skipspace(s);
3241             expect = (*s == '{') ? XTERMBLOCK : XTERM;
3242             UNIBRACK(OP_ENTEREVAL);
3243
3244         case KEY_eof:
3245             UNI(OP_EOF);
3246
3247         case KEY_exp:
3248             UNI(OP_EXP);
3249
3250         case KEY_each:
3251             UNI(OP_EACH);
3252
3253         case KEY_exec:
3254             set_csh();
3255             LOP(OP_EXEC,XREF);
3256
3257         case KEY_endhostent:
3258             FUN0(OP_EHOSTENT);
3259
3260         case KEY_endnetent:
3261             FUN0(OP_ENETENT);
3262
3263         case KEY_endservent:
3264             FUN0(OP_ESERVENT);
3265
3266         case KEY_endprotoent:
3267             FUN0(OP_EPROTOENT);
3268
3269         case KEY_endpwent:
3270             FUN0(OP_EPWENT);
3271
3272         case KEY_endgrent:
3273             FUN0(OP_EGRENT);
3274
3275         case KEY_for:
3276         case KEY_foreach:
3277             yylval.ival = curcop->cop_line;
3278             s = skipspace(s);
3279             if (expect == XSTATE && isIDFIRST(*s)) {
3280                 char *p = s;
3281                 if ((bufend - p) >= 3 &&
3282                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3283                     p += 2;
3284                 p = skipspace(p);
3285                 if (isIDFIRST(*p))
3286                     croak("Missing $ on loop variable");
3287             }
3288             OPERATOR(FOR);
3289
3290         case KEY_formline:
3291             LOP(OP_FORMLINE,XTERM);
3292
3293         case KEY_fork:
3294             FUN0(OP_FORK);
3295
3296         case KEY_fcntl:
3297             LOP(OP_FCNTL,XTERM);
3298
3299         case KEY_fileno:
3300             UNI(OP_FILENO);
3301
3302         case KEY_flock:
3303             LOP(OP_FLOCK,XTERM);
3304
3305         case KEY_gt:
3306             Rop(OP_SGT);
3307
3308         case KEY_ge:
3309             Rop(OP_SGE);
3310
3311         case KEY_grep:
3312             LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3313
3314         case KEY_goto:
3315             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3316             LOOPX(OP_GOTO);
3317
3318         case KEY_gmtime:
3319             UNI(OP_GMTIME);
3320
3321         case KEY_getc:
3322             UNI(OP_GETC);
3323
3324         case KEY_getppid:
3325             FUN0(OP_GETPPID);
3326
3327         case KEY_getpgrp:
3328             UNI(OP_GETPGRP);
3329
3330         case KEY_getpriority:
3331             LOP(OP_GETPRIORITY,XTERM);
3332
3333         case KEY_getprotobyname:
3334             UNI(OP_GPBYNAME);
3335
3336         case KEY_getprotobynumber:
3337             LOP(OP_GPBYNUMBER,XTERM);
3338
3339         case KEY_getprotoent:
3340             FUN0(OP_GPROTOENT);
3341
3342         case KEY_getpwent:
3343             FUN0(OP_GPWENT);
3344
3345         case KEY_getpwnam:
3346             UNI(OP_GPWNAM);
3347
3348         case KEY_getpwuid:
3349             UNI(OP_GPWUID);
3350
3351         case KEY_getpeername:
3352             UNI(OP_GETPEERNAME);
3353
3354         case KEY_gethostbyname:
3355             UNI(OP_GHBYNAME);
3356
3357         case KEY_gethostbyaddr:
3358             LOP(OP_GHBYADDR,XTERM);
3359
3360         case KEY_gethostent:
3361             FUN0(OP_GHOSTENT);
3362
3363         case KEY_getnetbyname:
3364             UNI(OP_GNBYNAME);
3365
3366         case KEY_getnetbyaddr:
3367             LOP(OP_GNBYADDR,XTERM);
3368
3369         case KEY_getnetent:
3370             FUN0(OP_GNETENT);
3371
3372         case KEY_getservbyname:
3373             LOP(OP_GSBYNAME,XTERM);
3374
3375         case KEY_getservbyport:
3376             LOP(OP_GSBYPORT,XTERM);
3377
3378         case KEY_getservent:
3379             FUN0(OP_GSERVENT);
3380
3381         case KEY_getsockname:
3382             UNI(OP_GETSOCKNAME);
3383
3384         case KEY_getsockopt:
3385             LOP(OP_GSOCKOPT,XTERM);
3386
3387         case KEY_getgrent:
3388             FUN0(OP_GGRENT);
3389
3390         case KEY_getgrnam:
3391             UNI(OP_GGRNAM);
3392
3393         case KEY_getgrgid:
3394             UNI(OP_GGRGID);
3395
3396         case KEY_getlogin:
3397             FUN0(OP_GETLOGIN);
3398
3399         case KEY_glob:
3400             set_csh();
3401             LOP(OP_GLOB,XTERM);
3402
3403         case KEY_hex:
3404             UNI(OP_HEX);
3405
3406         case KEY_if:
3407             yylval.ival = curcop->cop_line;
3408             OPERATOR(IF);
3409
3410         case KEY_index:
3411             LOP(OP_INDEX,XTERM);
3412
3413         case KEY_int:
3414             UNI(OP_INT);
3415
3416         case KEY_ioctl:
3417             LOP(OP_IOCTL,XTERM);
3418
3419         case KEY_join:
3420             LOP(OP_JOIN,XTERM);
3421
3422         case KEY_keys:
3423             UNI(OP_KEYS);
3424
3425         case KEY_kill:
3426             LOP(OP_KILL,XTERM);
3427
3428         case KEY_last:
3429             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3430             LOOPX(OP_LAST);
3431
3432         case KEY_lc:
3433             UNI(OP_LC);
3434
3435         case KEY_lcfirst:
3436             UNI(OP_LCFIRST);
3437
3438         case KEY_local:
3439             OPERATOR(LOCAL);
3440
3441         case KEY_length:
3442             UNI(OP_LENGTH);
3443
3444         case KEY_lt:
3445             Rop(OP_SLT);
3446
3447         case KEY_le:
3448             Rop(OP_SLE);
3449
3450         case KEY_localtime:
3451             UNI(OP_LOCALTIME);
3452
3453         case KEY_log:
3454             UNI(OP_LOG);
3455
3456         case KEY_link:
3457             LOP(OP_LINK,XTERM);
3458
3459         case KEY_listen:
3460             LOP(OP_LISTEN,XTERM);
3461
3462         case KEY_lock:
3463             UNI(OP_LOCK);
3464
3465         case KEY_lstat:
3466             UNI(OP_LSTAT);
3467
3468         case KEY_m:
3469             s = scan_pat(s);
3470             TERM(sublex_start());
3471
3472         case KEY_map:
3473             LOP(OP_MAPSTART,XREF);
3474
3475         case KEY_mkdir:
3476             LOP(OP_MKDIR,XTERM);
3477
3478         case KEY_msgctl:
3479             LOP(OP_MSGCTL,XTERM);
3480
3481         case KEY_msgget:
3482             LOP(OP_MSGGET,XTERM);
3483
3484         case KEY_msgrcv:
3485             LOP(OP_MSGRCV,XTERM);
3486
3487         case KEY_msgsnd:
3488             LOP(OP_MSGSND,XTERM);
3489
3490         case KEY_my:
3491             in_my = TRUE;
3492             s = skipspace(s);
3493             if (isIDFIRST(*s)) {
3494                 s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
3495                 in_my_stash = gv_stashpv(tokenbuf, FALSE);
3496                 if (!in_my_stash) {
3497                     char tmpbuf[1024];
3498                     bufptr = s;
3499                     sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
3500                     yyerror(tmpbuf);
3501                 }
3502             }
3503             OPERATOR(MY);
3504
3505         case KEY_next:
3506             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3507             LOOPX(OP_NEXT);
3508
3509         case KEY_ne:
3510             Eop(OP_SNE);
3511
3512         case KEY_no:
3513             if (expect != XSTATE)
3514                 yyerror("\"no\" not allowed in expression");
3515             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3516             s = force_version(s);
3517             yylval.ival = 0;
3518             OPERATOR(USE);
3519
3520         case KEY_not:
3521             OPERATOR(NOTOP);
3522
3523         case KEY_open:
3524             s = skipspace(s);
3525             if (isIDFIRST(*s)) {
3526                 char *t;
3527                 for (d = s; isALNUM(*d); d++) ;
3528                 t = skipspace(d);
3529                 if (strchr("|&*+-=!?:.", *t))
3530                     warn("Precedence problem: open %.*s should be open(%.*s)",
3531                         d-s,s, d-s,s);
3532             }
3533             LOP(OP_OPEN,XTERM);
3534
3535         case KEY_or:
3536             yylval.ival = OP_OR;
3537             OPERATOR(OROP);
3538
3539         case KEY_ord:
3540             UNI(OP_ORD);
3541
3542         case KEY_oct:
3543             UNI(OP_OCT);
3544
3545         case KEY_opendir:
3546             LOP(OP_OPEN_DIR,XTERM);
3547
3548         case KEY_print:
3549             checkcomma(s,tokenbuf,"filehandle");
3550             LOP(OP_PRINT,XREF);
3551
3552         case KEY_printf:
3553             checkcomma(s,tokenbuf,"filehandle");
3554             LOP(OP_PRTF,XREF);
3555
3556         case KEY_prototype:
3557             UNI(OP_PROTOTYPE);
3558
3559         case KEY_push:
3560             LOP(OP_PUSH,XTERM);
3561
3562         case KEY_pop:
3563             UNI(OP_POP);
3564
3565         case KEY_pos:
3566             UNI(OP_POS);
3567
3568         case KEY_pack:
3569             LOP(OP_PACK,XTERM);
3570
3571         case KEY_package:
3572             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3573             OPERATOR(PACKAGE);
3574
3575         case KEY_pipe:
3576             LOP(OP_PIPE_OP,XTERM);
3577
3578         case KEY_q:
3579             s = scan_str(s);
3580             if (!s)
3581                 missingterm((char*)0);
3582             yylval.ival = OP_CONST;
3583             TERM(sublex_start());
3584
3585         case KEY_quotemeta:
3586             UNI(OP_QUOTEMETA);
3587
3588         case KEY_qw:
3589             s = scan_str(s);
3590             if (!s)
3591                 missingterm((char*)0);
3592             if (dowarn && SvLEN(lex_stuff)) {
3593                 d = SvPV_force(lex_stuff, len);
3594                 for (; len; --len, ++d) {
3595                     if (*d == ',') {
3596                         warn("Possible attempt to separate words with commas");
3597                         break;
3598                     }
3599                     if (*d == '#') {
3600                         warn("Possible attempt to put comments in qw() list");
3601                         break;
3602                     }
3603                 }
3604             }
3605             force_next(')');
3606             nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, q(lex_stuff));
3607             lex_stuff = Nullsv;
3608             force_next(THING);
3609             force_next(',');
3610             nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3611             force_next(THING);
3612             force_next('(');
3613             yylval.ival = OP_SPLIT;
3614             CLINE;
3615             expect = XTERM;
3616             bufptr = s;
3617             last_lop = oldbufptr;
3618             last_lop_op = OP_SPLIT;
3619             return FUNC;
3620
3621         case KEY_qq:
3622             s = scan_str(s);
3623             if (!s)
3624                 missingterm((char*)0);
3625             yylval.ival = OP_STRINGIFY;
3626             if (SvIVX(lex_stuff) == '\'')
3627                 SvIVX(lex_stuff) = 0;   /* qq'$foo' should intepolate */
3628             TERM(sublex_start());
3629
3630         case KEY_qx:
3631             s = scan_str(s);
3632             if (!s)
3633                 missingterm((char*)0);
3634             yylval.ival = OP_BACKTICK;
3635             set_csh();
3636             TERM(sublex_start());
3637
3638         case KEY_return:
3639             OLDLOP(OP_RETURN);
3640
3641         case KEY_require:
3642             *tokenbuf = '\0';
3643             s = force_word(s,WORD,TRUE,TRUE,FALSE);
3644             if (isIDFIRST(*tokenbuf))
3645                 gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
3646             else if (*s == '<')
3647                 yyerror("<> should be quotes");
3648             UNI(OP_REQUIRE);
3649
3650         case KEY_reset:
3651             UNI(OP_RESET);
3652
3653         case KEY_redo:
3654             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3655             LOOPX(OP_REDO);
3656
3657         case KEY_rename:
3658             LOP(OP_RENAME,XTERM);
3659
3660         case KEY_rand:
3661             UNI(OP_RAND);
3662
3663         case KEY_rmdir:
3664             UNI(OP_RMDIR);
3665
3666         case KEY_rindex:
3667             LOP(OP_RINDEX,XTERM);
3668
3669         case KEY_read:
3670             LOP(OP_READ,XTERM);
3671
3672         case KEY_readdir:
3673             UNI(OP_READDIR);
3674
3675         case KEY_readline:
3676             set_csh();
3677             UNI(OP_READLINE);
3678
3679         case KEY_readpipe:
3680             set_csh();
3681             UNI(OP_BACKTICK);
3682
3683         case KEY_rewinddir:
3684             UNI(OP_REWINDDIR);
3685
3686         case KEY_recv:
3687             LOP(OP_RECV,XTERM);
3688
3689         case KEY_reverse:
3690             LOP(OP_REVERSE,XTERM);
3691
3692         case KEY_readlink:
3693             UNI(OP_READLINK);
3694
3695         case KEY_ref:
3696             UNI(OP_REF);
3697
3698         case KEY_s:
3699             s = scan_subst(s);
3700             if (yylval.opval)
3701                 TERM(sublex_start());
3702             else
3703                 TOKEN(1);       /* force error */
3704
3705         case KEY_chomp:
3706             UNI(OP_CHOMP);
3707
3708         case KEY_scalar:
3709             UNI(OP_SCALAR);
3710
3711         case KEY_select:
3712             LOP(OP_SELECT,XTERM);
3713
3714         case KEY_seek:
3715             LOP(OP_SEEK,XTERM);
3716
3717         case KEY_semctl:
3718             LOP(OP_SEMCTL,XTERM);
3719
3720         case KEY_semget:
3721             LOP(OP_SEMGET,XTERM);
3722
3723         case KEY_semop:
3724             LOP(OP_SEMOP,XTERM);
3725
3726         case KEY_send:
3727             LOP(OP_SEND,XTERM);
3728
3729         case KEY_setpgrp:
3730             LOP(OP_SETPGRP,XTERM);
3731
3732         case KEY_setpriority:
3733             LOP(OP_SETPRIORITY,XTERM);
3734
3735         case KEY_sethostent:
3736             UNI(OP_SHOSTENT);
3737
3738         case KEY_setnetent:
3739             UNI(OP_SNETENT);
3740
3741         case KEY_setservent:
3742             UNI(OP_SSERVENT);
3743
3744         case KEY_setprotoent:
3745             UNI(OP_SPROTOENT);
3746
3747         case KEY_setpwent:
3748             FUN0(OP_SPWENT);
3749
3750         case KEY_setgrent:
3751             FUN0(OP_SGRENT);
3752
3753         case KEY_seekdir:
3754             LOP(OP_SEEKDIR,XTERM);
3755
3756         case KEY_setsockopt:
3757             LOP(OP_SSOCKOPT,XTERM);
3758
3759         case KEY_shift:
3760             UNI(OP_SHIFT);
3761
3762         case KEY_shmctl:
3763             LOP(OP_SHMCTL,XTERM);
3764
3765         case KEY_shmget:
3766             LOP(OP_SHMGET,XTERM);
3767
3768         case KEY_shmread:
3769             LOP(OP_SHMREAD,XTERM);
3770
3771         case KEY_shmwrite:
3772             LOP(OP_SHMWRITE,XTERM);
3773
3774         case KEY_shutdown:
3775             LOP(OP_SHUTDOWN,XTERM);
3776
3777         case KEY_sin:
3778             UNI(OP_SIN);
3779
3780         case KEY_sleep:
3781             UNI(OP_SLEEP);
3782
3783         case KEY_socket:
3784             LOP(OP_SOCKET,XTERM);
3785
3786         case KEY_socketpair:
3787             LOP(OP_SOCKPAIR,XTERM);
3788
3789         case KEY_sort:
3790             checkcomma(s,tokenbuf,"subroutine name");
3791             s = skipspace(s);
3792             if (*s == ';' || *s == ')')         /* probably a close */
3793                 croak("sort is now a reserved word");
3794             expect = XTERM;
3795             s = force_word(s,WORD,TRUE,TRUE,FALSE);
3796             LOP(OP_SORT,XREF);
3797
3798         case KEY_split:
3799             LOP(OP_SPLIT,XTERM);
3800
3801         case KEY_sprintf:
3802             LOP(OP_SPRINTF,XTERM);
3803
3804         case KEY_splice:
3805             LOP(OP_SPLICE,XTERM);
3806
3807         case KEY_sqrt:
3808             UNI(OP_SQRT);
3809
3810         case KEY_srand:
3811             UNI(OP_SRAND);
3812
3813         case KEY_stat:
3814             UNI(OP_STAT);
3815
3816         case KEY_study:
3817             sawstudy++;
3818             UNI(OP_STUDY);
3819
3820         case KEY_substr:
3821             LOP(OP_SUBSTR,XTERM);
3822
3823         case KEY_format:
3824         case KEY_sub:
3825           really_sub:
3826             s = skipspace(s);
3827
3828             if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3829                 char tmpbuf[sizeof tokenbuf];
3830                 expect = XBLOCK;
3831                 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3832                 if (strchr(tmpbuf, ':'))
3833                     sv_setpv(subname, tmpbuf);
3834                 else {
3835                     sv_setsv(subname,curstname);
3836                     sv_catpvn(subname,"::",2);
3837                     sv_catpvn(subname,tmpbuf,len);
3838                 }
3839                 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3840                 s = skipspace(s);
3841             }
3842             else {
3843                 expect = XTERMBLOCK;
3844                 sv_setpv(subname,"?");
3845             }
3846
3847             if (tmp == KEY_format) {
3848                 s = skipspace(s);
3849                 if (*s == '=')
3850                     lex_formbrack = lex_brackets + 1;
3851                 OPERATOR(FORMAT);
3852             }
3853
3854             /* Look for a prototype */
3855             if (*s == '(') {
3856                 char *p;
3857
3858                 s = scan_str(s);
3859                 if (!s) {
3860                     if (lex_stuff)
3861                         SvREFCNT_dec(lex_stuff);
3862                     lex_stuff = Nullsv;
3863                     croak("Prototype not terminated");
3864                 }
3865                 /* strip spaces */
3866                 d = SvPVX(lex_stuff);
3867                 tmp = 0;
3868                 for (p = d; *p; ++p) {
3869                     if (!isSPACE(*p))
3870                         d[tmp++] = *p;
3871                 }
3872                 d[tmp] = '\0';
3873                 SvCUR(lex_stuff) = tmp;
3874
3875                 nexttoke++;
3876                 nextval[1] = nextval[0];
3877                 nexttype[1] = nexttype[0];
3878                 nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff);
3879                 nexttype[0] = THING;
3880                 if (nexttoke == 1) {
3881                     lex_defer = lex_state;
3882                     lex_expect = expect;
3883                     lex_state = LEX_KNOWNEXT;
3884                 }
3885                 lex_stuff = Nullsv;
3886             }
3887
3888             if (*SvPV(subname,na) == '?') {
3889                 sv_setpv(subname,"__ANON__");
3890                 TOKEN(ANONSUB);
3891             }
3892             PREBLOCK(SUB);
3893
3894         case KEY_system:
3895             set_csh();
3896             LOP(OP_SYSTEM,XREF);
3897
3898         case KEY_symlink:
3899             LOP(OP_SYMLINK,XTERM);
3900
3901         case KEY_syscall:
3902             LOP(OP_SYSCALL,XTERM);
3903
3904         case KEY_sysopen:
3905             LOP(OP_SYSOPEN,XTERM);
3906
3907         case KEY_sysseek:
3908             LOP(OP_SYSSEEK,XTERM);
3909
3910         case KEY_sysread:
3911             LOP(OP_SYSREAD,XTERM);
3912
3913         case KEY_syswrite:
3914             LOP(OP_SYSWRITE,XTERM);
3915
3916         case KEY_tr:
3917             s = scan_trans(s);
3918             TERM(sublex_start());
3919
3920         case KEY_tell:
3921             UNI(OP_TELL);
3922
3923         case KEY_telldir:
3924             UNI(OP_TELLDIR);
3925
3926         case KEY_tie:
3927             LOP(OP_TIE,XTERM);
3928
3929         case KEY_tied:
3930             UNI(OP_TIED);
3931
3932         case KEY_time:
3933             FUN0(OP_TIME);
3934
3935         case KEY_times:
3936             FUN0(OP_TMS);
3937
3938         case KEY_truncate:
3939             LOP(OP_TRUNCATE,XTERM);
3940
3941         case KEY_uc:
3942             UNI(OP_UC);
3943
3944         case KEY_ucfirst:
3945             UNI(OP_UCFIRST);
3946
3947         case KEY_untie:
3948             UNI(OP_UNTIE);
3949
3950         case KEY_until:
3951             yylval.ival = curcop->cop_line;
3952             OPERATOR(UNTIL);
3953
3954         case KEY_unless:
3955             yylval.ival = curcop->cop_line;
3956             OPERATOR(UNLESS);
3957
3958         case KEY_unlink:
3959             LOP(OP_UNLINK,XTERM);
3960
3961         case KEY_undef:
3962             UNI(OP_UNDEF);
3963
3964         case KEY_unpack:
3965             LOP(OP_UNPACK,XTERM);
3966
3967         case KEY_utime:
3968             LOP(OP_UTIME,XTERM);
3969
3970         case KEY_umask:
3971             if (dowarn) {
3972                 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3973                 if (*d != '0' && isDIGIT(*d))
3974                     yywarn("umask: argument is missing initial 0");
3975             }
3976             UNI(OP_UMASK);
3977
3978         case KEY_unshift:
3979             LOP(OP_UNSHIFT,XTERM);
3980
3981         case KEY_use:
3982             if (expect != XSTATE)
3983                 yyerror("\"use\" not allowed in expression");
3984             s = skipspace(s);
3985             if(isDIGIT(*s)) {
3986                 s = force_version(s);
3987                 if(*s == ';' || (s = skipspace(s), *s == ';')) {
3988                     nextval[nexttoke].opval = Nullop;
3989                     force_next(WORD);
3990                 }
3991             }
3992             else {
3993                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3994                 s = force_version(s);
3995             }
3996             yylval.ival = 1;
3997             OPERATOR(USE);
3998
3999         case KEY_values:
4000             UNI(OP_VALUES);
4001
4002         case KEY_vec:
4003             sawvec = TRUE;
4004             LOP(OP_VEC,XTERM);
4005
4006         case KEY_while:
4007             yylval.ival = curcop->cop_line;
4008             OPERATOR(WHILE);
4009
4010         case KEY_warn:
4011             hints |= HINT_BLOCK_SCOPE;
4012             LOP(OP_WARN,XTERM);
4013
4014         case KEY_wait:
4015             FUN0(OP_WAIT);
4016
4017         case KEY_waitpid:
4018             LOP(OP_WAITPID,XTERM);
4019
4020         case KEY_wantarray:
4021             FUN0(OP_WANTARRAY);
4022
4023         case KEY_write:
4024             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
4025             UNI(OP_ENTERWRITE);
4026
4027         case KEY_x:
4028             if (expect == XOPERATOR)
4029                 Mop(OP_REPEAT);
4030             check_uni();
4031             goto just_a_word;
4032
4033         case KEY_xor:
4034             yylval.ival = OP_XOR;
4035             OPERATOR(OROP);
4036
4037         case KEY_y:
4038             s = scan_trans(s);
4039             TERM(sublex_start());
4040         }
4041     }}
4042 }
4043
4044 I32
4045 keyword(register char *d, I32 len)
4046 {
4047     switch (*d) {
4048     case '_':
4049         if (d[1] == '_') {
4050             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
4051             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
4052             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
4053             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
4054             if (strEQ(d,"__END__"))             return KEY___END__;
4055         }
4056         break;
4057     case 'A':
4058         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
4059         break;
4060     case 'a':
4061         switch (len) {
4062         case 3:
4063             if (strEQ(d,"and"))                 return -KEY_and;
4064             if (strEQ(d,"abs"))                 return -KEY_abs;
4065             break;
4066         case 5:
4067             if (strEQ(d,"alarm"))               return -KEY_alarm;
4068             if (strEQ(d,"atan2"))               return -KEY_atan2;
4069             break;
4070         case 6:
4071             if (strEQ(d,"accept"))              return -KEY_accept;
4072             break;
4073         }
4074         break;
4075     case 'B':
4076         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
4077         break;
4078     case 'b':
4079         if (strEQ(d,"bless"))                   return -KEY_bless;
4080         if (strEQ(d,"bind"))                    return -KEY_bind;
4081         if (strEQ(d,"binmode"))                 return -KEY_binmode;
4082         break;
4083     case 'C':
4084         if (strEQ(d,"CORE"))                    return -KEY_CORE;
4085         break;
4086     case 'c':
4087         switch (len) {
4088         case 3:
4089             if (strEQ(d,"cmp"))                 return -KEY_cmp;
4090             if (strEQ(d,"chr"))                 return -KEY_chr;
4091             if (strEQ(d,"cos"))                 return -KEY_cos;
4092             break;
4093         case 4:
4094             if (strEQ(d,"chop"))                return KEY_chop;
4095             break;
4096         case 5:
4097             if (strEQ(d,"close"))               return -KEY_close;
4098             if (strEQ(d,"chdir"))               return -KEY_chdir;
4099             if (strEQ(d,"chomp"))               return KEY_chomp;
4100             if (strEQ(d,"chmod"))               return -KEY_chmod;
4101             if (strEQ(d,"chown"))               return -KEY_chown;
4102             if (strEQ(d,"crypt"))               return -KEY_crypt;
4103             break;
4104         case 6:
4105             if (strEQ(d,"chroot"))              return -KEY_chroot;
4106             if (strEQ(d,"caller"))              return -KEY_caller;
4107             break;
4108         case 7:
4109             if (strEQ(d,"connect"))             return -KEY_connect;
4110             break;
4111         case 8:
4112             if (strEQ(d,"closedir"))            return -KEY_closedir;
4113             if (strEQ(d,"continue"))            return -KEY_continue;
4114             break;
4115         }
4116         break;
4117     case 'D':
4118         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
4119         break;
4120     case 'd':
4121         switch (len) {
4122         case 2:
4123             if (strEQ(d,"do"))                  return KEY_do;
4124             break;
4125         case 3:
4126             if (strEQ(d,"die"))                 return -KEY_die;
4127             break;
4128         case 4:
4129             if (strEQ(d,"dump"))                return -KEY_dump;
4130             break;
4131         case 6:
4132             if (strEQ(d,"delete"))              return KEY_delete;
4133             break;
4134         case 7:
4135             if (strEQ(d,"defined"))             return KEY_defined;
4136             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
4137             break;
4138         case 8:
4139             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
4140             break;
4141         }
4142         break;
4143     case 'E':
4144         if (strEQ(d,"EQ")) { deprecate(d);      return -KEY_eq;}
4145         if (strEQ(d,"END"))                     return KEY_END;
4146         break;
4147     case 'e':
4148         switch (len) {
4149         case 2:
4150             if (strEQ(d,"eq"))                  return -KEY_eq;
4151             break;
4152         case 3:
4153             if (strEQ(d,"eof"))                 return -KEY_eof;
4154             if (strEQ(d,"exp"))                 return -KEY_exp;
4155             break;
4156         case 4:
4157             if (strEQ(d,"else"))                return KEY_else;
4158             if (strEQ(d,"exit"))                return -KEY_exit;
4159             if (strEQ(d,"eval"))                return KEY_eval;
4160             if (strEQ(d,"exec"))                return -KEY_exec;
4161             if (strEQ(d,"each"))                return KEY_each;
4162             break;
4163         case 5:
4164             if (strEQ(d,"elsif"))               return KEY_elsif;
4165             break;
4166         case 6:
4167             if (strEQ(d,"exists"))              return KEY_exists;
4168             if (strEQ(d,"elseif")) warn("elseif should be elsif");
4169             break;
4170         case 8:
4171             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
4172             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
4173             break;
4174         case 9:
4175             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
4176             break;
4177         case 10:
4178             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
4179             if (strEQ(d,"endservent"))          return -KEY_endservent;
4180             break;
4181         case 11:
4182             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
4183             break;
4184         }
4185         break;
4186     case 'f':
4187         switch (len) {
4188         case 3:
4189             if (strEQ(d,"for"))                 return KEY_for;
4190             break;
4191         case 4:
4192             if (strEQ(d,"fork"))                return -KEY_fork;
4193             break;
4194         case 5:
4195             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
4196             if (strEQ(d,"flock"))               return -KEY_flock;
4197             break;
4198         case 6:
4199             if (strEQ(d,"format"))              return KEY_format;
4200             if (strEQ(d,"fileno"))              return -KEY_fileno;
4201             break;
4202         case 7:
4203             if (strEQ(d,"foreach"))             return KEY_foreach;
4204             break;
4205         case 8:
4206             if (strEQ(d,"formline"))            return -KEY_formline;
4207             break;
4208         }
4209         break;
4210     case 'G':
4211         if (len == 2) {
4212             if (strEQ(d,"GT")) { deprecate(d);  return -KEY_gt;}
4213             if (strEQ(d,"GE")) { deprecate(d);  return -KEY_ge;}
4214         }
4215         break;
4216     case 'g':
4217         if (strnEQ(d,"get",3)) {
4218             d += 3;
4219             if (*d == 'p') {
4220                 switch (len) {
4221                 case 7:
4222                     if (strEQ(d,"ppid"))        return -KEY_getppid;
4223                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
4224                     break;
4225                 case 8:
4226                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
4227                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
4228                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
4229                     break;
4230                 case 11:
4231                     if (strEQ(d,"peername"))    return -KEY_getpeername;
4232                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
4233                     if (strEQ(d,"priority"))    return -KEY_getpriority;
4234                     break;
4235                 case 14:
4236                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4237                     break;
4238                 case 16:
4239                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4240                     break;
4241                 }
4242             }
4243             else if (*d == 'h') {
4244                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
4245                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
4246                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
4247             }
4248             else if (*d == 'n') {
4249                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
4250                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
4251                 if (strEQ(d,"netent"))          return -KEY_getnetent;
4252             }
4253             else if (*d == 's') {
4254                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
4255                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
4256                 if (strEQ(d,"servent"))         return -KEY_getservent;
4257                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
4258                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
4259             }
4260             else if (*d == 'g') {
4261                 if (strEQ(d,"grent"))           return -KEY_getgrent;
4262                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
4263                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
4264             }
4265             else if (*d == 'l') {
4266                 if (strEQ(d,"login"))           return -KEY_getlogin;
4267             }
4268             else if (strEQ(d,"c"))              return -KEY_getc;
4269             break;
4270         }
4271         switch (len) {
4272         case 2:
4273             if (strEQ(d,"gt"))                  return -KEY_gt;
4274             if (strEQ(d,"ge"))                  return -KEY_ge;
4275             break;
4276         case 4:
4277             if (strEQ(d,"grep"))                return KEY_grep;
4278             if (strEQ(d,"goto"))                return KEY_goto;
4279             if (strEQ(d,"glob"))                return KEY_glob;
4280             break;
4281         case 6:
4282             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
4283             break;
4284         }
4285         break;
4286     case 'h':
4287         if (strEQ(d,"hex"))                     return -KEY_hex;
4288         break;
4289     case 'I':
4290         if (strEQ(d,"INIT"))                    return KEY_INIT;
4291         break;
4292     case 'i':
4293         switch (len) {
4294         case 2:
4295             if (strEQ(d,"if"))                  return KEY_if;
4296             break;
4297         case 3:
4298             if (strEQ(d,"int"))                 return -KEY_int;
4299             break;
4300         case 5:
4301             if (strEQ(d,"index"))               return -KEY_index;
4302             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
4303             break;
4304         }
4305         break;
4306     case 'j':
4307         if (strEQ(d,"join"))                    return -KEY_join;
4308         break;
4309     case 'k':
4310         if (len == 4) {
4311             if (strEQ(d,"keys"))                return KEY_keys;
4312             if (strEQ(d,"kill"))                return -KEY_kill;
4313         }
4314         break;
4315     case 'L':
4316         if (len == 2) {
4317             if (strEQ(d,"LT")) { deprecate(d);  return -KEY_lt;}
4318             if (strEQ(d,"LE")) { deprecate(d);  return -KEY_le;}
4319         }
4320         break;
4321     case 'l':
4322         switch (len) {
4323         case 2:
4324             if (strEQ(d,"lt"))                  return -KEY_lt;
4325             if (strEQ(d,"le"))                  return -KEY_le;
4326             if (strEQ(d,"lc"))                  return -KEY_lc;
4327             break;
4328         case 3:
4329             if (strEQ(d,"log"))                 return -KEY_log;
4330             break;
4331         case 4:
4332             if (strEQ(d,"last"))                return KEY_last;
4333             if (strEQ(d,"link"))                return -KEY_link;
4334             if (strEQ(d,"lock"))                return -KEY_lock;
4335             break;
4336         case 5:
4337             if (strEQ(d,"local"))               return KEY_local;
4338             if (strEQ(d,"lstat"))               return -KEY_lstat;
4339             break;
4340         case 6:
4341             if (strEQ(d,"length"))              return -KEY_length;
4342             if (strEQ(d,"listen"))              return -KEY_listen;
4343             break;
4344         case 7:
4345             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
4346             break;
4347         case 9:
4348             if (strEQ(d,"localtime"))           return -KEY_localtime;
4349             break;
4350         }
4351         break;
4352     case 'm':
4353         switch (len) {
4354         case 1:                                 return KEY_m;
4355         case 2:
4356             if (strEQ(d,"my"))                  return KEY_my;
4357             break;
4358         case 3:
4359             if (strEQ(d,"map"))                 return KEY_map;
4360             break;
4361         case 5:
4362             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
4363             break;
4364         case 6:
4365             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
4366             if (strEQ(d,"msgget"))              return -KEY_msgget;
4367             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
4368             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
4369             break;
4370         }
4371         break;
4372     case 'N':
4373         if (strEQ(d,"NE")) { deprecate(d);      return -KEY_ne;}
4374         break;
4375     case 'n':
4376         if (strEQ(d,"next"))                    return KEY_next;
4377         if (strEQ(d,"ne"))                      return -KEY_ne;
4378         if (strEQ(d,"not"))                     return -KEY_not;
4379         if (strEQ(d,"no"))                      return KEY_no;
4380         break;
4381     case 'o':
4382         switch (len) {
4383         case 2:
4384             if (strEQ(d,"or"))                  return -KEY_or;
4385             break;
4386         case 3:
4387             if (strEQ(d,"ord"))                 return -KEY_ord;
4388             if (strEQ(d,"oct"))                 return -KEY_oct;
4389             break;
4390         case 4:
4391             if (strEQ(d,"open"))                return -KEY_open;
4392             break;
4393         case 7:
4394             if (strEQ(d,"opendir"))             return -KEY_opendir;
4395             break;
4396         }
4397         break;
4398     case 'p':
4399         switch (len) {
4400         case 3:
4401             if (strEQ(d,"pop"))                 return KEY_pop;
4402             if (strEQ(d,"pos"))                 return KEY_pos;
4403             break;
4404         case 4:
4405             if (strEQ(d,"push"))                return KEY_push;
4406             if (strEQ(d,"pack"))                return -KEY_pack;
4407             if (strEQ(d,"pipe"))                return -KEY_pipe;
4408             break;
4409         case 5:
4410             if (strEQ(d,"print"))               return KEY_print;
4411             break;
4412         case 6:
4413             if (strEQ(d,"printf"))              return KEY_printf;
4414             break;
4415         case 7:
4416             if (strEQ(d,"package"))             return KEY_package;
4417             break;
4418         case 9:
4419             if (strEQ(d,"prototype"))           return KEY_prototype;
4420         }
4421         break;
4422     case 'q':
4423         if (len <= 2) {
4424             if (strEQ(d,"q"))                   return KEY_q;
4425             if (strEQ(d,"qq"))                  return KEY_qq;
4426             if (strEQ(d,"qw"))                  return KEY_qw;
4427             if (strEQ(d,"qx"))                  return KEY_qx;
4428         }
4429         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
4430         break;
4431     case 'r':
4432         switch (len) {
4433         case 3:
4434             if (strEQ(d,"ref"))                 return -KEY_ref;
4435             break;
4436         case 4:
4437             if (strEQ(d,"read"))                return -KEY_read;
4438             if (strEQ(d,"rand"))                return -KEY_rand;
4439             if (strEQ(d,"recv"))                return -KEY_recv;
4440             if (strEQ(d,"redo"))                return KEY_redo;
4441             break;
4442         case 5:
4443             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
4444             if (strEQ(d,"reset"))               return -KEY_reset;
4445             break;
4446         case 6:
4447             if (strEQ(d,"return"))              return KEY_return;
4448             if (strEQ(d,"rename"))              return -KEY_rename;
4449             if (strEQ(d,"rindex"))              return -KEY_rindex;
4450             break;
4451         case 7:
4452             if (strEQ(d,"require"))             return -KEY_require;
4453             if (strEQ(d,"reverse"))             return -KEY_reverse;
4454             if (strEQ(d,"readdir"))             return -KEY_readdir;
4455             break;
4456         case 8:
4457             if (strEQ(d,"readlink"))            return -KEY_readlink;
4458             if (strEQ(d,"readline"))            return -KEY_readline;
4459             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
4460             break;
4461         case 9:
4462             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
4463             break;
4464         }
4465         break;
4466     case 's':
4467         switch (d[1]) {
4468         case 0:                                 return KEY_s;
4469         case 'c':
4470             if (strEQ(d,"scalar"))              return KEY_scalar;
4471             break;
4472         case 'e':
4473             switch (len) {
4474             case 4:
4475                 if (strEQ(d,"seek"))            return -KEY_seek;
4476                 if (strEQ(d,"send"))            return -KEY_send;
4477                 break;
4478             case 5:
4479                 if (strEQ(d,"semop"))           return -KEY_semop;
4480                 break;
4481             case 6:
4482                 if (strEQ(d,"select"))          return -KEY_select;
4483                 if (strEQ(d,"semctl"))          return -KEY_semctl;
4484                 if (strEQ(d,"semget"))          return -KEY_semget;
4485                 break;
4486             case 7:
4487                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
4488                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
4489                 break;
4490             case 8:
4491                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
4492                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
4493                 break;
4494             case 9:
4495                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
4496                 break;
4497             case 10:
4498                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
4499                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
4500                 if (strEQ(d,"setservent"))      return -KEY_setservent;
4501                 break;
4502             case 11:
4503                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
4504                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
4505                 break;
4506             }
4507             break;
4508         case 'h':
4509             switch (len) {
4510             case 5:
4511                 if (strEQ(d,"shift"))           return KEY_shift;
4512                 break;
4513             case 6:
4514                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
4515                 if (strEQ(d,"shmget"))          return -KEY_shmget;
4516                 break;
4517             case 7:
4518                 if (strEQ(d,"shmread"))         return -KEY_shmread;
4519                 break;
4520             case 8:
4521                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
4522                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
4523                 break;
4524             }
4525             break;
4526         case 'i':
4527             if (strEQ(d,"sin"))                 return -KEY_sin;
4528             break;
4529         case 'l':
4530             if (strEQ(d,"sleep"))               return -KEY_sleep;
4531             break;
4532         case 'o':
4533             if (strEQ(d,"sort"))                return KEY_sort;
4534             if (strEQ(d,"socket"))              return -KEY_socket;
4535             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
4536             break;
4537         case 'p':
4538             if (strEQ(d,"split"))               return KEY_split;
4539             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
4540             if (strEQ(d,"splice"))              return KEY_splice;
4541             break;
4542         case 'q':
4543             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
4544             break;
4545         case 'r':
4546             if (strEQ(d,"srand"))               return -KEY_srand;
4547             break;
4548         case 't':
4549             if (strEQ(d,"stat"))                return -KEY_stat;
4550             if (strEQ(d,"study"))               return KEY_study;
4551             break;
4552         case 'u':
4553             if (strEQ(d,"substr"))              return -KEY_substr;
4554             if (strEQ(d,"sub"))                 return KEY_sub;
4555             break;
4556         case 'y':
4557             switch (len) {
4558             case 6:
4559                 if (strEQ(d,"system"))          return -KEY_system;
4560                 break;
4561             case 7:
4562                 if (strEQ(d,"symlink"))         return -KEY_symlink;
4563                 if (strEQ(d,"syscall"))         return -KEY_syscall;
4564                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
4565                 if (strEQ(d,"sysread"))         return -KEY_sysread;
4566                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
4567                 break;
4568             case 8:
4569                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
4570                 break;
4571             }
4572             break;
4573         }
4574         break;
4575     case 't':
4576         switch (len) {
4577         case 2:
4578             if (strEQ(d,"tr"))                  return KEY_tr;
4579             break;
4580         case 3:
4581             if (strEQ(d,"tie"))                 return KEY_tie;
4582             break;
4583         case 4:
4584             if (strEQ(d,"tell"))                return -KEY_tell;
4585             if (strEQ(d,"tied"))                return KEY_tied;
4586             if (strEQ(d,"time"))                return -KEY_time;
4587             break;
4588         case 5:
4589             if (strEQ(d,"times"))               return -KEY_times;
4590             break;
4591         case 7:
4592             if (strEQ(d,"telldir"))             return -KEY_telldir;
4593             break;
4594         case 8:
4595             if (strEQ(d,"truncate"))            return -KEY_truncate;
4596             break;
4597         }
4598         break;
4599     case 'u':
4600         switch (len) {
4601         case 2:
4602             if (strEQ(d,"uc"))                  return -KEY_uc;
4603             break;
4604         case 3:
4605             if (strEQ(d,"use"))                 return KEY_use;
4606             break;
4607         case 5:
4608             if (strEQ(d,"undef"))               return KEY_undef;
4609             if (strEQ(d,"until"))               return KEY_until;
4610             if (strEQ(d,"untie"))               return KEY_untie;
4611             if (strEQ(d,"utime"))               return -KEY_utime;
4612             if (strEQ(d,"umask"))               return -KEY_umask;
4613             break;
4614         case 6:
4615             if (strEQ(d,"unless"))              return KEY_unless;
4616             if (strEQ(d,"unpack"))              return -KEY_unpack;
4617             if (strEQ(d,"unlink"))              return -KEY_unlink;
4618             break;
4619         case 7:
4620             if (strEQ(d,"unshift"))             return KEY_unshift;
4621             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
4622             break;
4623         }
4624         break;
4625     case 'v':
4626         if (strEQ(d,"values"))                  return -KEY_values;
4627         if (strEQ(d,"vec"))                     return -KEY_vec;
4628         break;
4629     case 'w':
4630         switch (len) {
4631         case 4:
4632             if (strEQ(d,"warn"))                return -KEY_warn;
4633             if (strEQ(d,"wait"))                return -KEY_wait;
4634             break;
4635         case 5:
4636             if (strEQ(d,"while"))               return KEY_while;
4637             if (strEQ(d,"write"))               return -KEY_write;
4638             break;
4639         case 7:
4640             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
4641             break;
4642         case 9:
4643             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
4644             break;
4645         }
4646         break;
4647     case 'x':
4648         if (len == 1)                           return -KEY_x;
4649         if (strEQ(d,"xor"))                     return -KEY_xor;
4650         break;
4651     case 'y':
4652         if (len == 1)                           return KEY_y;
4653         break;
4654     case 'z':
4655         break;
4656     }
4657     return 0;
4658 }
4659
4660 static void
4661 checkcomma(register char *s, char *name, char *what)
4662 {
4663     char *w;
4664
4665     if (dowarn && *s == ' ' && s[1] == '(') {   /* XXX gotta be a better way */
4666         int level = 1;
4667         for (w = s+2; *w && level; w++) {
4668             if (*w == '(')
4669                 ++level;
4670             else if (*w == ')')
4671                 --level;
4672         }
4673         if (*w)
4674             for (; *w && isSPACE(*w); w++) ;
4675         if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4676             warn("%s (...) interpreted as function",name);
4677     }
4678     while (s < bufend && isSPACE(*s))
4679         s++;
4680     if (*s == '(')
4681         s++;
4682     while (s < bufend && isSPACE(*s))
4683         s++;
4684     if (isIDFIRST(*s)) {
4685         w = s++;
4686         while (isALNUM(*s))
4687             s++;
4688         while (s < bufend && isSPACE(*s))
4689             s++;
4690         if (*s == ',') {
4691             int kw;
4692             *s = '\0';
4693             kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4694             *s = ',';
4695             if (kw)
4696                 return;
4697             croak("No comma allowed after %s", what);
4698         }
4699     }
4700 }
4701
4702 static char *
4703 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4704 {
4705     register char *d = dest;
4706     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
4707     for (;;) {
4708         if (d >= e)
4709             croak(ident_too_long);
4710         if (isALNUM(*s))
4711             *d++ = *s++;
4712         else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4713             *d++ = ':';
4714             *d++ = ':';
4715             s++;
4716         }
4717         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4718             *d++ = *s++;
4719             *d++ = *s++;
4720         }
4721         else {
4722             *d = '\0';
4723             *slp = d - dest;
4724             return s;
4725         }
4726     }
4727 }
4728
4729 static char *
4730 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4731 {
4732     register char *d;
4733     register char *e;
4734     char *bracket = 0;
4735     char funny = *s++;
4736
4737     if (lex_brackets == 0)
4738         lex_fakebrack = 0;
4739     if (isSPACE(*s))
4740         s = skipspace(s);
4741     d = dest;
4742     e = d + destlen - 3;        /* two-character token, ending NUL */
4743     if (isDIGIT(*s)) {
4744         while (isDIGIT(*s)) {
4745             if (d >= e)
4746                 croak(ident_too_long);
4747             *d++ = *s++;
4748         }
4749     }
4750     else {
4751         for (;;) {
4752             if (d >= e)
4753                 croak(ident_too_long);
4754             if (isALNUM(*s))
4755                 *d++ = *s++;
4756             else if (*s == '\'' && isIDFIRST(s[1])) {
4757                 *d++ = ':';
4758                 *d++ = ':';
4759                 s++;
4760             }
4761             else if (*s == ':' && s[1] == ':') {
4762                 *d++ = *s++;
4763                 *d++ = *s++;
4764             }
4765             else
4766                 break;
4767         }
4768     }
4769     *d = '\0';
4770     d = dest;
4771     if (*d) {
4772         if (lex_state != LEX_NORMAL)
4773             lex_state = LEX_INTERPENDMAYBE;
4774         return s;
4775     }
4776     if (*s == '$' && s[1] &&
4777       (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4778     {
4779         if (isDIGIT(s[1]) && lex_state == LEX_INTERPNORMAL)
4780             deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4781         else
4782             return s;
4783     }
4784     if (*s == '{') {
4785         bracket = s;
4786         s++;
4787     }
4788     else if (ck_uni)
4789         check_uni();
4790     if (s < send)
4791         *d = *s++;
4792     d[1] = '\0';
4793     if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4794         *d = toCTRL(*s);
4795         s++;
4796     }
4797     if (bracket) {
4798         if (isSPACE(s[-1])) {
4799             while (s < send) {
4800                 char ch = *s++;
4801                 if (ch != ' ' && ch != '\t') {
4802                     *d = ch;
4803                     break;
4804                 }
4805             }
4806         }
4807         if (isIDFIRST(*d)) {
4808             d++;
4809             while (isALNUM(*s) || *s == ':')
4810                 *d++ = *s++;
4811             *d = '\0';
4812             while (s < send && (*s == ' ' || *s == '\t')) s++;
4813             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4814                 if (dowarn && keyword(dest, d - dest)) {
4815                     char *brack = *s == '[' ? "[...]" : "{...}";
4816                     warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4817                         funny, dest, brack, funny, dest, brack);
4818                 }
4819                 lex_fakebrack = lex_brackets+1;
4820                 bracket++;
4821                 lex_brackstack[lex_brackets++] = XOPERATOR;
4822                 return s;
4823             }
4824         }
4825         if (*s == '}') {
4826             s++;
4827             if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
4828                 lex_state = LEX_INTERPEND;
4829             if (funny == '#')
4830                 funny = '@';
4831             if (dowarn && lex_state == LEX_NORMAL &&
4832               (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4833                 warn("Ambiguous use of %c{%s} resolved to %c%s",
4834                     funny, dest, funny, dest);
4835         }
4836         else {
4837             s = bracket;                /* let the parser handle it */
4838             *dest = '\0';
4839         }
4840     }
4841     else if (lex_state == LEX_INTERPNORMAL && !lex_brackets && !intuit_more(s))
4842         lex_state = LEX_INTERPEND;
4843     return s;
4844 }
4845
4846 void pmflag(U16 *pmfl, int ch)
4847 {
4848     if (ch == 'i')
4849         *pmfl |= PMf_FOLD;
4850     else if (ch == 'g')
4851         *pmfl |= PMf_GLOBAL;
4852     else if (ch == 'c')
4853         *pmfl |= PMf_CONTINUE;
4854     else if (ch == 'o')
4855         *pmfl |= PMf_KEEP;
4856     else if (ch == 'm')
4857         *pmfl |= PMf_MULTILINE;
4858     else if (ch == 's')
4859         *pmfl |= PMf_SINGLELINE;
4860     else if (ch == 'x')
4861         *pmfl |= PMf_EXTENDED;
4862 }
4863
4864 static char *
4865 scan_pat(char *start)
4866 {
4867     PMOP *pm;
4868     char *s;
4869
4870     s = scan_str(start);
4871     if (!s) {
4872         if (lex_stuff)
4873             SvREFCNT_dec(lex_stuff);
4874         lex_stuff = Nullsv;
4875         croak("Search pattern not terminated");
4876     }
4877
4878     pm = (PMOP*)newPMOP(OP_MATCH, 0);
4879     if (multi_open == '?')
4880         pm->op_pmflags |= PMf_ONCE;
4881     while (*s && strchr("iogcmsx", *s))
4882         pmflag(&pm->op_pmflags,*s++);
4883     pm->op_pmpermflags = pm->op_pmflags;
4884
4885     lex_op = (OP*)pm;
4886     yylval.ival = OP_MATCH;
4887     return s;
4888 }
4889
4890 static char *
4891 scan_subst(char *start)
4892 {
4893     register char *s;
4894     register PMOP *pm;
4895     I32 first_start;
4896     I32 es = 0;
4897
4898     yylval.ival = OP_NULL;
4899
4900     s = scan_str(start);
4901
4902     if (!s) {
4903         if (lex_stuff)
4904             SvREFCNT_dec(lex_stuff);
4905         lex_stuff = Nullsv;
4906         croak("Substitution pattern not terminated");
4907     }
4908
4909     if (s[-1] == multi_open)
4910         s--;
4911
4912     first_start = multi_start;
4913     s = scan_str(s);
4914     if (!s) {
4915         if (lex_stuff)
4916             SvREFCNT_dec(lex_stuff);
4917         lex_stuff = Nullsv;
4918         if (lex_repl)
4919             SvREFCNT_dec(lex_repl);
4920         lex_repl = Nullsv;
4921         croak("Substitution replacement not terminated");
4922     }
4923     multi_start = first_start;  /* so whole substitution is taken together */
4924
4925     pm = (PMOP*)newPMOP(OP_SUBST, 0);
4926     while (*s && strchr("iogcmsex", *s)) {
4927         if (*s == 'e') {
4928             s++;
4929             es++;
4930         }
4931         else
4932             pmflag(&pm->op_pmflags,*s++);
4933     }
4934
4935     if (es) {
4936         SV *repl;
4937         pm->op_pmflags |= PMf_EVAL;
4938         repl = newSVpv("",0);
4939         while (es-- > 0)
4940             sv_catpv(repl, es ? "eval " : "do ");
4941         sv_catpvn(repl, "{ ", 2);
4942         sv_catsv(repl, lex_repl);
4943         sv_catpvn(repl, " };", 2);
4944         SvCOMPILED_on(repl);
4945         SvREFCNT_dec(lex_repl);
4946         lex_repl = repl;
4947     }
4948
4949     pm->op_pmpermflags = pm->op_pmflags;
4950     lex_op = (OP*)pm;
4951     yylval.ival = OP_SUBST;
4952     return s;
4953 }
4954
4955 static char *
4956 scan_trans(char *start)
4957 {
4958     register char* s;
4959     OP *o;
4960     short *tbl;
4961     I32 squash;
4962     I32 Delete;
4963     I32 complement;
4964
4965     yylval.ival = OP_NULL;
4966
4967     s = scan_str(start);
4968     if (!s) {
4969         if (lex_stuff)
4970             SvREFCNT_dec(lex_stuff);
4971         lex_stuff = Nullsv;
4972         croak("Transliteration pattern not terminated");
4973     }
4974     if (s[-1] == multi_open)
4975         s--;
4976
4977     s = scan_str(s);
4978     if (!s) {
4979         if (lex_stuff)
4980             SvREFCNT_dec(lex_stuff);
4981         lex_stuff = Nullsv;
4982         if (lex_repl)
4983             SvREFCNT_dec(lex_repl);
4984         lex_repl = Nullsv;
4985         croak("Transliteration replacement not terminated");
4986     }
4987
4988     New(803,tbl,256,short);
4989     o = newPVOP(OP_TRANS, 0, (char*)tbl);
4990
4991     complement = Delete = squash = 0;
4992     while (*s == 'c' || *s == 'd' || *s == 's') {
4993         if (*s == 'c')
4994             complement = OPpTRANS_COMPLEMENT;
4995         else if (*s == 'd')
4996             Delete = OPpTRANS_DELETE;
4997         else
4998             squash = OPpTRANS_SQUASH;
4999         s++;
5000     }
5001     o->op_private = Delete|squash|complement;
5002
5003     lex_op = o;
5004     yylval.ival = OP_TRANS;
5005     return s;
5006 }
5007
5008 static char *
5009 scan_heredoc(register char *s)
5010 {
5011     dTHR;
5012     SV *herewas;
5013     I32 op_type = OP_SCALAR;
5014     I32 len;
5015     SV *tmpstr;
5016     char term;
5017     register char *d;
5018     register char *e;
5019     char *peek;
5020     int outer = (rsfp && !(lex_inwhat == OP_SCALAR));
5021
5022     s += 2;
5023     d = tokenbuf;
5024     e = tokenbuf + sizeof tokenbuf - 1;
5025     if (!outer)
5026         *d++ = '\n';
5027     for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5028     if (*peek && strchr("`'\"",*peek)) {
5029         s = peek;
5030         term = *s++;
5031         s = delimcpy(d, e, s, bufend, term, &len);
5032         d += len;
5033         if (s < bufend)
5034             s++;
5035     }
5036     else {
5037         if (*s == '\\')
5038             s++, term = '\'';
5039         else
5040             term = '"';
5041         if (!isALNUM(*s))
5042             deprecate("bare << to mean <<\"\"");
5043         for (; isALNUM(*s); s++) {
5044             if (d < e)
5045                 *d++ = *s;
5046         }
5047     }
5048     if (d >= tokenbuf + sizeof tokenbuf - 1)
5049         croak("Delimiter for here document is too long");
5050     *d++ = '\n';
5051     *d = '\0';
5052     len = d - tokenbuf;
5053     d = "\n";
5054     if (outer || !(d=ninstr(s,bufend,d,d+1)))
5055         herewas = newSVpv(s,bufend-s);
5056     else
5057         s--, herewas = newSVpv(s,d-s);
5058     s += SvCUR(herewas);
5059
5060     tmpstr = NEWSV(87,80);
5061     sv_upgrade(tmpstr, SVt_PVIV);
5062     if (term == '\'') {
5063         op_type = OP_CONST;
5064         SvIVX(tmpstr) = -1;
5065     }
5066     else if (term == '`') {
5067         op_type = OP_BACKTICK;
5068         SvIVX(tmpstr) = '\\';
5069     }
5070
5071     CLINE;
5072     multi_start = curcop->cop_line;
5073     multi_open = multi_close = '<';
5074     term = *tokenbuf;
5075     if (!outer) {
5076         d = s;
5077         while (s < bufend &&
5078           (*s != term || memNE(s,tokenbuf,len)) ) {
5079             if (*s++ == '\n')
5080                 curcop->cop_line++;
5081         }
5082         if (s >= bufend) {
5083             curcop->cop_line = multi_start;
5084             missingterm(tokenbuf);
5085         }
5086         sv_setpvn(tmpstr,d+1,s-d);
5087         s += len - 1;
5088         curcop->cop_line++;     /* the preceding stmt passes a newline */
5089
5090         sv_catpvn(herewas,s,bufend-s);
5091         sv_setsv(linestr,herewas);
5092         oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
5093         bufend = SvPVX(linestr) + SvCUR(linestr);
5094     }
5095     else
5096         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
5097     while (s >= bufend) {       /* multiple line string? */
5098         if (!outer ||
5099          !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5100             curcop->cop_line = multi_start;
5101             missingterm(tokenbuf);
5102         }
5103         curcop->cop_line++;
5104         if (PERLDB_LINE && curstash != debstash) {
5105             SV *sv = NEWSV(88,0);
5106
5107             sv_upgrade(sv, SVt_PVMG);
5108             sv_setsv(sv,linestr);
5109             av_store(GvAV(curcop->cop_filegv),
5110               (I32)curcop->cop_line,sv);
5111         }
5112         bufend = SvPVX(linestr) + SvCUR(linestr);
5113         if (*s == term && memEQ(s,tokenbuf,len)) {
5114             s = bufend - 1;
5115             *s = ' ';
5116             sv_catsv(linestr,herewas);
5117             bufend = SvPVX(linestr) + SvCUR(linestr);
5118         }
5119         else {
5120             s = bufend;
5121             sv_catsv(tmpstr,linestr);
5122         }
5123     }
5124     multi_end = curcop->cop_line;
5125     s++;
5126     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5127         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5128         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5129     }
5130     SvREFCNT_dec(herewas);
5131     lex_stuff = tmpstr;
5132     yylval.ival = op_type;
5133     return s;
5134 }
5135
5136 /* scan_inputsymbol
5137    takes: current position in input buffer
5138    returns: new position in input buffer
5139    side-effects: yylval and lex_op are set.
5140
5141    This code handles:
5142
5143    <>           read from ARGV
5144    <FH>         read from filehandle
5145    <pkg::FH>    read from package qualified filehandle
5146    <pkg'FH>     read from package qualified filehandle
5147    <$fh>        read from filehandle in $fh
5148    <*.h>        filename glob
5149
5150 */
5151
5152 static char *
5153 scan_inputsymbol(char *start)
5154 {
5155     register char *s = start;           /* current position in buffer */
5156     register char *d;
5157     register char *e;
5158     I32 len;
5159
5160     d = tokenbuf;                       /* start of temp holding space */
5161     e = tokenbuf + sizeof tokenbuf;     /* end of temp holding space */
5162     s = delimcpy(d, e, s + 1, bufend, '>', &len);       /* extract until > */
5163
5164     /* die if we didn't have space for the contents of the <>,
5165        or if it didn't end
5166     */
5167
5168     if (len >= sizeof tokenbuf)
5169         croak("Excessively long <> operator");
5170     if (s >= bufend)
5171         croak("Unterminated <> operator");
5172
5173     s++;
5174
5175     /* check for <$fh>
5176        Remember, only scalar variables are interpreted as filehandles by
5177        this code.  Anything more complex (e.g., <$fh{$num}>) will be
5178        treated as a glob() call.
5179        This code makes use of the fact that except for the $ at the front,
5180        a scalar variable and a filehandle look the same.
5181     */
5182     if (*d == '$' && d[1]) d++;
5183
5184     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5185     while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5186         d++;
5187
5188     /* If we've tried to read what we allow filehandles to look like, and
5189        there's still text left, then it must be a glob() and not a getline.
5190        Use scan_str to pull out the stuff between the <> and treat it
5191        as nothing more than a string.
5192     */
5193
5194     if (d - tokenbuf != len) {
5195         yylval.ival = OP_GLOB;
5196         set_csh();
5197         s = scan_str(start);
5198         if (!s)
5199            croak("Glob not terminated");
5200         return s;
5201     }
5202     else {
5203         /* we're in a filehandle read situation */
5204         d = tokenbuf;
5205
5206         /* turn <> into <ARGV> */
5207         if (!len)
5208             (void)strcpy(d,"ARGV");
5209
5210         /* if <$fh>, create the ops to turn the variable into a
5211            filehandle
5212         */
5213         if (*d == '$') {
5214             I32 tmp;
5215
5216             /* try to find it in the pad for this block, otherwise find
5217                add symbol table ops
5218             */
5219             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5220                 OP *o = newOP(OP_PADSV, 0);
5221                 o->op_targ = tmp;
5222                 lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5223             }
5224             else {
5225                 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5226                 lex_op = (OP*)newUNOP(OP_READLINE, 0,
5227                                         newUNOP(OP_RV2GV, 0,
5228                                             newUNOP(OP_RV2SV, 0,
5229                                                 newGVOP(OP_GV, 0, gv))));
5230             }
5231             /* we created the ops in lex_op, so make yylval.ival a null op */
5232             yylval.ival = OP_NULL;
5233         }
5234
5235         /* If it's none of the above, it must be a literal filehandle
5236            (<Foo::BAR> or <FOO>) so build a simple readline OP */
5237         else {
5238             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5239             lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5240             yylval.ival = OP_NULL;
5241         }
5242     }
5243
5244     return s;
5245 }
5246
5247
5248 /* scan_str
5249    takes: start position in buffer
5250    returns: position to continue reading from buffer
5251    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5252         updates the read buffer.
5253
5254    This subroutine pulls a string out of the input.  It is called for:
5255         q               single quotes           q(literal text)
5256         '               single quotes           'literal text'
5257         qq              double quotes           qq(interpolate $here please)
5258         "               double quotes           "interpolate $here please"
5259         qx              backticks               qx(/bin/ls -l)
5260         `               backticks               `/bin/ls -l`
5261         qw              quote words             @EXPORT_OK = qw( func() $spam )
5262         m//             regexp match            m/this/
5263         s///            regexp substitute       s/this/that/
5264         tr///           string transliterate    tr/this/that/
5265         y///            string transliterate    y/this/that/
5266         ($*@)           sub prototypes          sub foo ($)
5267         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
5268
5269    In most of these cases (all but <>, patterns and transliterate)
5270    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
5271    calls scan_str().  s/// makes yylex() call scan_subst() which calls
5272    scan_str().  tr/// and y/// make yylex() call scan_trans() which
5273    calls scan_str().
5274
5275    It skips whitespace before the string starts, and treats the first
5276    character as the delimiter.  If the delimiter is one of ([{< then
5277    the corresponding "close" character )]}> is used as the closing
5278    delimiter.  It allows quoting of delimiters, and if the string has
5279    balanced delimiters ([{<>}]) it allows nesting.
5280
5281    The lexer always reads these strings into lex_stuff, except in the
5282    case of the operators which take *two* arguments (s/// and tr///)
5283    when it checks to see if lex_stuff is full (presumably with the 1st
5284    arg to s or tr) and if so puts the string into lex_repl.
5285
5286 */
5287
5288 static char *
5289 scan_str(char *start)
5290 {
5291     dTHR;
5292     SV *sv;                             /* scalar value: string */
5293     char *tmps;                         /* temp string, used for delimiter matching */
5294     register char *s = start;           /* current position in the buffer */
5295     register char term;                 /* terminating character */
5296     register char *to;                  /* current position in the sv's data */
5297     I32 brackets = 1;                   /* bracket nesting level */
5298
5299     /* skip space before the delimiter */
5300     if (isSPACE(*s))
5301         s = skipspace(s);
5302
5303     /* mark where we are, in case we need to report errors */
5304     CLINE;
5305
5306     /* after skipping whitespace, the next character is the terminator */
5307     term = *s;
5308     /* mark where we are */
5309     multi_start = curcop->cop_line;
5310     multi_open = term;
5311
5312     /* find corresponding closing delimiter */
5313     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5314         term = tmps[5];
5315     multi_close = term;
5316
5317     /* create a new SV to hold the contents.  87 is leak category, I'm
5318        assuming.  80 is the SV's initial length.  What a random number. */
5319     sv = NEWSV(87,80);
5320     sv_upgrade(sv, SVt_PVIV);
5321     SvIVX(sv) = term;
5322     (void)SvPOK_only(sv);               /* validate pointer */
5323
5324     /* move past delimiter and try to read a complete string */
5325     s++;
5326     for (;;) {
5327         /* extend sv if need be */
5328         SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
5329         /* set 'to' to the next character in the sv's string */
5330         to = SvPVX(sv)+SvCUR(sv);
5331
5332         /* if open delimiter is the close delimiter read unbridle */
5333         if (multi_open == multi_close) {
5334             for (; s < bufend; s++,to++) {
5335                 /* embedded newlines increment the current line number */
5336                 if (*s == '\n' && !rsfp)
5337                     curcop->cop_line++;
5338                 /* handle quoted delimiters */
5339                 if (*s == '\\' && s+1 < bufend && term != '\\') {
5340                     if (s[1] == term)
5341                         s++;
5342                 /* any other quotes are simply copied straight through */
5343                     else
5344                         *to++ = *s++;
5345                 }
5346                 /* terminate when run out of buffer (the for() condition), or
5347                    have found the terminator */
5348                 else if (*s == term)
5349                     break;
5350                 *to = *s;
5351             }
5352         }
5353
5354         /* if the terminator isn't the same as the start character (e.g.,
5355            matched brackets), we have to allow more in the quoting, and
5356            be prepared for nested brackets.
5357         */
5358         else {
5359             /* read until we run out of string, or we find the terminator */
5360             for (; s < bufend; s++,to++) {
5361                 /* embedded newlines increment the line count */
5362                 if (*s == '\n' && !rsfp)
5363                     curcop->cop_line++;
5364                 /* backslashes can escape the open or closing characters */
5365                 if (*s == '\\' && s+1 < bufend) {
5366                     if ((s[1] == multi_open) || (s[1] == multi_close))
5367                         s++;
5368                     else
5369                         *to++ = *s++;
5370                 }
5371                 /* allow nested opens and closes */
5372                 else if (*s == multi_close && --brackets <= 0)
5373                     break;
5374                 else if (*s == multi_open)
5375                     brackets++;
5376                 *to = *s;
5377             }
5378         }
5379         /* terminate the copied string and update the sv's end-of-string */
5380         *to = '\0';
5381         SvCUR_set(sv, to - SvPVX(sv));
5382
5383         /*
5384          * this next chunk reads more into the buffer if we're not done yet
5385          */
5386
5387         if (s < bufend) break;  /* handle case where we are done yet :-) */
5388
5389         /* if we're out of file, or a read fails, bail and reset the current
5390            line marker so we can report where the unterminated string began
5391         */
5392         if (!rsfp ||
5393          !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5394             sv_free(sv);
5395             curcop->cop_line = multi_start;
5396             return Nullch;
5397         }
5398         /* we read a line, so increment our line counter */
5399         curcop->cop_line++;
5400
5401         /* update debugger info */
5402         if (PERLDB_LINE && curstash != debstash) {
5403             SV *sv = NEWSV(88,0);
5404
5405             sv_upgrade(sv, SVt_PVMG);
5406             sv_setsv(sv,linestr);
5407             av_store(GvAV(curcop->cop_filegv),
5408               (I32)curcop->cop_line, sv);
5409         }
5410
5411         /* having changed the buffer, we must update bufend */
5412         bufend = SvPVX(linestr) + SvCUR(linestr);
5413     }
5414
5415     /* at this point, we have successfully read the delimited string */
5416
5417     multi_end = curcop->cop_line;
5418     s++;
5419
5420     /* if we allocated too much space, give some back */
5421     if (SvCUR(sv) + 5 < SvLEN(sv)) {
5422         SvLEN_set(sv, SvCUR(sv) + 1);
5423         Renew(SvPVX(sv), SvLEN(sv), char);
5424     }
5425
5426     /* decide whether this is the first or second quoted string we've read
5427        for this op
5428     */
5429
5430     if (lex_stuff)
5431         lex_repl = sv;
5432     else
5433         lex_stuff = sv;
5434     return s;
5435 }
5436
5437 /*
5438   scan_num
5439   takes: pointer to position in buffer
5440   returns: pointer to new position in buffer
5441   side-effects: builds ops for the constant in yylval.op
5442
5443   Read a number in any of the formats that Perl accepts:
5444
5445   0(x[0-7A-F]+)|([0-7]+)
5446   [\d_]+(\.[\d_]*)?[Ee](\d+)
5447
5448   Underbars (_) are allowed in decimal numbers.  If -w is on,
5449   underbars before a decimal point must be at three digit intervals.
5450
5451   Like most scan_ routines, it uses the tokenbuf buffer to hold the
5452   thing it reads.
5453
5454   If it reads a number without a decimal point or an exponent, it will
5455   try converting the number to an integer and see if it can do so
5456   without loss of precision.
5457 */
5458
5459 char *
5460 scan_num(char *start)
5461 {
5462     register char *s = start;           /* current position in buffer */
5463     register char *d;                   /* destination in temp buffer */
5464     register char *e;                   /* end of temp buffer */
5465     I32 tryiv;                          /* used to see if it can be an int */
5466     double value;                       /* number read, as a double */
5467     SV *sv;                             /* place to put the converted number */
5468     I32 floatit;                        /* boolean: int or float? */
5469     char *lastub = 0;                   /* position of last underbar */
5470     static char number_too_long[] = "Number too long";
5471
5472     /* We use the first character to decide what type of number this is */
5473
5474     switch (*s) {
5475     default:
5476       croak("panic: scan_num");
5477
5478     /* if it starts with a 0, it could be an octal number, a decimal in
5479        0.13 disguise, or a hexadecimal number.
5480     */
5481     case '0':
5482         {
5483           /* variables:
5484              u          holds the "number so far"
5485              shift      the power of 2 of the base (hex == 4, octal == 3)
5486              overflowed was the number more than we can hold?
5487
5488              Shift is used when we add a digit.  It also serves as an "are
5489              we in octal or hex?" indicator to disallow hex characters when
5490              in octal mode.
5491            */
5492             UV u;
5493             I32 shift;
5494             bool overflowed = FALSE;
5495
5496             /* check for hex */
5497             if (s[1] == 'x') {
5498                 shift = 4;
5499                 s += 2;
5500             }
5501             /* check for a decimal in disguise */
5502             else if (s[1] == '.')
5503                 goto decimal;
5504             /* so it must be octal */
5505             else
5506                 shift = 3;
5507             u = 0;
5508
5509             /* read the rest of the octal number */
5510             for (;;) {
5511                 UV n, b;        /* n is used in the overflow test, b is the digit we're adding on */
5512
5513                 switch (*s) {
5514
5515                 /* if we don't mention it, we're done */
5516                 default:
5517                     goto out;
5518
5519                 /* _ are ignored */
5520                 case '_':
5521                     s++;
5522                     break;
5523
5524                 /* 8 and 9 are not octal */
5525                 case '8': case '9':
5526                     if (shift != 4)
5527                         yyerror("Illegal octal digit");
5528                     /* FALL THROUGH */
5529
5530                 /* octal digits */
5531                 case '0': case '1': case '2': case '3': case '4':
5532                 case '5': case '6': case '7':
5533                     b = *s++ & 15;              /* ASCII digit -> value of digit */
5534                     goto digit;
5535
5536                 /* hex digits */
5537                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5538                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5539                     /* make sure they said 0x */
5540                     if (shift != 4)
5541                         goto out;
5542                     b = (*s++ & 7) + 9;
5543
5544                     /* Prepare to put the digit we have onto the end
5545                        of the number so far.  We check for overflows.
5546                     */
5547
5548                   digit:
5549                     n = u << shift;     /* make room for the digit */
5550                     if (!overflowed && (n >> shift) != u) {
5551                         warn("Integer overflow in %s number",
5552                              (shift == 4) ? "hex" : "octal");
5553                         overflowed = TRUE;
5554                     }
5555                     u = n | b;          /* add the digit to the end */
5556                     break;
5557                 }
5558             }
5559
5560           /* if we get here, we had success: make a scalar value from
5561              the number.
5562           */
5563           out:
5564             sv = NEWSV(92,0);
5565             sv_setuv(sv, u);
5566         }
5567         break;
5568
5569     /*
5570       handle decimal numbers.
5571       we're also sent here when we read a 0 as the first digit
5572     */
5573     case '1': case '2': case '3': case '4': case '5':
5574     case '6': case '7': case '8': case '9': case '.':
5575       decimal:
5576         d = tokenbuf;
5577         e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
5578         floatit = FALSE;
5579
5580         /* read next group of digits and _ and copy into d */
5581         while (isDIGIT(*s) || *s == '_') {
5582             /* skip underscores, checking for misplaced ones
5583                if -w is on
5584             */
5585             if (*s == '_') {
5586                 if (dowarn && lastub && s - lastub != 3)
5587                     warn("Misplaced _ in number");
5588                 lastub = ++s;
5589             }
5590             else {
5591                 /* check for end of fixed-length buffer */
5592                 if (d >= e)
5593                     croak(number_too_long);
5594                 /* if we're ok, copy the character */
5595                 *d++ = *s++;
5596             }
5597         }
5598
5599         /* final misplaced underbar check */
5600         if (dowarn && lastub && s - lastub != 3)
5601             warn("Misplaced _ in number");
5602
5603         /* read a decimal portion if there is one.  avoid
5604            3..5 being interpreted as the number 3. followed
5605            by .5
5606         */
5607         if (*s == '.' && s[1] != '.') {
5608             floatit = TRUE;
5609             *d++ = *s++;
5610
5611             /* copy, ignoring underbars, until we run out of
5612                digits.  Note: no misplaced underbar checks!
5613             */
5614             for (; isDIGIT(*s) || *s == '_'; s++) {
5615                 /* fixed length buffer check */
5616                 if (d >= e)
5617                     croak(number_too_long);
5618                 if (*s != '_')
5619                     *d++ = *s;
5620             }
5621         }
5622
5623         /* read exponent part, if present */
5624         if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5625             floatit = TRUE;
5626             s++;
5627
5628             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5629             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
5630
5631             /* allow positive or negative exponent */
5632             if (*s == '+' || *s == '-')
5633                 *d++ = *s++;
5634
5635             /* read digits of exponent (no underbars :-) */
5636             while (isDIGIT(*s)) {
5637                 if (d >= e)
5638                     croak(number_too_long);
5639                 *d++ = *s++;
5640             }
5641         }
5642
5643         /* terminate the string */
5644         *d = '\0';
5645
5646         /* make an sv from the string */
5647         sv = NEWSV(92,0);
5648         /* reset numeric locale in case we were earlier left in Swaziland */
5649         SET_NUMERIC_STANDARD();
5650         value = atof(tokenbuf);
5651
5652         /*
5653            See if we can make do with an integer value without loss of
5654            precision.  We use I_V to cast to an int, because some
5655            compilers have issues.  Then we try casting it back and see
5656            if it was the same.  We only do this if we know we
5657            specifically read an integer.
5658
5659            Note: if floatit is true, then we don't need to do the
5660            conversion at all.
5661         */
5662         tryiv = I_V(value);
5663         if (!floatit && (double)tryiv == value)
5664             sv_setiv(sv, tryiv);
5665         else
5666             sv_setnv(sv, value);
5667         break;
5668     }
5669
5670     /* make the op for the constant and return */
5671
5672     yylval.opval = newSVOP(OP_CONST, 0, sv);
5673
5674     return s;
5675 }
5676
5677 static char *
5678 scan_formline(register char *s)
5679 {
5680     dTHR;
5681     register char *eol;
5682     register char *t;
5683     SV *stuff = newSVpv("",0);
5684     bool needargs = FALSE;
5685
5686     while (!needargs) {
5687         if (*s == '.' || *s == '}') {
5688             /*SUPPRESS 530*/
5689             for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5690             if (*t == '\n')
5691                 break;
5692         }
5693         if (in_eval && !rsfp) {
5694             eol = strchr(s,'\n');
5695             if (!eol++)
5696                 eol = bufend;
5697         }
5698         else
5699             eol = bufend = SvPVX(linestr) + SvCUR(linestr);
5700         if (*s != '#') {
5701             for (t = s; t < eol; t++) {
5702                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5703                     needargs = FALSE;
5704                     goto enough;        /* ~~ must be first line in formline */
5705                 }
5706                 if (*t == '@' || *t == '^')
5707                     needargs = TRUE;
5708             }
5709             sv_catpvn(stuff, s, eol-s);
5710         }
5711         s = eol;
5712         if (rsfp) {
5713             s = filter_gets(linestr, rsfp, 0);
5714             oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
5715             bufend = bufptr + SvCUR(linestr);
5716             if (!s) {
5717                 s = bufptr;
5718                 yyerror("Format not terminated");
5719                 break;
5720             }
5721         }
5722         incline(s);
5723     }
5724   enough:
5725     if (SvCUR(stuff)) {
5726         expect = XTERM;
5727         if (needargs) {
5728             lex_state = LEX_NORMAL;
5729             nextval[nexttoke].ival = 0;
5730             force_next(',');
5731         }
5732         else
5733             lex_state = LEX_FORMLINE;
5734         nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5735         force_next(THING);
5736         nextval[nexttoke].ival = OP_FORMLINE;
5737         force_next(LSTOP);
5738     }
5739     else {
5740         SvREFCNT_dec(stuff);
5741         lex_formbrack = 0;
5742         bufptr = s;
5743     }
5744     return s;
5745 }
5746
5747 static void
5748 set_csh(void)
5749 {
5750 #ifdef CSH
5751     if (!cshlen)
5752         cshlen = strlen(cshname);
5753 #endif
5754 }
5755
5756 I32
5757 start_subparse(I32 is_format, U32 flags)
5758 {
5759     dTHR;
5760     I32 oldsavestack_ix = savestack_ix;
5761     CV* outsidecv = compcv;
5762     AV* comppadlist;
5763
5764     if (compcv) {
5765         assert(SvTYPE(compcv) == SVt_PVCV);
5766     }
5767     save_I32(&subline);
5768     save_item(subname);
5769     SAVEI32(padix);
5770     SAVESPTR(curpad);
5771     SAVESPTR(comppad);
5772     SAVESPTR(comppad_name);
5773     SAVESPTR(compcv);
5774     SAVEI32(comppad_name_fill);
5775     SAVEI32(min_intro_pending);
5776     SAVEI32(max_intro_pending);
5777     SAVEI32(pad_reset_pending);
5778
5779     compcv = (CV*)NEWSV(1104,0);
5780     sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
5781     CvFLAGS(compcv) |= flags;
5782
5783     comppad = newAV();
5784     av_push(comppad, Nullsv);
5785     curpad = AvARRAY(comppad);
5786     comppad_name = newAV();
5787     comppad_name_fill = 0;
5788     min_intro_pending = 0;
5789     padix = 0;
5790     subline = curcop->cop_line;
5791 #ifdef USE_THREADS
5792     av_store(comppad_name, 0, newSVpv("@_", 2));
5793     curpad[0] = (SV*)newAV();
5794     SvPADMY_on(curpad[0]);      /* XXX Needed? */
5795     CvOWNER(compcv) = 0;
5796     New(666, CvMUTEXP(compcv), 1, perl_mutex);
5797     MUTEX_INIT(CvMUTEXP(compcv));
5798 #endif /* USE_THREADS */
5799
5800     comppadlist = newAV();
5801     AvREAL_off(comppadlist);
5802     av_store(comppadlist, 0, (SV*)comppad_name);
5803     av_store(comppadlist, 1, (SV*)comppad);
5804
5805     CvPADLIST(compcv) = comppadlist;
5806     CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
5807 #ifdef USE_THREADS
5808     CvOWNER(compcv) = 0;
5809     New(666, CvMUTEXP(compcv), 1, perl_mutex);
5810     MUTEX_INIT(CvMUTEXP(compcv));
5811 #endif /* USE_THREADS */
5812
5813     return oldsavestack_ix;
5814 }
5815
5816 int
5817 yywarn(char *s)
5818 {
5819     dTHR;
5820     --error_count;
5821     in_eval |= 2;
5822     yyerror(s);
5823     in_eval &= ~2;
5824     return 0;
5825 }
5826
5827 int
5828 yyerror(char *s)
5829 {
5830     dTHR;
5831     char *where = NULL;
5832     char *context = NULL;
5833     int contlen = -1;
5834     SV *msg;
5835
5836     if (!yychar || (yychar == ';' && !rsfp))
5837         where = "at EOF";
5838     else if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
5839       oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
5840         while (isSPACE(*oldoldbufptr))
5841             oldoldbufptr++;
5842         context = oldoldbufptr;
5843         contlen = bufptr - oldoldbufptr;
5844     }
5845     else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
5846       oldbufptr != bufptr) {
5847         while (isSPACE(*oldbufptr))
5848             oldbufptr++;
5849         context = oldbufptr;
5850         contlen = bufptr - oldbufptr;
5851     }
5852     else if (yychar > 255)
5853         where = "next token ???";
5854     else if ((yychar & 127) == 127) {
5855         if (lex_state == LEX_NORMAL ||
5856            (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
5857             where = "at end of line";
5858         else if (lex_inpat)
5859             where = "within pattern";
5860         else
5861             where = "within string";
5862     }
5863     else {
5864         SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
5865         if (yychar < 32)
5866             sv_catpvf(where_sv, "^%c", toCTRL(yychar));
5867         else if (isPRINT_LC(yychar))
5868             sv_catpvf(where_sv, "%c", yychar);
5869         else
5870             sv_catpvf(where_sv, "\\%03o", yychar & 255);
5871         where = SvPVX(where_sv);
5872     }
5873     msg = sv_2mortal(newSVpv(s, 0));
5874     sv_catpvf(msg, " at %_ line %ld, ",
5875               GvSV(curcop->cop_filegv), (long)curcop->cop_line);
5876     if (context)
5877         sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
5878     else
5879         sv_catpvf(msg, "%s\n", where);
5880     if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
5881         sv_catpvf(msg,
5882         "  (Might be a runaway multi-line %c%c string starting on line %ld)\n",
5883                 (int)multi_open,(int)multi_close,(long)multi_start);
5884         multi_end = 0;
5885     }
5886     if (in_eval & 2)
5887         warn("%_", msg);
5888     else if (in_eval)
5889         sv_catsv(ERRSV, msg);
5890     else
5891         PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
5892     if (++error_count >= 10)
5893         croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
5894     in_my = 0;
5895     in_my_stash = Nullhv;
5896     return 0;
5897 }
5898
5899