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