toke.c

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