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