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