toke.c

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