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