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+*?|()-nrtfeaxcz0123456789[{]} \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                      || (last_lop_op == OP_ENTERSUB
2899                          && last_proto
2900                          && last_proto[last_proto[0] == ';' ? 1 : 0] == '*')) )
2901                 {
2902                     bool immediate_paren = *s == '(';
2903
2904                     /* (Now we can afford to cross potential line boundary.) */
2905                     s = skipspace(s);
2906
2907                     /* Two barewords in a row may indicate method call. */
2908
2909                     if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
2910                         return tmp;
2911
2912                     /* If not a declared subroutine, it's an indirect object. */
2913                     /* (But it's an indir obj regardless for sort.) */
2914
2915                     if ((last_lop_op == OP_SORT ||
2916                          (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
2917                         (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
2918                         expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
2919                         goto bareword;
2920                     }
2921                 }
2922
2923                 /* If followed by a paren, it's certainly a subroutine. */
2924
2925                 expect = XOPERATOR;
2926                 s = skipspace(s);
2927                 if (*s == '(') {
2928                     CLINE;
2929                     if (gv && GvCVu(gv)) {
2930                         for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
2931                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
2932                             s = d + 1;
2933                             goto its_constant;
2934                         }
2935                     }
2936                     nextval[nexttoke].opval = yylval.opval;
2937                     expect = XOPERATOR;
2938                     force_next(WORD);
2939                     yylval.ival = 0;
2940                     TOKEN('&');
2941                 }
2942
2943                 /* If followed by var or block, call it a method (unless sub) */
2944
2945                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
2946                     last_lop = oldbufptr;
2947                     last_lop_op = OP_METHOD;
2948                     PREBLOCK(METHOD);
2949                 }
2950
2951                 /* If followed by a bareword, see if it looks like indir obj. */
2952
2953                 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
2954                     return tmp;
2955
2956                 /* Not a method, so call it a subroutine (if defined) */
2957
2958                 if (gv && GvCVu(gv)) {
2959                     CV* cv;
2960                     if (lastchar == '-')
2961                         warn("Ambiguous use of -%s resolved as -&%s()",
2962                                 tokenbuf, tokenbuf);
2963                     last_lop = oldbufptr;
2964                     last_lop_op = OP_ENTERSUB;
2965                     /* Check for a constant sub */
2966                     cv = GvCV(gv);
2967                     if ((sv = cv_const_sv(cv))) {
2968                   its_constant:
2969                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
2970                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
2971                         yylval.opval->op_private = 0;
2972                         TOKEN(WORD);
2973                     }
2974
2975                     /* Resolve to GV now. */
2976                     op_free(yylval.opval);
2977                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
2978                     /* Is there a prototype? */
2979                     if (SvPOK(cv)) {
2980                         STRLEN len;
2981                         last_proto = SvPV((SV*)cv, len);
2982                         if (!len)
2983                             TERM(FUNC0SUB);
2984                         if (strEQ(last_proto, "$"))
2985                             OPERATOR(UNIOPSUB);
2986                         if (*last_proto == '&' && *s == '{') {
2987                             sv_setpv(subname,"__ANON__");
2988                             PREBLOCK(LSTOPSUB);
2989                         }
2990                     } else
2991                         last_proto = NULL;
2992                     nextval[nexttoke].opval = yylval.opval;
2993                     expect = XTERM;
2994                     force_next(WORD);
2995                     TOKEN(NOAMP);
2996                 }
2997
2998                 if (hints & HINT_STRICT_SUBS &&
2999                     lastchar != '-' &&
3000                     strnNE(s,"->",2) &&
3001                     last_lop_op != OP_TRUNCATE &&  /* S/F prototype in opcode.pl */
3002                     last_lop_op != OP_ACCEPT &&
3003                     last_lop_op != OP_PIPE_OP &&
3004                     last_lop_op != OP_SOCKPAIR)
3005                 {
3006                     warn(
3007                      "Bareword \"%s\" not allowed while \"strict subs\" in use",
3008                         tokenbuf);
3009                     ++error_count;
3010                 }
3011
3012                 /* Call it a bare word */
3013
3014             bareword:
3015                 if (dowarn) {
3016                     if (lastchar != '-') {
3017                         for (d = tokenbuf; *d && isLOWER(*d); d++) ;
3018                         if (!*d)
3019                             warn(warn_reserved, tokenbuf);
3020                     }
3021                 }
3022
3023             safe_bareword:
3024                 if (lastchar && strchr("*%&", lastchar)) {
3025                     warn("Operator or semicolon missing before %c%s",
3026                         lastchar, tokenbuf);
3027                     warn("Ambiguous use of %c resolved as operator %c",
3028                         lastchar, lastchar);
3029                 }
3030                 TOKEN(WORD);
3031             }
3032
3033         case KEY___FILE__:
3034             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3035                                         newSVsv(GvSV(curcop->cop_filegv)));
3036             TERM(THING);
3037
3038         case KEY___LINE__:
3039             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3040                                     newSVpvf("%ld", (long)curcop->cop_line));
3041             TERM(THING);
3042
3043         case KEY___PACKAGE__:
3044             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3045                                         (curstash
3046                                          ? newSVsv(curstname)
3047                                          : &sv_undef));
3048             TERM(THING);
3049
3050         case KEY___DATA__:
3051         case KEY___END__: {
3052             GV *gv;
3053
3054             /*SUPPRESS 560*/
3055             if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
3056                 char *pname = "main";
3057                 if (tokenbuf[2] == 'D')
3058                     pname = HvNAME(curstash ? curstash : defstash);
3059                 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3060                 GvMULTI_on(gv);
3061                 if (!GvIO(gv))
3062                     GvIOp(gv) = newIO();
3063                 IoIFP(GvIOp(gv)) = rsfp;
3064 #if defined(HAS_FCNTL) && defined(F_SETFD)
3065                 {
3066                     int fd = PerlIO_fileno(rsfp);
3067                     fcntl(fd,F_SETFD,fd >= 3);
3068                 }
3069 #endif
3070                 /* Mark this internal pseudo-handle as clean */
3071                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3072                 if (preprocess)
3073                     IoTYPE(GvIOp(gv)) = '|';
3074                 else if ((PerlIO*)rsfp == PerlIO_stdin())
3075                     IoTYPE(GvIOp(gv)) = '-';
3076                 else
3077                     IoTYPE(GvIOp(gv)) = '<';
3078                 rsfp = Nullfp;
3079             }
3080             goto fake_eof;
3081         }
3082
3083         case KEY_AUTOLOAD:
3084         case KEY_DESTROY:
3085         case KEY_BEGIN:
3086         case KEY_END:
3087         case KEY_INIT:
3088             if (expect == XSTATE) {
3089                 s = bufptr;
3090                 goto really_sub;
3091             }
3092             goto just_a_word;
3093
3094         case KEY_CORE:
3095             if (*s == ':' && s[1] == ':') {
3096                 s += 2;
3097                 d = s;
3098                 s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
3099                 tmp = keyword(tokenbuf, len);
3100                 if (tmp < 0)
3101                     tmp = -tmp;
3102                 goto reserved_word;
3103             }
3104             goto just_a_word;
3105
3106         case KEY_abs:
3107             UNI(OP_ABS);
3108
3109         case KEY_alarm:
3110             UNI(OP_ALARM);
3111
3112         case KEY_accept:
3113             LOP(OP_ACCEPT,XTERM);
3114
3115         case KEY_and:
3116             OPERATOR(ANDOP);
3117
3118         case KEY_atan2:
3119             LOP(OP_ATAN2,XTERM);
3120
3121         case KEY_bind:
3122             LOP(OP_BIND,XTERM);
3123
3124         case KEY_binmode:
3125             UNI(OP_BINMODE);
3126
3127         case KEY_bless:
3128             LOP(OP_BLESS,XTERM);
3129
3130         case KEY_chop:
3131             UNI(OP_CHOP);
3132
3133         case KEY_continue:
3134             PREBLOCK(CONTINUE);
3135
3136         case KEY_chdir:
3137             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
3138             UNI(OP_CHDIR);
3139
3140         case KEY_close:
3141             UNI(OP_CLOSE);
3142
3143         case KEY_closedir:
3144             UNI(OP_CLOSEDIR);
3145
3146         case KEY_cmp:
3147             Eop(OP_SCMP);
3148
3149         case KEY_caller:
3150             UNI(OP_CALLER);
3151
3152         case KEY_crypt:
3153 #ifdef FCRYPT
3154             if (!cryptseen++)
3155                 init_des();
3156 #endif
3157             LOP(OP_CRYPT,XTERM);
3158
3159         case KEY_chmod:
3160             if (dowarn) {
3161                 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3162                 if (*d != '0' && isDIGIT(*d))
3163                     yywarn("chmod: mode argument is missing initial 0");
3164             }
3165             LOP(OP_CHMOD,XTERM);
3166
3167         case KEY_chown:
3168             LOP(OP_CHOWN,XTERM);
3169
3170         case KEY_connect:
3171             LOP(OP_CONNECT,XTERM);
3172
3173         case KEY_chr:
3174             UNI(OP_CHR);
3175
3176         case KEY_cos:
3177             UNI(OP_COS);
3178
3179         case KEY_chroot:
3180             UNI(OP_CHROOT);
3181
3182         case KEY_do:
3183             s = skipspace(s);
3184             if (*s == '{')
3185                 PRETERMBLOCK(DO);
3186             if (*s != '\'')
3187                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3188             OPERATOR(DO);
3189
3190         case KEY_die:
3191             hints |= HINT_BLOCK_SCOPE;
3192             LOP(OP_DIE,XTERM);
3193
3194         case KEY_defined:
3195             UNI(OP_DEFINED);
3196
3197         case KEY_delete:
3198             UNI(OP_DELETE);
3199
3200         case KEY_dbmopen:
3201             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3202             LOP(OP_DBMOPEN,XTERM);
3203
3204         case KEY_dbmclose:
3205             UNI(OP_DBMCLOSE);
3206
3207         case KEY_dump:
3208             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3209             LOOPX(OP_DUMP);
3210
3211         case KEY_else:
3212             PREBLOCK(ELSE);
3213
3214         case KEY_elsif:
3215             yylval.ival = curcop->cop_line;
3216             OPERATOR(ELSIF);
3217
3218         case KEY_eq:
3219             Eop(OP_SEQ);
3220
3221         case KEY_exists:
3222             UNI(OP_EXISTS);
3223
3224         case KEY_exit:
3225             UNI(OP_EXIT);
3226
3227         case KEY_eval:
3228             s = skipspace(s);
3229             expect = (*s == '{') ? XTERMBLOCK : XTERM;
3230             UNIBRACK(OP_ENTEREVAL);
3231
3232         case KEY_eof:
3233             UNI(OP_EOF);
3234
3235         case KEY_exp:
3236             UNI(OP_EXP);
3237
3238         case KEY_each:
3239             UNI(OP_EACH);
3240
3241         case KEY_exec:
3242             set_csh();
3243             LOP(OP_EXEC,XREF);
3244
3245         case KEY_endhostent:
3246             FUN0(OP_EHOSTENT);
3247
3248         case KEY_endnetent:
3249             FUN0(OP_ENETENT);
3250
3251         case KEY_endservent:
3252             FUN0(OP_ESERVENT);
3253
3254         case KEY_endprotoent:
3255             FUN0(OP_EPROTOENT);
3256
3257         case KEY_endpwent:
3258             FUN0(OP_EPWENT);
3259
3260         case KEY_endgrent:
3261             FUN0(OP_EGRENT);
3262
3263         case KEY_for:
3264         case KEY_foreach:
3265             yylval.ival = curcop->cop_line;
3266             s = skipspace(s);
3267             if (expect == XSTATE && isIDFIRST(*s)) {
3268                 char *p = s;
3269                 if ((bufend - p) >= 3 &&
3270                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3271                     p += 2;
3272                 p = skipspace(p);
3273                 if (isIDFIRST(*p))
3274                     croak("Missing $ on loop variable");
3275             }
3276             OPERATOR(FOR);
3277
3278         case KEY_formline:
3279             LOP(OP_FORMLINE,XTERM);
3280
3281         case KEY_fork:
3282             FUN0(OP_FORK);
3283
3284         case KEY_fcntl:
3285             LOP(OP_FCNTL,XTERM);
3286
3287         case KEY_fileno:
3288             UNI(OP_FILENO);
3289
3290         case KEY_flock:
3291             LOP(OP_FLOCK,XTERM);
3292
3293         case KEY_gt:
3294             Rop(OP_SGT);
3295
3296         case KEY_ge:
3297             Rop(OP_SGE);
3298
3299         case KEY_grep:
3300             LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3301
3302         case KEY_goto:
3303             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3304             LOOPX(OP_GOTO);
3305
3306         case KEY_gmtime:
3307             UNI(OP_GMTIME);
3308
3309         case KEY_getc:
3310             UNI(OP_GETC);
3311
3312         case KEY_getppid:
3313             FUN0(OP_GETPPID);
3314
3315         case KEY_getpgrp:
3316             UNI(OP_GETPGRP);
3317
3318         case KEY_getpriority:
3319             LOP(OP_GETPRIORITY,XTERM);
3320
3321         case KEY_getprotobyname:
3322             UNI(OP_GPBYNAME);
3323
3324         case KEY_getprotobynumber:
3325             LOP(OP_GPBYNUMBER,XTERM);
3326
3327         case KEY_getprotoent:
3328             FUN0(OP_GPROTOENT);
3329
3330         case KEY_getpwent:
3331             FUN0(OP_GPWENT);
3332
3333         case KEY_getpwnam:
3334             UNI(OP_GPWNAM);
3335
3336         case KEY_getpwuid:
3337             UNI(OP_GPWUID);
3338
3339         case KEY_getpeername:
3340             UNI(OP_GETPEERNAME);
3341
3342         case KEY_gethostbyname:
3343             UNI(OP_GHBYNAME);
3344
3345         case KEY_gethostbyaddr:
3346             LOP(OP_GHBYADDR,XTERM);
3347
3348         case KEY_gethostent:
3349             FUN0(OP_GHOSTENT);
3350
3351         case KEY_getnetbyname:
3352             UNI(OP_GNBYNAME);
3353
3354         case KEY_getnetbyaddr:
3355             LOP(OP_GNBYADDR,XTERM);
3356
3357         case KEY_getnetent:
3358             FUN0(OP_GNETENT);
3359
3360         case KEY_getservbyname:
3361             LOP(OP_GSBYNAME,XTERM);
3362
3363         case KEY_getservbyport:
3364             LOP(OP_GSBYPORT,XTERM);
3365
3366         case KEY_getservent:
3367             FUN0(OP_GSERVENT);
3368
3369         case KEY_getsockname:
3370             UNI(OP_GETSOCKNAME);
3371
3372         case KEY_getsockopt:
3373             LOP(OP_GSOCKOPT,XTERM);
3374
3375         case KEY_getgrent:
3376             FUN0(OP_GGRENT);
3377
3378         case KEY_getgrnam:
3379             UNI(OP_GGRNAM);
3380
3381         case KEY_getgrgid:
3382             UNI(OP_GGRGID);
3383
3384         case KEY_getlogin:
3385             FUN0(OP_GETLOGIN);
3386
3387         case KEY_glob:
3388             set_csh();
3389             LOP(OP_GLOB,XTERM);
3390
3391         case KEY_hex:
3392             UNI(OP_HEX);
3393
3394         case KEY_if:
3395             yylval.ival = curcop->cop_line;
3396             OPERATOR(IF);
3397
3398         case KEY_index:
3399             LOP(OP_INDEX,XTERM);
3400
3401         case KEY_int:
3402             UNI(OP_INT);
3403
3404         case KEY_ioctl:
3405             LOP(OP_IOCTL,XTERM);
3406
3407         case KEY_join:
3408             LOP(OP_JOIN,XTERM);
3409
3410         case KEY_keys:
3411             UNI(OP_KEYS);
3412
3413         case KEY_kill:
3414             LOP(OP_KILL,XTERM);
3415
3416         case KEY_last:
3417             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3418             LOOPX(OP_LAST);
3419
3420         case KEY_lc:
3421             UNI(OP_LC);
3422
3423         case KEY_lcfirst:
3424             UNI(OP_LCFIRST);
3425
3426         case KEY_local:
3427             OPERATOR(LOCAL);
3428
3429         case KEY_length:
3430             UNI(OP_LENGTH);
3431
3432         case KEY_lt:
3433             Rop(OP_SLT);
3434
3435         case KEY_le:
3436             Rop(OP_SLE);
3437
3438         case KEY_localtime:
3439             UNI(OP_LOCALTIME);
3440
3441         case KEY_log:
3442             UNI(OP_LOG);
3443
3444         case KEY_link:
3445             LOP(OP_LINK,XTERM);
3446
3447         case KEY_listen:
3448             LOP(OP_LISTEN,XTERM);
3449
3450         case KEY_lock:
3451             UNI(OP_LOCK);
3452
3453         case KEY_lstat:
3454             UNI(OP_LSTAT);
3455
3456         case KEY_m:
3457             s = scan_pat(s);
3458             TERM(sublex_start());
3459
3460         case KEY_map:
3461             LOP(OP_MAPSTART,XREF);
3462
3463         case KEY_mkdir:
3464             LOP(OP_MKDIR,XTERM);
3465
3466         case KEY_msgctl:
3467             LOP(OP_MSGCTL,XTERM);
3468
3469         case KEY_msgget:
3470             LOP(OP_MSGGET,XTERM);
3471
3472         case KEY_msgrcv:
3473             LOP(OP_MSGRCV,XTERM);
3474
3475         case KEY_msgsnd:
3476             LOP(OP_MSGSND,XTERM);
3477
3478         case KEY_my:
3479             in_my = TRUE;
3480             s = skipspace(s);
3481             if (isIDFIRST(*s)) {
3482                 s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
3483                 in_my_stash = gv_stashpv(tokenbuf, FALSE);
3484                 if (!in_my_stash) {
3485                     char tmpbuf[1024];
3486                     bufptr = s;
3487                     sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
3488                     yyerror(tmpbuf);
3489                 }
3490             }
3491             OPERATOR(MY);
3492
3493         case KEY_next:
3494             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3495             LOOPX(OP_NEXT);
3496
3497         case KEY_ne:
3498             Eop(OP_SNE);
3499
3500         case KEY_no:
3501             if (expect != XSTATE)
3502                 yyerror("\"no\" not allowed in expression");
3503             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3504             s = force_version(s);
3505             yylval.ival = 0;
3506             OPERATOR(USE);
3507
3508         case KEY_not:
3509             OPERATOR(NOTOP);
3510
3511         case KEY_open:
3512             s = skipspace(s);
3513             if (isIDFIRST(*s)) {
3514                 char *t;
3515                 for (d = s; isALNUM(*d); d++) ;
3516                 t = skipspace(d);
3517                 if (strchr("|&*+-=!?:.", *t))
3518                     warn("Precedence problem: open %.*s should be open(%.*s)",
3519                         d-s,s, d-s,s);
3520             }
3521             LOP(OP_OPEN,XTERM);
3522
3523         case KEY_or:
3524             yylval.ival = OP_OR;
3525             OPERATOR(OROP);
3526
3527         case KEY_ord:
3528             UNI(OP_ORD);
3529
3530         case KEY_oct:
3531             UNI(OP_OCT);
3532
3533         case KEY_opendir:
3534             LOP(OP_OPEN_DIR,XTERM);
3535
3536         case KEY_print:
3537             checkcomma(s,tokenbuf,"filehandle");
3538             LOP(OP_PRINT,XREF);
3539
3540         case KEY_printf:
3541             checkcomma(s,tokenbuf,"filehandle");
3542             LOP(OP_PRTF,XREF);
3543
3544         case KEY_prototype:
3545             UNI(OP_PROTOTYPE);
3546
3547         case KEY_push:
3548             LOP(OP_PUSH,XTERM);
3549
3550         case KEY_pop:
3551             UNI(OP_POP);
3552
3553         case KEY_pos:
3554             UNI(OP_POS);
3555
3556         case KEY_pack:
3557             LOP(OP_PACK,XTERM);
3558
3559         case KEY_package:
3560             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3561             OPERATOR(PACKAGE);
3562
3563         case KEY_pipe:
3564             LOP(OP_PIPE_OP,XTERM);
3565
3566         case KEY_q:
3567             s = scan_str(s);
3568             if (!s)
3569                 missingterm((char*)0);
3570             yylval.ival = OP_CONST;
3571             TERM(sublex_start());
3572
3573         case KEY_quotemeta:
3574             UNI(OP_QUOTEMETA);
3575
3576         case KEY_qw:
3577             s = scan_str(s);
3578             if (!s)
3579                 missingterm((char*)0);
3580             if (dowarn && SvLEN(lex_stuff)) {
3581                 d = SvPV_force(lex_stuff, len);
3582                 for (; len; --len, ++d) {
3583                     if (*d == ',') {
3584                         warn("Possible attempt to separate words with commas");
3585                         break;
3586                     }
3587                     if (*d == '#') {
3588                         warn("Possible attempt to put comments in qw() list");
3589                         break;
3590                     }
3591                 }
3592             }
3593             force_next(')');
3594             nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(lex_stuff));
3595             lex_stuff = Nullsv;
3596             force_next(THING);
3597             force_next(',');
3598             nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3599             force_next(THING);
3600             force_next('(');
3601             yylval.ival = OP_SPLIT;
3602             CLINE;
3603             expect = XTERM;
3604             bufptr = s;
3605             last_lop = oldbufptr;
3606             last_lop_op = OP_SPLIT;
3607             return FUNC;
3608
3609         case KEY_qq:
3610             s = scan_str(s);
3611             if (!s)
3612                 missingterm((char*)0);
3613             yylval.ival = OP_STRINGIFY;
3614             if (SvIVX(lex_stuff) == '\'')
3615                 SvIVX(lex_stuff) = 0;   /* qq'$foo' should intepolate */
3616             TERM(sublex_start());
3617
3618         case KEY_qx:
3619             s = scan_str(s);
3620             if (!s)
3621                 missingterm((char*)0);
3622             yylval.ival = OP_BACKTICK;
3623             set_csh();
3624             TERM(sublex_start());
3625
3626         case KEY_return:
3627             OLDLOP(OP_RETURN);
3628
3629         case KEY_require:
3630             *tokenbuf = '\0';
3631             s = force_word(s,WORD,TRUE,TRUE,FALSE);
3632             if (isIDFIRST(*tokenbuf))
3633                 gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
3634             else if (*s == '<')
3635                 yyerror("<> should be quotes");
3636             UNI(OP_REQUIRE);
3637
3638         case KEY_reset:
3639             UNI(OP_RESET);
3640
3641         case KEY_redo:
3642             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3643             LOOPX(OP_REDO);
3644
3645         case KEY_rename:
3646             LOP(OP_RENAME,XTERM);
3647
3648         case KEY_rand:
3649             UNI(OP_RAND);
3650
3651         case KEY_rmdir:
3652             UNI(OP_RMDIR);
3653
3654         case KEY_rindex:
3655             LOP(OP_RINDEX,XTERM);
3656
3657         case KEY_read:
3658             LOP(OP_READ,XTERM);
3659
3660         case KEY_readdir:
3661             UNI(OP_READDIR);
3662
3663         case KEY_readline:
3664             set_csh();
3665             UNI(OP_READLINE);
3666
3667         case KEY_readpipe:
3668             set_csh();
3669             UNI(OP_BACKTICK);
3670
3671         case KEY_rewinddir:
3672             UNI(OP_REWINDDIR);
3673
3674         case KEY_recv:
3675             LOP(OP_RECV,XTERM);
3676
3677         case KEY_reverse:
3678             LOP(OP_REVERSE,XTERM);
3679
3680         case KEY_readlink:
3681             UNI(OP_READLINK);
3682
3683         case KEY_ref:
3684             UNI(OP_REF);
3685
3686         case KEY_s:
3687             s = scan_subst(s);
3688             if (yylval.opval)
3689                 TERM(sublex_start());
3690             else
3691                 TOKEN(1);       /* force error */
3692
3693         case KEY_chomp:
3694             UNI(OP_CHOMP);
3695
3696         case KEY_scalar:
3697             UNI(OP_SCALAR);
3698
3699         case KEY_select:
3700             LOP(OP_SELECT,XTERM);
3701
3702         case KEY_seek:
3703             LOP(OP_SEEK,XTERM);
3704
3705         case KEY_semctl:
3706             LOP(OP_SEMCTL,XTERM);
3707
3708         case KEY_semget:
3709             LOP(OP_SEMGET,XTERM);
3710
3711         case KEY_semop:
3712             LOP(OP_SEMOP,XTERM);
3713
3714         case KEY_send:
3715             LOP(OP_SEND,XTERM);
3716
3717         case KEY_setpgrp:
3718             LOP(OP_SETPGRP,XTERM);
3719
3720         case KEY_setpriority:
3721             LOP(OP_SETPRIORITY,XTERM);
3722
3723         case KEY_sethostent:
3724             UNI(OP_SHOSTENT);
3725
3726         case KEY_setnetent:
3727             UNI(OP_SNETENT);
3728
3729         case KEY_setservent:
3730             UNI(OP_SSERVENT);
3731
3732         case KEY_setprotoent:
3733             UNI(OP_SPROTOENT);
3734
3735         case KEY_setpwent:
3736             FUN0(OP_SPWENT);
3737
3738         case KEY_setgrent:
3739             FUN0(OP_SGRENT);
3740
3741         case KEY_seekdir:
3742             LOP(OP_SEEKDIR,XTERM);
3743
3744         case KEY_setsockopt:
3745             LOP(OP_SSOCKOPT,XTERM);
3746
3747         case KEY_shift:
3748             UNI(OP_SHIFT);
3749
3750         case KEY_shmctl:
3751             LOP(OP_SHMCTL,XTERM);
3752
3753         case KEY_shmget:
3754             LOP(OP_SHMGET,XTERM);
3755
3756         case KEY_shmread:
3757             LOP(OP_SHMREAD,XTERM);
3758
3759         case KEY_shmwrite:
3760             LOP(OP_SHMWRITE,XTERM);
3761
3762         case KEY_shutdown:
3763             LOP(OP_SHUTDOWN,XTERM);
3764
3765         case KEY_sin:
3766             UNI(OP_SIN);
3767
3768         case KEY_sleep:
3769             UNI(OP_SLEEP);
3770
3771         case KEY_socket:
3772             LOP(OP_SOCKET,XTERM);
3773
3774         case KEY_socketpair:
3775             LOP(OP_SOCKPAIR,XTERM);
3776
3777         case KEY_sort:
3778             checkcomma(s,tokenbuf,"subroutine name");
3779             s = skipspace(s);
3780             if (*s == ';' || *s == ')')         /* probably a close */
3781                 croak("sort is now a reserved word");
3782             expect = XTERM;
3783             s = force_word(s,WORD,TRUE,TRUE,FALSE);
3784             LOP(OP_SORT,XREF);
3785
3786         case KEY_split:
3787             LOP(OP_SPLIT,XTERM);
3788
3789         case KEY_sprintf:
3790             LOP(OP_SPRINTF,XTERM);
3791
3792         case KEY_splice:
3793             LOP(OP_SPLICE,XTERM);
3794
3795         case KEY_sqrt:
3796             UNI(OP_SQRT);
3797
3798         case KEY_srand:
3799             UNI(OP_SRAND);
3800
3801         case KEY_stat:
3802             UNI(OP_STAT);
3803
3804         case KEY_study:
3805             sawstudy++;
3806             UNI(OP_STUDY);
3807
3808         case KEY_substr:
3809             LOP(OP_SUBSTR,XTERM);
3810
3811         case KEY_format:
3812         case KEY_sub:
3813           really_sub:
3814             s = skipspace(s);
3815
3816             if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3817                 char tmpbuf[sizeof tokenbuf];
3818                 expect = XBLOCK;
3819                 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3820                 if (strchr(tmpbuf, ':'))
3821                     sv_setpv(subname, tmpbuf);
3822                 else {
3823                     sv_setsv(subname,curstname);
3824                     sv_catpvn(subname,"::",2);
3825                     sv_catpvn(subname,tmpbuf,len);
3826                 }
3827                 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3828                 s = skipspace(s);
3829             }
3830             else {
3831                 expect = XTERMBLOCK;
3832                 sv_setpv(subname,"?");
3833             }
3834
3835             if (tmp == KEY_format) {
3836                 s = skipspace(s);
3837                 if (*s == '=')
3838                     lex_formbrack = lex_brackets + 1;
3839                 OPERATOR(FORMAT);
3840             }
3841
3842             /* Look for a prototype */
3843             if (*s == '(') {
3844                 char *p;
3845
3846                 s = scan_str(s);
3847                 if (!s) {
3848                     if (lex_stuff)
3849                         SvREFCNT_dec(lex_stuff);
3850                     lex_stuff = Nullsv;
3851                     croak("Prototype not terminated");
3852                 }
3853                 /* strip spaces */
3854                 d = SvPVX(lex_stuff);
3855                 tmp = 0;
3856                 for (p = d; *p; ++p) {
3857                     if (!isSPACE(*p))
3858                         d[tmp++] = *p;
3859                 }
3860                 d[tmp] = '\0';
3861                 SvCUR(lex_stuff) = tmp;
3862
3863                 nexttoke++;
3864                 nextval[1] = nextval[0];
3865                 nexttype[1] = nexttype[0];
3866                 nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff);
3867                 nexttype[0] = THING;
3868                 if (nexttoke == 1) {
3869                     lex_defer = lex_state;
3870                     lex_expect = expect;
3871                     lex_state = LEX_KNOWNEXT;
3872                 }
3873                 lex_stuff = Nullsv;
3874             }
3875
3876             if (*SvPV(subname,na) == '?') {
3877                 sv_setpv(subname,"__ANON__");
3878                 TOKEN(ANONSUB);
3879             }
3880             PREBLOCK(SUB);
3881
3882         case KEY_system:
3883             set_csh();
3884             LOP(OP_SYSTEM,XREF);
3885
3886         case KEY_symlink:
3887             LOP(OP_SYMLINK,XTERM);
3888
3889         case KEY_syscall:
3890             LOP(OP_SYSCALL,XTERM);
3891
3892         case KEY_sysopen:
3893             LOP(OP_SYSOPEN,XTERM);
3894
3895         case KEY_sysseek:
3896             LOP(OP_SYSSEEK,XTERM);
3897
3898         case KEY_sysread:
3899             LOP(OP_SYSREAD,XTERM);
3900
3901         case KEY_syswrite:
3902             LOP(OP_SYSWRITE,XTERM);
3903
3904         case KEY_tr:
3905             s = scan_trans(s);
3906             TERM(sublex_start());
3907
3908         case KEY_tell:
3909             UNI(OP_TELL);
3910
3911         case KEY_telldir:
3912             UNI(OP_TELLDIR);
3913
3914         case KEY_tie:
3915             LOP(OP_TIE,XTERM);
3916
3917         case KEY_tied:
3918             UNI(OP_TIED);
3919
3920         case KEY_time:
3921             FUN0(OP_TIME);
3922
3923         case KEY_times:
3924             FUN0(OP_TMS);
3925
3926         case KEY_truncate:
3927             LOP(OP_TRUNCATE,XTERM);
3928
3929         case KEY_uc:
3930             UNI(OP_UC);
3931
3932         case KEY_ucfirst:
3933             UNI(OP_UCFIRST);
3934
3935         case KEY_untie:
3936             UNI(OP_UNTIE);
3937
3938         case KEY_until:
3939             yylval.ival = curcop->cop_line;
3940             OPERATOR(UNTIL);
3941
3942         case KEY_unless:
3943             yylval.ival = curcop->cop_line;
3944             OPERATOR(UNLESS);
3945
3946         case KEY_unlink:
3947             LOP(OP_UNLINK,XTERM);
3948
3949         case KEY_undef:
3950             UNI(OP_UNDEF);
3951
3952         case KEY_unpack:
3953             LOP(OP_UNPACK,XTERM);
3954
3955         case KEY_utime:
3956             LOP(OP_UTIME,XTERM);
3957
3958         case KEY_umask:
3959             if (dowarn) {
3960                 for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
3961                 if (*d != '0' && isDIGIT(*d))
3962                     yywarn("umask: argument is missing initial 0");
3963             }
3964             UNI(OP_UMASK);
3965
3966         case KEY_unshift:
3967             LOP(OP_UNSHIFT,XTERM);
3968
3969         case KEY_use:
3970             if (expect != XSTATE)
3971                 yyerror("\"use\" not allowed in expression");
3972             s = skipspace(s);
3973             if(isDIGIT(*s)) {
3974                 s = force_version(s);
3975                 if(*s == ';' || (s = skipspace(s), *s == ';')) {
3976                     nextval[nexttoke].opval = Nullop;
3977                     force_next(WORD);
3978                 }
3979             }
3980             else {
3981                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3982                 s = force_version(s);
3983             }
3984             yylval.ival = 1;
3985             OPERATOR(USE);
3986
3987         case KEY_values:
3988             UNI(OP_VALUES);
3989
3990         case KEY_vec:
3991             sawvec = TRUE;
3992             LOP(OP_VEC,XTERM);
3993
3994         case KEY_while:
3995             yylval.ival = curcop->cop_line;
3996             OPERATOR(WHILE);
3997
3998         case KEY_warn:
3999             hints |= HINT_BLOCK_SCOPE;
4000             LOP(OP_WARN,XTERM);
4001
4002         case KEY_wait:
4003             FUN0(OP_WAIT);
4004
4005         case KEY_waitpid:
4006             LOP(OP_WAITPID,XTERM);
4007
4008         case KEY_wantarray:
4009             FUN0(OP_WANTARRAY);
4010
4011         case KEY_write:
4012             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
4013             UNI(OP_ENTERWRITE);
4014
4015         case KEY_x:
4016             if (expect == XOPERATOR)
4017                 Mop(OP_REPEAT);
4018             check_uni();
4019             goto just_a_word;
4020
4021         case KEY_xor:
4022             yylval.ival = OP_XOR;
4023             OPERATOR(OROP);
4024
4025         case KEY_y:
4026             s = scan_trans(s);
4027             TERM(sublex_start());
4028         }
4029     }}
4030 }
4031
4032 I32
4033 keyword(register char *d, I32 len)
4034 {
4035     switch (*d) {
4036     case '_':
4037         if (d[1] == '_') {
4038             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
4039             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
4040             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
4041             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
4042             if (strEQ(d,"__END__"))             return KEY___END__;
4043         }
4044         break;
4045     case 'A':
4046         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
4047         break;
4048     case 'a':
4049         switch (len) {
4050         case 3:
4051             if (strEQ(d,"and"))                 return -KEY_and;
4052             if (strEQ(d,"abs"))                 return -KEY_abs;
4053             break;
4054         case 5:
4055             if (strEQ(d,"alarm"))               return -KEY_alarm;
4056             if (strEQ(d,"atan2"))               return -KEY_atan2;
4057             break;
4058         case 6:
4059             if (strEQ(d,"accept"))              return -KEY_accept;
4060             break;
4061         }
4062         break;
4063     case 'B':
4064         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
4065         break;
4066     case 'b':
4067         if (strEQ(d,"bless"))                   return -KEY_bless;
4068         if (strEQ(d,"bind"))                    return -KEY_bind;
4069         if (strEQ(d,"binmode"))                 return -KEY_binmode;
4070         break;
4071     case 'C':
4072         if (strEQ(d,"CORE"))                    return -KEY_CORE;
4073         break;
4074     case 'c':
4075         switch (len) {
4076         case 3:
4077             if (strEQ(d,"cmp"))                 return -KEY_cmp;
4078             if (strEQ(d,"chr"))                 return -KEY_chr;
4079             if (strEQ(d,"cos"))                 return -KEY_cos;
4080             break;
4081         case 4:
4082             if (strEQ(d,"chop"))                return KEY_chop;
4083             break;
4084         case 5:
4085             if (strEQ(d,"close"))               return -KEY_close;
4086             if (strEQ(d,"chdir"))               return -KEY_chdir;
4087             if (strEQ(d,"chomp"))               return KEY_chomp;
4088             if (strEQ(d,"chmod"))               return -KEY_chmod;
4089             if (strEQ(d,"chown"))               return -KEY_chown;
4090             if (strEQ(d,"crypt"))               return -KEY_crypt;
4091             break;
4092         case 6:
4093             if (strEQ(d,"chroot"))              return -KEY_chroot;
4094             if (strEQ(d,"caller"))              return -KEY_caller;
4095             break;
4096         case 7:
4097             if (strEQ(d,"connect"))             return -KEY_connect;
4098             break;
4099         case 8:
4100             if (strEQ(d,"closedir"))            return -KEY_closedir;
4101             if (strEQ(d,"continue"))            return -KEY_continue;
4102             break;
4103         }
4104         break;
4105     case 'D':
4106         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
4107         break;
4108     case 'd':
4109         switch (len) {
4110         case 2:
4111             if (strEQ(d,"do"))                  return KEY_do;
4112             break;
4113         case 3:
4114             if (strEQ(d,"die"))                 return -KEY_die;
4115             break;
4116         case 4:
4117             if (strEQ(d,"dump"))                return -KEY_dump;
4118             break;
4119         case 6:
4120             if (strEQ(d,"delete"))              return KEY_delete;
4121             break;
4122         case 7:
4123             if (strEQ(d,"defined"))             return KEY_defined;
4124             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
4125             break;
4126         case 8:
4127             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
4128             break;
4129         }
4130         break;
4131     case 'E':
4132         if (strEQ(d,"EQ")) { deprecate(d);      return -KEY_eq;}
4133         if (strEQ(d,"END"))                     return KEY_END;
4134         break;
4135     case 'e':
4136         switch (len) {
4137         case 2:
4138             if (strEQ(d,"eq"))                  return -KEY_eq;
4139             break;
4140         case 3:
4141             if (strEQ(d,"eof"))                 return -KEY_eof;
4142             if (strEQ(d,"exp"))                 return -KEY_exp;
4143             break;
4144         case 4:
4145             if (strEQ(d,"else"))                return KEY_else;
4146             if (strEQ(d,"exit"))                return -KEY_exit;
4147             if (strEQ(d,"eval"))                return KEY_eval;
4148             if (strEQ(d,"exec"))                return -KEY_exec;
4149             if (strEQ(d,"each"))                return KEY_each;
4150             break;
4151         case 5:
4152             if (strEQ(d,"elsif"))               return KEY_elsif;
4153             break;
4154         case 6:
4155             if (strEQ(d,"exists"))              return KEY_exists;
4156             if (strEQ(d,"elseif")) warn("elseif should be elsif");
4157             break;
4158         case 8:
4159             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
4160             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
4161             break;
4162         case 9:
4163             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
4164             break;
4165         case 10:
4166             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
4167             if (strEQ(d,"endservent"))          return -KEY_endservent;
4168             break;
4169         case 11:
4170             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
4171             break;
4172         }
4173         break;
4174     case 'f':
4175         switch (len) {
4176         case 3:
4177             if (strEQ(d,"for"))                 return KEY_for;
4178             break;
4179         case 4:
4180             if (strEQ(d,"fork"))                return -KEY_fork;
4181             break;
4182         case 5:
4183             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
4184             if (strEQ(d,"flock"))               return -KEY_flock;
4185             break;
4186         case 6:
4187             if (strEQ(d,"format"))              return KEY_format;
4188             if (strEQ(d,"fileno"))              return -KEY_fileno;
4189             break;
4190         case 7:
4191             if (strEQ(d,"foreach"))             return KEY_foreach;
4192             break;
4193         case 8:
4194             if (strEQ(d,"formline"))            return -KEY_formline;
4195             break;
4196         }
4197         break;
4198     case 'G':
4199         if (len == 2) {
4200             if (strEQ(d,"GT")) { deprecate(d);  return -KEY_gt;}
4201             if (strEQ(d,"GE")) { deprecate(d);  return -KEY_ge;}
4202         }
4203         break;
4204     case 'g':
4205         if (strnEQ(d,"get",3)) {
4206             d += 3;
4207             if (*d == 'p') {
4208                 switch (len) {
4209                 case 7:
4210                     if (strEQ(d,"ppid"))        return -KEY_getppid;
4211                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
4212                     break;
4213                 case 8:
4214                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
4215                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
4216                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
4217                     break;
4218                 case 11:
4219                     if (strEQ(d,"peername"))    return -KEY_getpeername;
4220                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
4221                     if (strEQ(d,"priority"))    return -KEY_getpriority;
4222                     break;
4223                 case 14:
4224                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4225                     break;
4226                 case 16:
4227                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4228                     break;
4229                 }
4230             }
4231             else if (*d == 'h') {
4232                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
4233                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
4234                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
4235             }
4236             else if (*d == 'n') {
4237                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
4238                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
4239                 if (strEQ(d,"netent"))          return -KEY_getnetent;
4240             }
4241             else if (*d == 's') {
4242                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
4243                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
4244                 if (strEQ(d,"servent"))         return -KEY_getservent;
4245                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
4246                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
4247             }
4248             else if (*d == 'g') {
4249                 if (strEQ(d,"grent"))           return -KEY_getgrent;
4250                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
4251                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
4252             }
4253             else if (*d == 'l') {
4254                 if (strEQ(d,"login"))           return -KEY_getlogin;
4255             }
4256             else if (strEQ(d,"c"))              return -KEY_getc;
4257             break;
4258         }
4259         switch (len) {
4260         case 2:
4261             if (strEQ(d,"gt"))                  return -KEY_gt;
4262             if (strEQ(d,"ge"))                  return -KEY_ge;
4263             break;
4264         case 4:
4265             if (strEQ(d,"grep"))                return KEY_grep;
4266             if (strEQ(d,"goto"))                return KEY_goto;
4267             if (strEQ(d,"glob"))                return KEY_glob;
4268             break;
4269         case 6:
4270             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
4271             break;
4272         }
4273         break;
4274     case 'h':
4275         if (strEQ(d,"hex"))                     return -KEY_hex;
4276         break;
4277     case 'I':
4278         if (strEQ(d,"INIT"))                    return KEY_INIT;
4279         break;
4280     case 'i':
4281         switch (len) {
4282         case 2:
4283             if (strEQ(d,"if"))                  return KEY_if;
4284             break;
4285         case 3:
4286             if (strEQ(d,"int"))                 return -KEY_int;
4287             break;
4288         case 5:
4289             if (strEQ(d,"index"))               return -KEY_index;
4290             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
4291             break;
4292         }
4293         break;
4294     case 'j':
4295         if (strEQ(d,"join"))                    return -KEY_join;
4296         break;
4297     case 'k':
4298         if (len == 4) {
4299             if (strEQ(d,"keys"))                return KEY_keys;
4300             if (strEQ(d,"kill"))                return -KEY_kill;
4301         }
4302         break;
4303     case 'L':
4304         if (len == 2) {
4305             if (strEQ(d,"LT")) { deprecate(d);  return -KEY_lt;}
4306             if (strEQ(d,"LE")) { deprecate(d);  return -KEY_le;}
4307         }
4308         break;
4309     case 'l':
4310         switch (len) {
4311         case 2:
4312             if (strEQ(d,"lt"))                  return -KEY_lt;
4313             if (strEQ(d,"le"))                  return -KEY_le;
4314             if (strEQ(d,"lc"))                  return -KEY_lc;
4315             break;
4316         case 3:
4317             if (strEQ(d,"log"))                 return -KEY_log;
4318             break;
4319         case 4:
4320             if (strEQ(d,"last"))                return KEY_last;
4321             if (strEQ(d,"link"))                return -KEY_link;
4322             if (strEQ(d,"lock"))                return -KEY_lock;
4323             break;
4324         case 5:
4325             if (strEQ(d,"local"))               return KEY_local;
4326             if (strEQ(d,"lstat"))               return -KEY_lstat;
4327             break;
4328         case 6:
4329             if (strEQ(d,"length"))              return -KEY_length;
4330             if (strEQ(d,"listen"))              return -KEY_listen;
4331             break;
4332         case 7:
4333             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
4334             break;
4335         case 9:
4336             if (strEQ(d,"localtime"))           return -KEY_localtime;
4337             break;
4338         }
4339         break;
4340     case 'm':
4341         switch (len) {
4342         case 1:                                 return KEY_m;
4343         case 2:
4344             if (strEQ(d,"my"))                  return KEY_my;
4345             break;
4346         case 3:
4347             if (strEQ(d,"map"))                 return KEY_map;
4348             break;
4349         case 5:
4350             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
4351             break;
4352         case 6:
4353             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
4354             if (strEQ(d,"msgget"))              return -KEY_msgget;
4355             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
4356             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
4357             break;
4358         }
4359         break;
4360     case 'N':
4361         if (strEQ(d,"NE")) { deprecate(d);      return -KEY_ne;}
4362         break;
4363     case 'n':
4364         if (strEQ(d,"next"))                    return KEY_next;
4365         if (strEQ(d,"ne"))                      return -KEY_ne;
4366         if (strEQ(d,"not"))                     return -KEY_not;
4367         if (strEQ(d,"no"))                      return KEY_no;
4368         break;
4369     case 'o':
4370         switch (len) {
4371         case 2:
4372             if (strEQ(d,"or"))                  return -KEY_or;
4373             break;
4374         case 3:
4375             if (strEQ(d,"ord"))                 return -KEY_ord;
4376             if (strEQ(d,"oct"))                 return -KEY_oct;
4377             break;
4378         case 4:
4379             if (strEQ(d,"open"))                return -KEY_open;
4380             break;
4381         case 7:
4382             if (strEQ(d,"opendir"))             return -KEY_opendir;
4383             break;
4384         }
4385         break;
4386     case 'p':
4387         switch (len) {
4388         case 3:
4389             if (strEQ(d,"pop"))                 return KEY_pop;
4390             if (strEQ(d,"pos"))                 return KEY_pos;
4391             break;
4392         case 4:
4393             if (strEQ(d,"push"))                return KEY_push;
4394             if (strEQ(d,"pack"))                return -KEY_pack;
4395             if (strEQ(d,"pipe"))                return -KEY_pipe;
4396             break;
4397         case 5:
4398             if (strEQ(d,"print"))               return KEY_print;
4399             break;
4400         case 6:
4401             if (strEQ(d,"printf"))              return KEY_printf;
4402             break;
4403         case 7:
4404             if (strEQ(d,"package"))             return KEY_package;
4405             break;
4406         case 9:
4407             if (strEQ(d,"prototype"))           return KEY_prototype;
4408         }
4409         break;
4410     case 'q':
4411         if (len <= 2) {
4412             if (strEQ(d,"q"))                   return KEY_q;
4413             if (strEQ(d,"qq"))                  return KEY_qq;
4414             if (strEQ(d,"qw"))                  return KEY_qw;
4415             if (strEQ(d,"qx"))                  return KEY_qx;
4416         }
4417         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
4418         break;
4419     case 'r':
4420         switch (len) {
4421         case 3:
4422             if (strEQ(d,"ref"))                 return -KEY_ref;
4423             break;
4424         case 4:
4425             if (strEQ(d,"read"))                return -KEY_read;
4426             if (strEQ(d,"rand"))                return -KEY_rand;
4427             if (strEQ(d,"recv"))                return -KEY_recv;
4428             if (strEQ(d,"redo"))                return KEY_redo;
4429             break;
4430         case 5:
4431             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
4432             if (strEQ(d,"reset"))               return -KEY_reset;
4433             break;
4434         case 6:
4435             if (strEQ(d,"return"))              return KEY_return;
4436             if (strEQ(d,"rename"))              return -KEY_rename;
4437             if (strEQ(d,"rindex"))              return -KEY_rindex;
4438             break;
4439         case 7:
4440             if (strEQ(d,"require"))             return -KEY_require;
4441             if (strEQ(d,"reverse"))             return -KEY_reverse;
4442             if (strEQ(d,"readdir"))             return -KEY_readdir;
4443             break;
4444         case 8:
4445             if (strEQ(d,"readlink"))            return -KEY_readlink;
4446             if (strEQ(d,"readline"))            return -KEY_readline;
4447             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
4448             break;
4449         case 9:
4450             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
4451             break;
4452         }
4453         break;
4454     case 's':
4455         switch (d[1]) {
4456         case 0:                                 return KEY_s;
4457         case 'c':
4458             if (strEQ(d,"scalar"))              return KEY_scalar;
4459             break;
4460         case 'e':
4461             switch (len) {
4462             case 4:
4463                 if (strEQ(d,"seek"))            return -KEY_seek;
4464                 if (strEQ(d,"send"))            return -KEY_send;
4465                 break;
4466             case 5:
4467                 if (strEQ(d,"semop"))           return -KEY_semop;
4468                 break;
4469             case 6:
4470                 if (strEQ(d,"select"))          return -KEY_select;
4471                 if (strEQ(d,"semctl"))          return -KEY_semctl;
4472                 if (strEQ(d,"semget"))          return -KEY_semget;
4473                 break;
4474             case 7:
4475                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
4476                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
4477                 break;
4478             case 8:
4479                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
4480                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
4481                 break;
4482             case 9:
4483                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
4484                 break;
4485             case 10:
4486                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
4487                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
4488                 if (strEQ(d,"setservent"))      return -KEY_setservent;
4489                 break;
4490             case 11:
4491                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
4492                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
4493                 break;
4494             }
4495             break;
4496         case 'h':
4497             switch (len) {
4498             case 5:
4499                 if (strEQ(d,"shift"))           return KEY_shift;
4500                 break;
4501             case 6:
4502                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
4503                 if (strEQ(d,"shmget"))          return -KEY_shmget;
4504                 break;
4505             case 7:
4506                 if (strEQ(d,"shmread"))         return -KEY_shmread;
4507                 break;
4508             case 8:
4509                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
4510                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
4511                 break;
4512             }
4513             break;
4514         case 'i':
4515             if (strEQ(d,"sin"))                 return -KEY_sin;
4516             break;
4517         case 'l':
4518             if (strEQ(d,"sleep"))               return -KEY_sleep;
4519             break;
4520         case 'o':
4521             if (strEQ(d,"sort"))                return KEY_sort;
4522             if (strEQ(d,"socket"))              return -KEY_socket;
4523             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
4524             break;
4525         case 'p':
4526             if (strEQ(d,"split"))               return KEY_split;
4527             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
4528             if (strEQ(d,"splice"))              return KEY_splice;
4529             break;
4530         case 'q':
4531             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
4532             break;
4533         case 'r':
4534             if (strEQ(d,"srand"))               return -KEY_srand;
4535             break;
4536         case 't':
4537             if (strEQ(d,"stat"))                return -KEY_stat;
4538             if (strEQ(d,"study"))               return KEY_study;
4539             break;
4540         case 'u':
4541             if (strEQ(d,"substr"))              return -KEY_substr;
4542             if (strEQ(d,"sub"))                 return KEY_sub;
4543             break;
4544         case 'y':
4545             switch (len) {
4546             case 6:
4547                 if (strEQ(d,"system"))          return -KEY_system;
4548                 break;
4549             case 7:
4550                 if (strEQ(d,"symlink"))         return -KEY_symlink;
4551                 if (strEQ(d,"syscall"))         return -KEY_syscall;
4552                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
4553                 if (strEQ(d,"sysread"))         return -KEY_sysread;
4554                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
4555                 break;
4556             case 8:
4557                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
4558                 break;
4559             }
4560             break;
4561         }
4562         break;
4563     case 't':
4564         switch (len) {
4565         case 2:
4566             if (strEQ(d,"tr"))                  return KEY_tr;
4567             break;
4568         case 3:
4569             if (strEQ(d,"tie"))                 return KEY_tie;
4570             break;
4571         case 4:
4572             if (strEQ(d,"tell"))                return -KEY_tell;
4573             if (strEQ(d,"tied"))                return KEY_tied;
4574             if (strEQ(d,"time"))                return -KEY_time;
4575             break;
4576         case 5:
4577             if (strEQ(d,"times"))               return -KEY_times;
4578             break;
4579         case 7:
4580             if (strEQ(d,"telldir"))             return -KEY_telldir;
4581             break;
4582         case 8:
4583             if (strEQ(d,"truncate"))            return -KEY_truncate;
4584             break;
4585         }
4586         break;
4587     case 'u':
4588         switch (len) {
4589         case 2:
4590             if (strEQ(d,"uc"))                  return -KEY_uc;
4591             break;
4592         case 3:
4593             if (strEQ(d,"use"))                 return KEY_use;
4594             break;
4595         case 5:
4596             if (strEQ(d,"undef"))               return KEY_undef;
4597             if (strEQ(d,"until"))               return KEY_until;
4598             if (strEQ(d,"untie"))               return KEY_untie;
4599             if (strEQ(d,"utime"))               return -KEY_utime;
4600             if (strEQ(d,"umask"))               return -KEY_umask;
4601             break;
4602         case 6:
4603             if (strEQ(d,"unless"))              return KEY_unless;
4604             if (strEQ(d,"unpack"))              return -KEY_unpack;
4605             if (strEQ(d,"unlink"))              return -KEY_unlink;
4606             break;
4607         case 7:
4608             if (strEQ(d,"unshift"))             return KEY_unshift;
4609             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
4610             break;
4611         }
4612         break;
4613     case 'v':
4614         if (strEQ(d,"values"))                  return -KEY_values;
4615         if (strEQ(d,"vec"))                     return -KEY_vec;
4616         break;
4617     case 'w':
4618         switch (len) {
4619         case 4:
4620             if (strEQ(d,"warn"))                return -KEY_warn;
4621             if (strEQ(d,"wait"))                return -KEY_wait;
4622             break;
4623         case 5:
4624             if (strEQ(d,"while"))               return KEY_while;
4625             if (strEQ(d,"write"))               return -KEY_write;
4626             break;
4627         case 7:
4628             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
4629             break;
4630         case 9:
4631             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
4632             break;
4633         }
4634         break;
4635     case 'x':
4636         if (len == 1)                           return -KEY_x;
4637         if (strEQ(d,"xor"))                     return -KEY_xor;
4638         break;
4639     case 'y':
4640         if (len == 1)                           return KEY_y;
4641         break;
4642     case 'z':
4643         break;
4644     }
4645     return 0;
4646 }
4647
4648 STATIC void
4649 checkcomma(register char *s, char *name, char *what)
4650 {
4651     char *w;
4652
4653     if (dowarn && *s == ' ' && s[1] == '(') {   /* XXX gotta be a better way */
4654         int level = 1;
4655         for (w = s+2; *w && level; w++) {
4656             if (*w == '(')
4657                 ++level;
4658             else if (*w == ')')
4659                 --level;
4660         }
4661         if (*w)
4662             for (; *w && isSPACE(*w); w++) ;
4663         if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4664             warn("%s (...) interpreted as function",name);
4665     }
4666     while (s < bufend && isSPACE(*s))
4667         s++;
4668     if (*s == '(')
4669         s++;
4670     while (s < bufend && isSPACE(*s))
4671         s++;
4672     if (isIDFIRST(*s)) {
4673         w = s++;
4674         while (isALNUM(*s))
4675             s++;
4676         while (s < bufend && isSPACE(*s))
4677             s++;
4678         if (*s == ',') {
4679             int kw;
4680             *s = '\0';
4681             kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4682             *s = ',';
4683             if (kw)
4684                 return;
4685             croak("No comma allowed after %s", what);
4686         }
4687     }
4688 }
4689
4690 STATIC char *
4691 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4692 {
4693     register char *d = dest;
4694     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
4695     for (;;) {
4696         if (d >= e)
4697             croak(ident_too_long);
4698         if (isALNUM(*s))
4699             *d++ = *s++;
4700         else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4701             *d++ = ':';
4702             *d++ = ':';
4703             s++;
4704         }
4705         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4706             *d++ = *s++;
4707             *d++ = *s++;
4708         }
4709         else {
4710             *d = '\0';
4711             *slp = d - dest;
4712             return s;
4713         }
4714     }
4715 }
4716
4717 STATIC char *
4718 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4719 {
4720     register char *d;
4721     register char *e;
4722     char *bracket = 0;
4723     char funny = *s++;
4724
4725     if (lex_brackets == 0)
4726         lex_fakebrack = 0;
4727     if (isSPACE(*s))
4728         s = skipspace(s);
4729     d = dest;
4730     e = d + destlen - 3;        /* two-character token, ending NUL */
4731     if (isDIGIT(*s)) {
4732         while (isDIGIT(*s)) {
4733             if (d >= e)
4734                 croak(ident_too_long);
4735             *d++ = *s++;
4736         }
4737     }
4738     else {
4739         for (;;) {
4740             if (d >= e)
4741                 croak(ident_too_long);
4742             if (isALNUM(*s))
4743                 *d++ = *s++;
4744             else if (*s == '\'' && isIDFIRST(s[1])) {
4745                 *d++ = ':';
4746                 *d++ = ':';
4747                 s++;
4748             }
4749             else if (*s == ':' && s[1] == ':') {
4750                 *d++ = *s++;
4751                 *d++ = *s++;
4752             }
4753             else
4754                 break;
4755         }
4756     }
4757     *d = '\0';
4758     d = dest;
4759     if (*d) {
4760         if (lex_state != LEX_NORMAL)
4761             lex_state = LEX_INTERPENDMAYBE;
4762         return s;
4763     }
4764     if (*s == '$' && s[1] &&
4765       (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4766     {
4767         if (isDIGIT(s[1]) && lex_state == LEX_INTERPNORMAL)
4768             deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
4769         else
4770             return s;
4771     }
4772     if (*s == '{') {
4773         bracket = s;
4774         s++;
4775     }
4776     else if (ck_uni)
4777         check_uni();
4778     if (s < send)
4779         *d = *s++;
4780     d[1] = '\0';
4781     if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
4782         *d = toCTRL(*s);
4783         s++;
4784     }
4785     if (bracket) {
4786         if (isSPACE(s[-1])) {
4787             while (s < send) {
4788                 char ch = *s++;
4789                 if (ch != ' ' && ch != '\t') {
4790                     *d = ch;
4791                     break;
4792                 }
4793             }
4794         }
4795         if (isIDFIRST(*d)) {
4796             d++;
4797             while (isALNUM(*s) || *s == ':')
4798                 *d++ = *s++;
4799             *d = '\0';
4800             while (s < send && (*s == ' ' || *s == '\t')) s++;
4801             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
4802                 if (dowarn && keyword(dest, d - dest)) {
4803                     char *brack = *s == '[' ? "[...]" : "{...}";
4804                     warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
4805                         funny, dest, brack, funny, dest, brack);
4806                 }
4807                 lex_fakebrack = lex_brackets+1;
4808                 bracket++;
4809                 lex_brackstack[lex_brackets++] = XOPERATOR;
4810                 return s;
4811             }
4812         }
4813         if (*s == '}') {
4814             s++;
4815             if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
4816                 lex_state = LEX_INTERPEND;
4817             if (funny == '#')
4818                 funny = '@';
4819             if (dowarn && lex_state == LEX_NORMAL &&
4820               (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
4821                 warn("Ambiguous use of %c{%s} resolved to %c%s",
4822                     funny, dest, funny, dest);
4823         }
4824         else {
4825             s = bracket;                /* let the parser handle it */
4826             *dest = '\0';
4827         }
4828     }
4829     else if (lex_state == LEX_INTERPNORMAL && !lex_brackets && !intuit_more(s))
4830         lex_state = LEX_INTERPEND;
4831     return s;
4832 }
4833
4834 void pmflag(U16 *pmfl, int ch)
4835 {
4836     if (ch == 'i')
4837         *pmfl |= PMf_FOLD;
4838     else if (ch == 'g')
4839         *pmfl |= PMf_GLOBAL;
4840     else if (ch == 'c')
4841         *pmfl |= PMf_CONTINUE;
4842     else if (ch == 'o')
4843         *pmfl |= PMf_KEEP;
4844     else if (ch == 'm')
4845         *pmfl |= PMf_MULTILINE;
4846     else if (ch == 's')
4847         *pmfl |= PMf_SINGLELINE;
4848     else if (ch == 't')
4849         *pmfl |= PMf_TAINTMEM;
4850     else if (ch == 'x')
4851         *pmfl |= PMf_EXTENDED;
4852 }
4853
4854 STATIC char *
4855 scan_pat(char *start)
4856 {
4857     PMOP *pm;
4858     char *s;
4859
4860     s = scan_str(start);
4861     if (!s) {
4862         if (lex_stuff)
4863             SvREFCNT_dec(lex_stuff);
4864         lex_stuff = Nullsv;
4865         croak("Search pattern not terminated");
4866     }
4867
4868     pm = (PMOP*)newPMOP(OP_MATCH, 0);
4869     if (multi_open == '?')
4870         pm->op_pmflags |= PMf_ONCE;
4871     while (*s && strchr("iogcmstx", *s))
4872         pmflag(&pm->op_pmflags,*s++);
4873     pm->op_pmpermflags = pm->op_pmflags;
4874
4875     lex_op = (OP*)pm;
4876     yylval.ival = OP_MATCH;
4877     return s;
4878 }
4879
4880 STATIC char *
4881 scan_subst(char *start)
4882 {
4883     register char *s;
4884     register PMOP *pm;
4885     I32 first_start;
4886     I32 es = 0;
4887
4888     yylval.ival = OP_NULL;
4889
4890     s = scan_str(start);
4891
4892     if (!s) {
4893         if (lex_stuff)
4894             SvREFCNT_dec(lex_stuff);
4895         lex_stuff = Nullsv;
4896         croak("Substitution pattern not terminated");
4897     }
4898
4899     if (s[-1] == multi_open)
4900         s--;
4901
4902     first_start = multi_start;
4903     s = scan_str(s);
4904     if (!s) {
4905         if (lex_stuff)
4906             SvREFCNT_dec(lex_stuff);
4907         lex_stuff = Nullsv;
4908         if (lex_repl)
4909             SvREFCNT_dec(lex_repl);
4910         lex_repl = Nullsv;
4911         croak("Substitution replacement not terminated");
4912     }
4913     multi_start = first_start;  /* so whole substitution is taken together */
4914
4915     pm = (PMOP*)newPMOP(OP_SUBST, 0);
4916     while (*s) {
4917         if (*s == 'e') {
4918             s++;
4919             es++;
4920         }
4921         else if (strchr("iogcmstx", *s))
4922             pmflag(&pm->op_pmflags,*s++);
4923         else
4924             break;
4925     }
4926
4927     if (es) {
4928         SV *repl;
4929         pm->op_pmflags |= PMf_EVAL;
4930         repl = newSVpv("",0);
4931         while (es-- > 0)
4932             sv_catpv(repl, es ? "eval " : "do ");
4933         sv_catpvn(repl, "{ ", 2);
4934         sv_catsv(repl, lex_repl);
4935         sv_catpvn(repl, " };", 2);
4936         SvCOMPILED_on(repl);
4937         SvREFCNT_dec(lex_repl);
4938         lex_repl = repl;
4939     }
4940
4941     pm->op_pmpermflags = pm->op_pmflags;
4942     lex_op = (OP*)pm;
4943     yylval.ival = OP_SUBST;
4944     return s;
4945 }
4946
4947 STATIC char *
4948 scan_trans(char *start)
4949 {
4950     register char* s;
4951     OP *o;
4952     short *tbl;
4953     I32 squash;
4954     I32 Delete;
4955     I32 complement;
4956
4957     yylval.ival = OP_NULL;
4958
4959     s = scan_str(start);
4960     if (!s) {
4961         if (lex_stuff)
4962             SvREFCNT_dec(lex_stuff);
4963         lex_stuff = Nullsv;
4964         croak("Transliteration pattern not terminated");
4965     }
4966     if (s[-1] == multi_open)
4967         s--;
4968
4969     s = scan_str(s);
4970     if (!s) {
4971         if (lex_stuff)
4972             SvREFCNT_dec(lex_stuff);
4973         lex_stuff = Nullsv;
4974         if (lex_repl)
4975             SvREFCNT_dec(lex_repl);
4976         lex_repl = Nullsv;
4977         croak("Transliteration replacement not terminated");
4978     }
4979
4980     New(803,tbl,256,short);
4981     o = newPVOP(OP_TRANS, 0, (char*)tbl);
4982
4983     complement = Delete = squash = 0;
4984     while (*s == 'c' || *s == 'd' || *s == 's') {
4985         if (*s == 'c')
4986             complement = OPpTRANS_COMPLEMENT;
4987         else if (*s == 'd')
4988             Delete = OPpTRANS_DELETE;
4989         else
4990             squash = OPpTRANS_SQUASH;
4991         s++;
4992     }
4993     o->op_private = Delete|squash|complement;
4994
4995     lex_op = o;
4996     yylval.ival = OP_TRANS;
4997     return s;
4998 }
4999
5000 STATIC char *
5001 scan_heredoc(register char *s)
5002 {
5003     dTHR;
5004     SV *herewas;
5005     I32 op_type = OP_SCALAR;
5006     I32 len;
5007     SV *tmpstr;
5008     char term;
5009     register char *d;
5010     register char *e;
5011     char *peek;
5012     int outer = (rsfp && !(lex_inwhat == OP_SCALAR));
5013
5014     s += 2;
5015     d = tokenbuf;
5016     e = tokenbuf + sizeof tokenbuf - 1;
5017     if (!outer)
5018         *d++ = '\n';
5019     for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5020     if (*peek && strchr("`'\"",*peek)) {
5021         s = peek;
5022         term = *s++;
5023         s = delimcpy(d, e, s, bufend, term, &len);
5024         d += len;
5025         if (s < bufend)
5026             s++;
5027     }
5028     else {
5029         if (*s == '\\')
5030             s++, term = '\'';
5031         else
5032             term = '"';
5033         if (!isALNUM(*s))
5034             deprecate("bare << to mean <<\"\"");
5035         for (; isALNUM(*s); s++) {
5036             if (d < e)
5037                 *d++ = *s;
5038         }
5039     }
5040     if (d >= tokenbuf + sizeof tokenbuf - 1)
5041         croak("Delimiter for here document is too long");
5042     *d++ = '\n';
5043     *d = '\0';
5044     len = d - tokenbuf;
5045     d = "\n";
5046     if (outer || !(d=ninstr(s,bufend,d,d+1)))
5047         herewas = newSVpv(s,bufend-s);
5048     else
5049         s--, herewas = newSVpv(s,d-s);
5050     s += SvCUR(herewas);
5051
5052     tmpstr = NEWSV(87,79);
5053     sv_upgrade(tmpstr, SVt_PVIV);
5054     if (term == '\'') {
5055         op_type = OP_CONST;
5056         SvIVX(tmpstr) = -1;
5057     }
5058     else if (term == '`') {
5059         op_type = OP_BACKTICK;
5060         SvIVX(tmpstr) = '\\';
5061     }
5062
5063     CLINE;
5064     multi_start = curcop->cop_line;
5065     multi_open = multi_close = '<';
5066     term = *tokenbuf;
5067     if (!outer) {
5068         d = s;
5069         while (s < bufend &&
5070           (*s != term || memNE(s,tokenbuf,len)) ) {
5071             if (*s++ == '\n')
5072                 curcop->cop_line++;
5073         }
5074         if (s >= bufend) {
5075             curcop->cop_line = multi_start;
5076             missingterm(tokenbuf);
5077         }
5078         sv_setpvn(tmpstr,d+1,s-d);
5079         s += len - 1;
5080         curcop->cop_line++;     /* the preceding stmt passes a newline */
5081
5082         sv_catpvn(herewas,s,bufend-s);
5083         sv_setsv(linestr,herewas);
5084         oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
5085         bufend = SvPVX(linestr) + SvCUR(linestr);
5086     }
5087     else
5088         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
5089     while (s >= bufend) {       /* multiple line string? */
5090         if (!outer ||
5091          !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5092             curcop->cop_line = multi_start;
5093             missingterm(tokenbuf);
5094         }
5095         curcop->cop_line++;
5096         if (PERLDB_LINE && curstash != debstash) {
5097             SV *sv = NEWSV(88,0);
5098
5099             sv_upgrade(sv, SVt_PVMG);
5100             sv_setsv(sv,linestr);
5101             av_store(GvAV(curcop->cop_filegv),
5102               (I32)curcop->cop_line,sv);
5103         }
5104         bufend = SvPVX(linestr) + SvCUR(linestr);
5105         if (*s == term && memEQ(s,tokenbuf,len)) {
5106             s = bufend - 1;
5107             *s = ' ';
5108             sv_catsv(linestr,herewas);
5109             bufend = SvPVX(linestr) + SvCUR(linestr);
5110         }
5111         else {
5112             s = bufend;
5113             sv_catsv(tmpstr,linestr);
5114         }
5115     }
5116     multi_end = curcop->cop_line;
5117     s++;
5118     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5119         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5120         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5121     }
5122     SvREFCNT_dec(herewas);
5123     lex_stuff = tmpstr;
5124     yylval.ival = op_type;
5125     return s;
5126 }
5127
5128 /* scan_inputsymbol
5129    takes: current position in input buffer
5130    returns: new position in input buffer
5131    side-effects: yylval and lex_op are set.
5132
5133    This code handles:
5134
5135    <>           read from ARGV
5136    <FH>         read from filehandle
5137    <pkg::FH>    read from package qualified filehandle
5138    <pkg'FH>     read from package qualified filehandle
5139    <$fh>        read from filehandle in $fh
5140    <*.h>        filename glob
5141
5142 */
5143
5144 STATIC char *
5145 scan_inputsymbol(char *start)
5146 {
5147     register char *s = start;           /* current position in buffer */
5148     register char *d;
5149     register char *e;
5150     I32 len;
5151
5152     d = tokenbuf;                       /* start of temp holding space */
5153     e = tokenbuf + sizeof tokenbuf;     /* end of temp holding space */
5154     s = delimcpy(d, e, s + 1, bufend, '>', &len);       /* extract until > */
5155
5156     /* die if we didn't have space for the contents of the <>,
5157        or if it didn't end
5158     */
5159
5160     if (len >= sizeof tokenbuf)
5161         croak("Excessively long <> operator");
5162     if (s >= bufend)
5163         croak("Unterminated <> operator");
5164
5165     s++;
5166
5167     /* check for <$fh>
5168        Remember, only scalar variables are interpreted as filehandles by
5169        this code.  Anything more complex (e.g., <$fh{$num}>) will be
5170        treated as a glob() call.
5171        This code makes use of the fact that except for the $ at the front,
5172        a scalar variable and a filehandle look the same.
5173     */
5174     if (*d == '$' && d[1]) d++;
5175
5176     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5177     while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5178         d++;
5179
5180     /* If we've tried to read what we allow filehandles to look like, and
5181        there's still text left, then it must be a glob() and not a getline.
5182        Use scan_str to pull out the stuff between the <> and treat it
5183        as nothing more than a string.
5184     */
5185
5186     if (d - tokenbuf != len) {
5187         yylval.ival = OP_GLOB;
5188         set_csh();
5189         s = scan_str(start);
5190         if (!s)
5191            croak("Glob not terminated");
5192         return s;
5193     }
5194     else {
5195         /* we're in a filehandle read situation */
5196         d = tokenbuf;
5197
5198         /* turn <> into <ARGV> */
5199         if (!len)
5200             (void)strcpy(d,"ARGV");
5201
5202         /* if <$fh>, create the ops to turn the variable into a
5203            filehandle
5204         */
5205         if (*d == '$') {
5206             I32 tmp;
5207
5208             /* try to find it in the pad for this block, otherwise find
5209                add symbol table ops
5210             */
5211             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5212                 OP *o = newOP(OP_PADSV, 0);
5213                 o->op_targ = tmp;
5214                 lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5215             }
5216             else {
5217                 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5218                 lex_op = (OP*)newUNOP(OP_READLINE, 0,
5219                                         newUNOP(OP_RV2GV, 0,
5220                                             newUNOP(OP_RV2SV, 0,
5221                                                 newGVOP(OP_GV, 0, gv))));
5222             }
5223             /* we created the ops in lex_op, so make yylval.ival a null op */
5224             yylval.ival = OP_NULL;
5225         }
5226
5227         /* If it's none of the above, it must be a literal filehandle
5228            (<Foo::BAR> or <FOO>) so build a simple readline OP */
5229         else {
5230             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5231             lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5232             yylval.ival = OP_NULL;
5233         }
5234     }
5235
5236     return s;
5237 }
5238
5239
5240 /* scan_str
5241    takes: start position in buffer
5242    returns: position to continue reading from buffer
5243    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5244         updates the read buffer.
5245
5246    This subroutine pulls a string out of the input.  It is called for:
5247         q               single quotes           q(literal text)
5248         '               single quotes           'literal text'
5249         qq              double quotes           qq(interpolate $here please)
5250         "               double quotes           "interpolate $here please"
5251         qx              backticks               qx(/bin/ls -l)
5252         `               backticks               `/bin/ls -l`
5253         qw              quote words             @EXPORT_OK = qw( func() $spam )
5254         m//             regexp match            m/this/
5255         s///            regexp substitute       s/this/that/
5256         tr///           string transliterate    tr/this/that/
5257         y///            string transliterate    y/this/that/
5258         ($*@)           sub prototypes          sub foo ($)
5259         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
5260
5261    In most of these cases (all but <>, patterns and transliterate)
5262    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
5263    calls scan_str().  s/// makes yylex() call scan_subst() which calls
5264    scan_str().  tr/// and y/// make yylex() call scan_trans() which
5265    calls scan_str().
5266
5267    It skips whitespace before the string starts, and treats the first
5268    character as the delimiter.  If the delimiter is one of ([{< then
5269    the corresponding "close" character )]}> is used as the closing
5270    delimiter.  It allows quoting of delimiters, and if the string has
5271    balanced delimiters ([{<>}]) it allows nesting.
5272
5273    The lexer always reads these strings into lex_stuff, except in the
5274    case of the operators which take *two* arguments (s/// and tr///)
5275    when it checks to see if lex_stuff is full (presumably with the 1st
5276    arg to s or tr) and if so puts the string into lex_repl.
5277
5278 */
5279
5280 STATIC char *
5281 scan_str(char *start)
5282 {
5283     dTHR;
5284     SV *sv;                             /* scalar value: string */
5285     char *tmps;                         /* temp string, used for delimiter matching */
5286     register char *s = start;           /* current position in the buffer */
5287     register char term;                 /* terminating character */
5288     register char *to;                  /* current position in the sv's data */
5289     I32 brackets = 1;                   /* bracket nesting level */
5290
5291     /* skip space before the delimiter */
5292     if (isSPACE(*s))
5293         s = skipspace(s);
5294
5295     /* mark where we are, in case we need to report errors */
5296     CLINE;
5297
5298     /* after skipping whitespace, the next character is the terminator */
5299     term = *s;
5300     /* mark where we are */
5301     multi_start = curcop->cop_line;
5302     multi_open = term;
5303
5304     /* find corresponding closing delimiter */
5305     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5306         term = tmps[5];
5307     multi_close = term;
5308
5309     /* create a new SV to hold the contents.  87 is leak category, I'm
5310        assuming.  79 is the SV's initial length.  What a random number. */
5311     sv = NEWSV(87,79);
5312     sv_upgrade(sv, SVt_PVIV);
5313     SvIVX(sv) = term;
5314     (void)SvPOK_only(sv);               /* validate pointer */
5315
5316     /* move past delimiter and try to read a complete string */
5317     s++;
5318     for (;;) {
5319         /* extend sv if need be */
5320         SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
5321         /* set 'to' to the next character in the sv's string */
5322         to = SvPVX(sv)+SvCUR(sv);
5323
5324         /* if open delimiter is the close delimiter read unbridle */
5325         if (multi_open == multi_close) {
5326             for (; s < bufend; s++,to++) {
5327                 /* embedded newlines increment the current line number */
5328                 if (*s == '\n' && !rsfp)
5329                     curcop->cop_line++;
5330                 /* handle quoted delimiters */
5331                 if (*s == '\\' && s+1 < bufend && term != '\\') {
5332                     if (s[1] == term)
5333                         s++;
5334                 /* any other quotes are simply copied straight through */
5335                     else
5336                         *to++ = *s++;
5337                 }
5338                 /* terminate when run out of buffer (the for() condition), or
5339                    have found the terminator */
5340                 else if (*s == term)
5341                     break;
5342                 *to = *s;
5343             }
5344         }
5345
5346         /* if the terminator isn't the same as the start character (e.g.,
5347            matched brackets), we have to allow more in the quoting, and
5348            be prepared for nested brackets.
5349         */
5350         else {
5351             /* read until we run out of string, or we find the terminator */
5352             for (; s < bufend; s++,to++) {
5353                 /* embedded newlines increment the line count */
5354                 if (*s == '\n' && !rsfp)
5355                     curcop->cop_line++;
5356                 /* backslashes can escape the open or closing characters */
5357                 if (*s == '\\' && s+1 < bufend) {
5358                     if ((s[1] == multi_open) || (s[1] == multi_close))
5359                         s++;
5360                     else
5361                         *to++ = *s++;
5362                 }
5363                 /* allow nested opens and closes */
5364                 else if (*s == multi_close && --brackets <= 0)
5365                     break;
5366                 else if (*s == multi_open)
5367                     brackets++;
5368                 *to = *s;
5369             }
5370         }
5371         /* terminate the copied string and update the sv's end-of-string */
5372         *to = '\0';
5373         SvCUR_set(sv, to - SvPVX(sv));
5374
5375         /*
5376          * this next chunk reads more into the buffer if we're not done yet
5377          */
5378
5379         if (s < bufend) break;  /* handle case where we are done yet :-) */
5380
5381         /* if we're out of file, or a read fails, bail and reset the current
5382            line marker so we can report where the unterminated string began
5383         */
5384         if (!rsfp ||
5385          !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
5386             sv_free(sv);
5387             curcop->cop_line = multi_start;
5388             return Nullch;
5389         }
5390         /* we read a line, so increment our line counter */
5391         curcop->cop_line++;
5392
5393         /* update debugger info */
5394         if (PERLDB_LINE && curstash != debstash) {
5395             SV *sv = NEWSV(88,0);
5396
5397             sv_upgrade(sv, SVt_PVMG);
5398             sv_setsv(sv,linestr);
5399             av_store(GvAV(curcop->cop_filegv),
5400               (I32)curcop->cop_line, sv);
5401         }
5402
5403         /* having changed the buffer, we must update bufend */
5404         bufend = SvPVX(linestr) + SvCUR(linestr);
5405     }
5406
5407     /* at this point, we have successfully read the delimited string */
5408
5409     multi_end = curcop->cop_line;
5410     s++;
5411
5412     /* if we allocated too much space, give some back */
5413     if (SvCUR(sv) + 5 < SvLEN(sv)) {
5414         SvLEN_set(sv, SvCUR(sv) + 1);
5415         Renew(SvPVX(sv), SvLEN(sv), char);
5416     }
5417
5418     /* decide whether this is the first or second quoted string we've read
5419        for this op
5420     */
5421
5422     if (lex_stuff)
5423         lex_repl = sv;
5424     else
5425         lex_stuff = sv;
5426     return s;
5427 }
5428
5429 /*
5430   scan_num
5431   takes: pointer to position in buffer
5432   returns: pointer to new position in buffer
5433   side-effects: builds ops for the constant in yylval.op
5434
5435   Read a number in any of the formats that Perl accepts:
5436
5437   0(x[0-7A-F]+)|([0-7]+)
5438   [\d_]+(\.[\d_]*)?[Ee](\d+)
5439
5440   Underbars (_) are allowed in decimal numbers.  If -w is on,
5441   underbars before a decimal point must be at three digit intervals.
5442
5443   Like most scan_ routines, it uses the tokenbuf buffer to hold the
5444   thing it reads.
5445
5446   If it reads a number without a decimal point or an exponent, it will
5447   try converting the number to an integer and see if it can do so
5448   without loss of precision.
5449 */
5450
5451 char *
5452 scan_num(char *start)
5453 {
5454     register char *s = start;           /* current position in buffer */
5455     register char *d;                   /* destination in temp buffer */
5456     register char *e;                   /* end of temp buffer */
5457     I32 tryiv;                          /* used to see if it can be an int */
5458     double value;                       /* number read, as a double */
5459     SV *sv;                             /* place to put the converted number */
5460     I32 floatit;                        /* boolean: int or float? */
5461     char *lastub = 0;                   /* position of last underbar */
5462     static char number_too_long[] = "Number too long";
5463
5464     /* We use the first character to decide what type of number this is */
5465
5466     switch (*s) {
5467     default:
5468       croak("panic: scan_num");
5469
5470     /* if it starts with a 0, it could be an octal number, a decimal in
5471        0.13 disguise, or a hexadecimal number.
5472     */
5473     case '0':
5474         {
5475           /* variables:
5476              u          holds the "number so far"
5477              shift      the power of 2 of the base (hex == 4, octal == 3)
5478              overflowed was the number more than we can hold?
5479
5480              Shift is used when we add a digit.  It also serves as an "are
5481              we in octal or hex?" indicator to disallow hex characters when
5482              in octal mode.
5483            */
5484             UV u;
5485             I32 shift;
5486             bool overflowed = FALSE;
5487
5488             /* check for hex */
5489             if (s[1] == 'x') {
5490                 shift = 4;
5491                 s += 2;
5492             }
5493             /* check for a decimal in disguise */
5494             else if (s[1] == '.')
5495                 goto decimal;
5496             /* so it must be octal */
5497             else
5498                 shift = 3;
5499             u = 0;
5500
5501             /* read the rest of the octal number */
5502             for (;;) {
5503                 UV n, b;        /* n is used in the overflow test, b is the digit we're adding on */
5504
5505                 switch (*s) {
5506
5507                 /* if we don't mention it, we're done */
5508                 default:
5509                     goto out;
5510
5511                 /* _ are ignored */
5512                 case '_':
5513                     s++;
5514                     break;
5515
5516                 /* 8 and 9 are not octal */
5517                 case '8': case '9':
5518                     if (shift != 4)
5519                         yyerror("Illegal octal digit");
5520                     /* FALL THROUGH */
5521
5522                 /* octal digits */
5523                 case '0': case '1': case '2': case '3': case '4':
5524                 case '5': case '6': case '7':
5525                     b = *s++ & 15;              /* ASCII digit -> value of digit */
5526                     goto digit;
5527
5528                 /* hex digits */
5529                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5530                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5531                     /* make sure they said 0x */
5532                     if (shift != 4)
5533                         goto out;
5534                     b = (*s++ & 7) + 9;
5535
5536                     /* Prepare to put the digit we have onto the end
5537                        of the number so far.  We check for overflows.
5538                     */
5539
5540                   digit:
5541                     n = u << shift;     /* make room for the digit */
5542                     if (!overflowed && (n >> shift) != u) {
5543                         warn("Integer overflow in %s number",
5544                              (shift == 4) ? "hex" : "octal");
5545                         overflowed = TRUE;
5546                     }
5547                     u = n | b;          /* add the digit to the end */
5548                     break;
5549                 }
5550             }
5551
5552           /* if we get here, we had success: make a scalar value from
5553              the number.
5554           */
5555           out:
5556             sv = NEWSV(92,0);
5557             sv_setuv(sv, u);
5558         }
5559         break;
5560
5561     /*
5562       handle decimal numbers.
5563       we're also sent here when we read a 0 as the first digit
5564     */
5565     case '1': case '2': case '3': case '4': case '5':
5566     case '6': case '7': case '8': case '9': case '.':
5567       decimal:
5568         d = tokenbuf;
5569         e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
5570         floatit = FALSE;
5571
5572         /* read next group of digits and _ and copy into d */
5573         while (isDIGIT(*s) || *s == '_') {
5574             /* skip underscores, checking for misplaced ones
5575                if -w is on
5576             */
5577             if (*s == '_') {
5578                 if (dowarn && lastub && s - lastub != 3)
5579                     warn("Misplaced _ in number");
5580                 lastub = ++s;
5581             }
5582             else {
5583                 /* check for end of fixed-length buffer */
5584                 if (d >= e)
5585                     croak(number_too_long);
5586                 /* if we're ok, copy the character */
5587                 *d++ = *s++;
5588             }
5589         }
5590
5591         /* final misplaced underbar check */
5592         if (dowarn && lastub && s - lastub != 3)
5593             warn("Misplaced _ in number");
5594
5595         /* read a decimal portion if there is one.  avoid
5596            3..5 being interpreted as the number 3. followed
5597            by .5
5598         */
5599         if (*s == '.' && s[1] != '.') {
5600             floatit = TRUE;
5601             *d++ = *s++;
5602
5603             /* copy, ignoring underbars, until we run out of
5604                digits.  Note: no misplaced underbar checks!
5605             */
5606             for (; isDIGIT(*s) || *s == '_'; s++) {
5607                 /* fixed length buffer check */
5608                 if (d >= e)
5609                     croak(number_too_long);
5610                 if (*s != '_')
5611                     *d++ = *s;
5612             }
5613         }
5614
5615         /* read exponent part, if present */
5616         if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5617             floatit = TRUE;
5618             s++;
5619
5620             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5621             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
5622
5623             /* allow positive or negative exponent */
5624             if (*s == '+' || *s == '-')
5625                 *d++ = *s++;
5626
5627             /* read digits of exponent (no underbars :-) */
5628             while (isDIGIT(*s)) {
5629                 if (d >= e)
5630                     croak(number_too_long);
5631                 *d++ = *s++;
5632             }
5633         }
5634
5635         /* terminate the string */
5636         *d = '\0';
5637
5638         /* make an sv from the string */
5639         sv = NEWSV(92,0);
5640         /* reset numeric locale in case we were earlier left in Swaziland */
5641         SET_NUMERIC_STANDARD();
5642         value = atof(tokenbuf);
5643
5644         /*
5645            See if we can make do with an integer value without loss of
5646            precision.  We use I_V to cast to an int, because some
5647            compilers have issues.  Then we try casting it back and see
5648            if it was the same.  We only do this if we know we
5649            specifically read an integer.
5650
5651            Note: if floatit is true, then we don't need to do the
5652            conversion at all.
5653         */
5654         tryiv = I_V(value);
5655         if (!floatit && (double)tryiv == value)
5656             sv_setiv(sv, tryiv);
5657         else
5658             sv_setnv(sv, value);
5659         break;
5660     }
5661
5662     /* make the op for the constant and return */
5663
5664     yylval.opval = newSVOP(OP_CONST, 0, sv);
5665
5666     return s;
5667 }
5668
5669 STATIC char *
5670 scan_formline(register char *s)
5671 {
5672     dTHR;
5673     register char *eol;
5674     register char *t;
5675     SV *stuff = newSVpv("",0);
5676     bool needargs = FALSE;
5677
5678     while (!needargs) {
5679         if (*s == '.' || *s == '}') {
5680             /*SUPPRESS 530*/
5681             for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
5682             if (*t == '\n')
5683                 break;
5684         }
5685         if (in_eval && !rsfp) {
5686             eol = strchr(s,'\n');
5687             if (!eol++)
5688                 eol = bufend;
5689         }
5690         else
5691             eol = bufend = SvPVX(linestr) + SvCUR(linestr);
5692         if (*s != '#') {
5693             for (t = s; t < eol; t++) {
5694                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
5695                     needargs = FALSE;
5696                     goto enough;        /* ~~ must be first line in formline */
5697                 }
5698                 if (*t == '@' || *t == '^')
5699                     needargs = TRUE;
5700             }
5701             sv_catpvn(stuff, s, eol-s);
5702         }
5703         s = eol;
5704         if (rsfp) {
5705             s = filter_gets(linestr, rsfp, 0);
5706             oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
5707             bufend = bufptr + SvCUR(linestr);
5708             if (!s) {
5709                 s = bufptr;
5710                 yyerror("Format not terminated");
5711                 break;
5712             }
5713         }
5714         incline(s);
5715     }
5716   enough:
5717     if (SvCUR(stuff)) {
5718         expect = XTERM;
5719         if (needargs) {
5720             lex_state = LEX_NORMAL;
5721             nextval[nexttoke].ival = 0;
5722             force_next(',');
5723         }
5724         else
5725             lex_state = LEX_FORMLINE;
5726         nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
5727         force_next(THING);
5728         nextval[nexttoke].ival = OP_FORMLINE;
5729         force_next(LSTOP);
5730     }
5731     else {
5732         SvREFCNT_dec(stuff);
5733         lex_formbrack = 0;
5734         bufptr = s;
5735     }
5736     return s;
5737 }
5738
5739 STATIC void
5740 set_csh(void)
5741 {
5742 #ifdef CSH
5743     if (!cshlen)
5744         cshlen = strlen(cshname);
5745 #endif
5746 }
5747
5748 I32
5749 start_subparse(I32 is_format, U32 flags)
5750 {
5751     dTHR;
5752     I32 oldsavestack_ix = savestack_ix;
5753     CV* outsidecv = compcv;
5754     AV* comppadlist;
5755
5756     if (compcv) {
5757         assert(SvTYPE(compcv) == SVt_PVCV);
5758     }
5759     save_I32(&subline);
5760     save_item(subname);
5761     SAVEI32(padix);
5762     SAVESPTR(curpad);
5763     SAVESPTR(comppad);
5764     SAVESPTR(comppad_name);
5765     SAVESPTR(compcv);
5766     SAVEI32(comppad_name_fill);
5767     SAVEI32(min_intro_pending);
5768     SAVEI32(max_intro_pending);
5769     SAVEI32(pad_reset_pending);
5770
5771     compcv = (CV*)NEWSV(1104,0);
5772     sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
5773     CvFLAGS(compcv) |= flags;
5774
5775     comppad = newAV();
5776     av_push(comppad, Nullsv);
5777     curpad = AvARRAY(comppad);
5778     comppad_name = newAV();
5779     comppad_name_fill = 0;
5780     min_intro_pending = 0;
5781     padix = 0;
5782     subline = curcop->cop_line;
5783 #ifdef USE_THREADS
5784     av_store(comppad_name, 0, newSVpv("@_", 2));
5785     curpad[0] = (SV*)newAV();
5786     SvPADMY_on(curpad[0]);      /* XXX Needed? */
5787     CvOWNER(compcv) = 0;
5788     New(666, CvMUTEXP(compcv), 1, perl_mutex);
5789     MUTEX_INIT(CvMUTEXP(compcv));
5790 #endif /* USE_THREADS */
5791
5792     comppadlist = newAV();
5793     AvREAL_off(comppadlist);
5794     av_store(comppadlist, 0, (SV*)comppad_name);
5795     av_store(comppadlist, 1, (SV*)comppad);
5796
5797     CvPADLIST(compcv) = comppadlist;
5798     CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
5799 #ifdef USE_THREADS
5800     CvOWNER(compcv) = 0;
5801     New(666, CvMUTEXP(compcv), 1, perl_mutex);
5802     MUTEX_INIT(CvMUTEXP(compcv));
5803 #endif /* USE_THREADS */
5804
5805     return oldsavestack_ix;
5806 }
5807
5808 int
5809 yywarn(char *s)
5810 {
5811     dTHR;
5812     --error_count;
5813     in_eval |= 2;
5814     yyerror(s);
5815     in_eval &= ~2;
5816     return 0;
5817 }
5818
5819 int
5820 yyerror(char *s)
5821 {
5822     dTHR;
5823     char *where = NULL;
5824     char *context = NULL;
5825     int contlen = -1;
5826     SV *msg;
5827
5828     if (!yychar || (yychar == ';' && !rsfp))
5829         where = "at EOF";
5830     else if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
5831       oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
5832         while (isSPACE(*oldoldbufptr))
5833             oldoldbufptr++;
5834         context = oldoldbufptr;
5835         contlen = bufptr - oldoldbufptr;
5836     }
5837     else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
5838       oldbufptr != bufptr) {
5839         while (isSPACE(*oldbufptr))
5840             oldbufptr++;
5841         context = oldbufptr;
5842         contlen = bufptr - oldbufptr;
5843     }
5844     else if (yychar > 255)
5845         where = "next token ???";
5846     else if ((yychar & 127) == 127) {
5847         if (lex_state == LEX_NORMAL ||
5848            (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
5849             where = "at end of line";
5850         else if (lex_inpat)
5851             where = "within pattern";
5852         else
5853             where = "within string";
5854     }
5855     else {
5856         SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
5857         if (yychar < 32)
5858             sv_catpvf(where_sv, "^%c", toCTRL(yychar));
5859         else if (isPRINT_LC(yychar))
5860             sv_catpvf(where_sv, "%c", yychar);
5861         else
5862             sv_catpvf(where_sv, "\\%03o", yychar & 255);
5863         where = SvPVX(where_sv);
5864     }
5865     msg = sv_2mortal(newSVpv(s, 0));
5866     sv_catpvf(msg, " at %_ line %ld, ",
5867               GvSV(curcop->cop_filegv), (long)curcop->cop_line);
5868     if (context)
5869         sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
5870     else
5871         sv_catpvf(msg, "%s\n", where);
5872     if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
5873         sv_catpvf(msg,
5874         "  (Might be a runaway multi-line %c%c string starting on line %ld)\n",
5875                 (int)multi_open,(int)multi_close,(long)multi_start);
5876         multi_end = 0;
5877     }
5878     if (in_eval & 2)
5879         warn("%_", msg);
5880     else if (in_eval)
5881         sv_catsv(ERRSV, msg);
5882     else
5883         PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
5884     if (++error_count >= 10)
5885         croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
5886     in_my = 0;
5887     in_my_stash = Nullhv;
5888     return 0;
5889 }
5890
5891