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