toke.c

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