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