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