toke.c

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