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