toke.c

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