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