toke.c

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