toke.c

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