toke.c

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