toke.c

   1 /*    toke.c
   2  *
   3  *    Copyright (c) 1991-2001, 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 /*
  15  * This file is the lexer for Perl.  It's closely linked to the
  16  * parser, perly.y.
  17  *
  18  * The main routine is yylex(), which returns the next token.
  19  */
  20
  21 #include "EXTERN.h"
  22 #define PERL_IN_TOKE_C
  23 #include "perl.h"
  24
  25 #define yychar  PL_yychar
  26 #define yylval  PL_yylval
  27
  28 static char ident_too_long[] = "Identifier too long";
  29
  30 static void restore_rsfp(pTHX_ void *f);
  31 #ifndef PERL_NO_UTF16_FILTER
  32 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
  33 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
  34 #endif
  35
  36 #define XFAKEBRACK 128
  37 #define XENUMMASK 127
  38
  39 #ifdef USE_UTF8_SCRIPTS
  40 #   define UTF (!IN_BYTES)
  41 #else
  42 #   ifdef EBCDIC /* For now 'use utf8' does not affect tokenizer on EBCDIC */
  43 #       define UTF (PL_linestr && DO_UTF8(PL_linestr))
  44 #   else
  45 #       define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
  46 #   endif
  47 #endif
  48
  49 /* In variables named $^X, these are the legal values for X.
  50  * 1999-02-27 mjd-perl-patch@plover.com */
  51 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
  52
  53 /* On MacOS, respect nonbreaking spaces */
  54 #ifdef MACOS_TRADITIONAL
  55 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
  56 #else
  57 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
  58 #endif
  59
  60 /* LEX_* are values for PL_lex_state, the state of the lexer.
  61  * They are arranged oddly so that the guard on the switch statement
  62  * can get by with a single comparison (if the compiler is smart enough).
  63  */
  64
  65 /* #define LEX_NOTPARSING               11 is done in perl.h. */
  66
  67 #define LEX_NORMAL              10
  68 #define LEX_INTERPNORMAL         9
  69 #define LEX_INTERPCASEMOD        8
  70 #define LEX_INTERPPUSH           7
  71 #define LEX_INTERPSTART          6
  72 #define LEX_INTERPEND            5
  73 #define LEX_INTERPENDMAYBE       4
  74 #define LEX_INTERPCONCAT         3
  75 #define LEX_INTERPCONST          2
  76 #define LEX_FORMLINE             1
  77 #define LEX_KNOWNEXT             0
  78
  79 #ifdef ff_next
  80 #undef ff_next
  81 #endif
  82
  83 #ifdef USE_PURE_BISON
  84 #  ifndef YYMAXLEVEL
  85 #    define YYMAXLEVEL 100
  86 #  endif
  87 YYSTYPE* yylval_pointer[YYMAXLEVEL];
  88 int* yychar_pointer[YYMAXLEVEL];
  89 int yyactlevel = -1;
  90 #  undef yylval
  91 #  undef yychar
  92 #  define yylval (*yylval_pointer[yyactlevel])
  93 #  define yychar (*yychar_pointer[yyactlevel])
  94 #  define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
  95 #  undef yylex
  96 #  define yylex()      Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
  97 #endif
  98
  99 #include "keywords.h"
 100
 101 /* CLINE is a macro that ensures PL_copline has a sane value */
 102
 103 #ifdef CLINE
 104 #undef CLINE
 105 #endif
 106 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
 107
 108 /*
 109  * Convenience functions to return different tokens and prime the
 110  * lexer for the next token.  They all take an argument.
 111  *
 112  * TOKEN        : generic token (used for '(', DOLSHARP, etc)
 113  * OPERATOR     : generic operator
 114  * AOPERATOR    : assignment operator
 115  * PREBLOCK     : beginning the block after an if, while, foreach, ...
 116  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
 117  * PREREF       : *EXPR where EXPR is not a simple identifier
 118  * TERM         : expression term
 119  * LOOPX        : loop exiting command (goto, last, dump, etc)
 120  * FTST         : file test operator
 121  * FUN0         : zero-argument function
 122  * FUN1         : not used, except for not, which isn't a UNIOP
 123  * BOop         : bitwise or or xor
 124  * BAop         : bitwise and
 125  * SHop         : shift operator
 126  * PWop         : power operator
 127  * PMop         : pattern-matching operator
 128  * Aop          : addition-level operator
 129  * Mop          : multiplication-level operator
 130  * Eop          : equality-testing operator
 131  * Rop          : relational operator <= != gt
 132  *
 133  * Also see LOP and lop() below.
 134  */
 135
 136 /* Note that REPORT() and REPORT2() will be expressions that supply
 137  * their own trailing comma, not suitable for statements as such. */
 138 #ifdef DEBUGGING /* Serve -DT. */
 139 #   define REPORT(x,retval) tokereport(x,s,(int)retval),
 140 #   define REPORT2(x,retval) tokereport(x,s, yylval.ival),
 141 #else
 142 #   define REPORT(x,retval)
 143 #   define REPORT2(x,retval)
 144 #endif
 145
 146 #define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
 147 #define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
 148 #define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
 149 #define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
 150 #define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
 151 #define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
 152 #define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
 153 #define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
 154 #define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
 155 #define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
 156 #define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
 157 #define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
 158 #define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
 159 #define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
 160 #define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
 161 #define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
 162 #define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
 163 #define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
 164 #define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
 165 #define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
 166
 167 /* This bit of chicanery makes a unary function followed by
 168  * a parenthesis into a function with one argument, highest precedence.
 169  */
 170 #define UNI(f) return(yylval.ival = f, \
 171         REPORT("uni",f) \
 172         PL_expect = XTERM, \
 173         PL_bufptr = s, \
 174         PL_last_uni = PL_oldbufptr, \
 175         PL_last_lop_op = f, \
 176         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 177
 178 #define UNIBRACK(f) return(yylval.ival = f, \
 179         REPORT("uni",f) \
 180         PL_bufptr = s, \
 181         PL_last_uni = PL_oldbufptr, \
 182         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 183
 184 /* grandfather return to old style */
 185 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
 186
 187 #ifdef DEBUGGING
 188
 189 STATIC void
 190 S_tokereport(pTHX_ char *thing, char* s, I32 rv)
 191 {
 192     DEBUG_T({
 193         SV* report = newSVpv(thing, 0);
 194         Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
 195                 (IV)rv);
 196
 197         if (s - PL_bufptr > 0)
 198             sv_catpvn(report, PL_bufptr, s - PL_bufptr);
 199         else {
 200             if (PL_oldbufptr && *PL_oldbufptr)
 201                 sv_catpv(report, PL_tokenbuf);
 202         }
 203         PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
 204     });
 205 }
 206
 207 #endif
 208
 209 /*
 210  * S_ao
 211  *
 212  * This subroutine detects &&= and ||= and turns an ANDAND or OROR
 213  * into an OP_ANDASSIGN or OP_ORASSIGN
 214  */
 215
 216 STATIC int
 217 S_ao(pTHX_ int toketype)
 218 {
 219     if (*PL_bufptr == '=') {
 220         PL_bufptr++;
 221         if (toketype == ANDAND)
 222             yylval.ival = OP_ANDASSIGN;
 223         else if (toketype == OROR)
 224             yylval.ival = OP_ORASSIGN;
 225         toketype = ASSIGNOP;
 226     }
 227     return toketype;
 228 }
 229
 230 /*
 231  * S_no_op
 232  * When Perl expects an operator and finds something else, no_op
 233  * prints the warning.  It always prints "<something> found where
 234  * operator expected.  It prints "Missing semicolon on previous line?"
 235  * if the surprise occurs at the start of the line.  "do you need to
 236  * predeclare ..." is printed out for code like "sub bar; foo bar $x"
 237  * where the compiler doesn't know if foo is a method call or a function.
 238  * It prints "Missing operator before end of line" if there's nothing
 239  * after the missing operator, or "... before <...>" if there is something
 240  * after the missing operator.
 241  */
 242
 243 STATIC void
 244 S_no_op(pTHX_ char *what, char *s)
 245 {
 246     char *oldbp = PL_bufptr;
 247     bool is_first = (PL_oldbufptr == PL_linestart);
 248
 249     if (!s)
 250         s = oldbp;
 251     else
 252         PL_bufptr = s;
 253     yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
 254     if (is_first)
 255         Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
 256     else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
 257         char *t;
 258         for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
 259         if (t < PL_bufptr && isSPACE(*t))
 260             Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
 261                 t - PL_oldoldbufptr, PL_oldoldbufptr);
 262     }
 263     else {
 264         assert(s >= oldbp);
 265         Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
 266     }
 267     PL_bufptr = oldbp;
 268 }
 269
 270 /*
 271  * S_missingterm
 272  * Complain about missing quote/regexp/heredoc terminator.
 273  * If it's called with (char *)NULL then it cauterizes the line buffer.
 274  * If we're in a delimited string and the delimiter is a control
 275  * character, it's reformatted into a two-char sequence like ^C.
 276  * This is fatal.
 277  */
 278
 279 STATIC void
 280 S_missingterm(pTHX_ char *s)
 281 {
 282     char tmpbuf[3];
 283     char q;
 284     if (s) {
 285         char *nl = strrchr(s,'\n');
 286         if (nl)
 287             *nl = '\0';
 288     }
 289     else if (
 290 #ifdef EBCDIC
 291         iscntrl(PL_multi_close)
 292 #else
 293         PL_multi_close < 32 || PL_multi_close == 127
 294 #endif
 295         ) {
 296         *tmpbuf = '^';
 297         tmpbuf[1] = toCTRL(PL_multi_close);
 298         s = "\\n";
 299         tmpbuf[2] = '\0';
 300         s = tmpbuf;
 301     }
 302     else {
 303         *tmpbuf = PL_multi_close;
 304         tmpbuf[1] = '\0';
 305         s = tmpbuf;
 306     }
 307     q = strchr(s,'"') ? '\'' : '"';
 308     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
 309 }
 310
 311 /*
 312  * Perl_deprecate
 313  */
 314
 315 void
 316 Perl_deprecate(pTHX_ char *s)
 317 {
 318     if (ckWARN(WARN_DEPRECATED))
 319         Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
 320 }
 321
 322 /*
 323  * depcom
 324  * Deprecate a comma-less variable list.
 325  */
 326
 327 STATIC void
 328 S_depcom(pTHX)
 329 {
 330     deprecate("comma-less variable list");
 331 }
 332
 333 /*
 334  * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
 335  * utf16-to-utf8-reversed.
 336  */
 337
 338 #ifdef PERL_CR_FILTER
 339 static void
 340 strip_return(SV *sv)
 341 {
 342     register char *s = SvPVX(sv);
 343     register char *e = s + SvCUR(sv);
 344     /* outer loop optimized to do nothing if there are no CR-LFs */
 345     while (s < e) {
 346         if (*s++ == '\r' && *s == '\n') {
 347             /* hit a CR-LF, need to copy the rest */
 348             register char *d = s - 1;
 349             *d++ = *s++;
 350             while (s < e) {
 351                 if (*s == '\r' && s[1] == '\n')
 352                     s++;
 353                 *d++ = *s++;
 354             }
 355             SvCUR(sv) -= s - d;
 356             return;
 357         }
 358     }
 359 }
 360
 361 STATIC I32
 362 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 363 {
 364     I32 count = FILTER_READ(idx+1, sv, maxlen);
 365     if (count > 0 && !maxlen)
 366         strip_return(sv);
 367     return count;
 368 }
 369 #endif
 370
 371 /*
 372  * Perl_lex_start
 373  * Initialize variables.  Uses the Perl save_stack to save its state (for
 374  * recursive calls to the parser).
 375  */
 376
 377 void
 378 Perl_lex_start(pTHX_ SV *line)
 379 {
 380     char *s;
 381     STRLEN len;
 382
 383     SAVEI32(PL_lex_dojoin);
 384     SAVEI32(PL_lex_brackets);
 385     SAVEI32(PL_lex_casemods);
 386     SAVEI32(PL_lex_starts);
 387     SAVEI32(PL_lex_state);
 388     SAVEVPTR(PL_lex_inpat);
 389     SAVEI32(PL_lex_inwhat);
 390     if (PL_lex_state == LEX_KNOWNEXT) {
 391         I32 toke = PL_nexttoke;
 392         while (--toke >= 0) {
 393             SAVEI32(PL_nexttype[toke]);
 394             SAVEVPTR(PL_nextval[toke]);
 395         }
 396         SAVEI32(PL_nexttoke);
 397     }
 398     SAVECOPLINE(PL_curcop);
 399     SAVEPPTR(PL_bufptr);
 400     SAVEPPTR(PL_bufend);
 401     SAVEPPTR(PL_oldbufptr);
 402     SAVEPPTR(PL_oldoldbufptr);
 403     SAVEPPTR(PL_last_lop);
 404     SAVEPPTR(PL_last_uni);
 405     SAVEPPTR(PL_linestart);
 406     SAVESPTR(PL_linestr);
 407     SAVEPPTR(PL_lex_brackstack);
 408     SAVEPPTR(PL_lex_casestack);
 409     SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
 410     SAVESPTR(PL_lex_stuff);
 411     SAVEI32(PL_lex_defer);
 412     SAVEI32(PL_sublex_info.sub_inwhat);
 413     SAVESPTR(PL_lex_repl);
 414     SAVEINT(PL_expect);
 415     SAVEINT(PL_lex_expect);
 416
 417     PL_lex_state = LEX_NORMAL;
 418     PL_lex_defer = 0;
 419     PL_expect = XSTATE;
 420     PL_lex_brackets = 0;
 421     New(899, PL_lex_brackstack, 120, char);
 422     New(899, PL_lex_casestack, 12, char);
 423     SAVEFREEPV(PL_lex_brackstack);
 424     SAVEFREEPV(PL_lex_casestack);
 425     PL_lex_casemods = 0;
 426     *PL_lex_casestack = '\0';
 427     PL_lex_dojoin = 0;
 428     PL_lex_starts = 0;
 429     PL_lex_stuff = Nullsv;
 430     PL_lex_repl = Nullsv;
 431     PL_lex_inpat = 0;
 432     PL_nexttoke = 0;
 433     PL_lex_inwhat = 0;
 434     PL_sublex_info.sub_inwhat = 0;
 435     PL_linestr = line;
 436     if (SvREADONLY(PL_linestr))
 437         PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 438     s = SvPV(PL_linestr, len);
 439     if (len && s[len-1] != ';') {
 440         if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
 441             PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 442         sv_catpvn(PL_linestr, "\n;", 2);
 443     }
 444     SvTEMP_off(PL_linestr);
 445     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
 446     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
 447     PL_last_lop = PL_last_uni = Nullch;
 448     PL_rsfp = 0;
 449 }
 450
 451 /*
 452  * Perl_lex_end
 453  * Finalizer for lexing operations.  Must be called when the parser is
 454  * done with the lexer.
 455  */
 456
 457 void
 458 Perl_lex_end(pTHX)
 459 {
 460     PL_doextract = FALSE;
 461 }
 462
 463 /*
 464  * S_incline
 465  * This subroutine has nothing to do with tilting, whether at windmills
 466  * or pinball tables.  Its name is short for "increment line".  It
 467  * increments the current line number in CopLINE(PL_curcop) and checks
 468  * to see whether the line starts with a comment of the form
 469  *    # line 500 "foo.pm"
 470  * If so, it sets the current line number and file to the values in the comment.
 471  */
 472
 473 STATIC void
 474 S_incline(pTHX_ char *s)
 475 {
 476     char *t;
 477     char *n;
 478     char *e;
 479     char ch;
 480
 481     CopLINE_inc(PL_curcop);
 482     if (*s++ != '#')
 483         return;
 484     while (SPACE_OR_TAB(*s)) s++;
 485     if (strnEQ(s, "line", 4))
 486         s += 4;
 487     else
 488         return;
 489     if (SPACE_OR_TAB(*s))
 490         s++;
 491     else
 492         return;
 493     while (SPACE_OR_TAB(*s)) s++;
 494     if (!isDIGIT(*s))
 495         return;
 496     n = s;
 497     while (isDIGIT(*s))
 498         s++;
 499     while (SPACE_OR_TAB(*s))
 500         s++;
 501     if (*s == '"' && (t = strchr(s+1, '"'))) {
 502         s++;
 503         e = t + 1;
 504     }
 505     else {
 506         for (t = s; !isSPACE(*t); t++) ;
 507         e = t;
 508     }
 509     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
 510         e++;
 511     if (*e != '\n' && *e != '\0')
 512         return;         /* false alarm */
 513
 514     ch = *t;
 515     *t = '\0';
 516     if (t - s > 0) {
 517         CopFILE_free(PL_curcop);
 518         CopFILE_set(PL_curcop, s);
 519     }
 520     *t = ch;
 521     CopLINE_set(PL_curcop, atoi(n)-1);
 522 }
 523
 524 /*
 525  * S_skipspace
 526  * Called to gobble the appropriate amount and type of whitespace.
 527  * Skips comments as well.
 528  */
 529
 530 STATIC char *
 531 S_skipspace(pTHX_ register char *s)
 532 {
 533     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
 534         while (s < PL_bufend && SPACE_OR_TAB(*s))
 535             s++;
 536         return s;
 537     }
 538     for (;;) {
 539         STRLEN prevlen;
 540         SSize_t oldprevlen, oldoldprevlen;
 541         SSize_t oldloplen = 0, oldunilen = 0;
 542         while (s < PL_bufend && isSPACE(*s)) {
 543             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
 544                 incline(s);
 545         }
 546
 547         /* comment */
 548         if (s < PL_bufend && *s == '#') {
 549             while (s < PL_bufend && *s != '\n')
 550                 s++;
 551             if (s < PL_bufend) {
 552                 s++;
 553                 if (PL_in_eval && !PL_rsfp) {
 554                     incline(s);
 555                     continue;
 556                 }
 557             }
 558         }
 559
 560         /* only continue to recharge the buffer if we're at the end
 561          * of the buffer, we're not reading from a source filter, and
 562          * we're in normal lexing mode
 563          */
 564         if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
 565                 PL_lex_state == LEX_FORMLINE)
 566             return s;
 567
 568         /* try to recharge the buffer */
 569         if ((s = filter_gets(PL_linestr, PL_rsfp,
 570                              (prevlen = SvCUR(PL_linestr)))) == Nullch)
 571         {
 572             /* end of file.  Add on the -p or -n magic */
 573             if (PL_minus_n || PL_minus_p) {
 574                 sv_setpv(PL_linestr,PL_minus_p ?
 575                          ";}continue{print or die qq(-p destination: $!\\n)" :
 576                          "");
 577                 sv_catpv(PL_linestr,";}");
 578                 PL_minus_n = PL_minus_p = 0;
 579             }
 580             else
 581                 sv_setpv(PL_linestr,";");
 582
 583             /* reset variables for next time we lex */
 584             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
 585                 = SvPVX(PL_linestr);
 586             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
 587             PL_last_lop = PL_last_uni = Nullch;
 588
 589             /* Close the filehandle.  Could be from -P preprocessor,
 590              * STDIN, or a regular file.  If we were reading code from
 591              * STDIN (because the commandline held no -e or filename)
 592              * then we don't close it, we reset it so the code can
 593              * read from STDIN too.
 594              */
 595
 596             if (PL_preprocess && !PL_in_eval)
 597                 (void)PerlProc_pclose(PL_rsfp);
 598             else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
 599                 PerlIO_clearerr(PL_rsfp);
 600             else
 601                 (void)PerlIO_close(PL_rsfp);
 602             PL_rsfp = Nullfp;
 603             return s;
 604         }
 605
 606         /* not at end of file, so we only read another line */
 607         /* make corresponding updates to old pointers, for yyerror() */
 608         oldprevlen = PL_oldbufptr - PL_bufend;
 609         oldoldprevlen = PL_oldoldbufptr - PL_bufend;
 610         if (PL_last_uni)
 611             oldunilen = PL_last_uni - PL_bufend;
 612         if (PL_last_lop)
 613             oldloplen = PL_last_lop - PL_bufend;
 614         PL_linestart = PL_bufptr = s + prevlen;
 615         PL_bufend = s + SvCUR(PL_linestr);
 616         s = PL_bufptr;
 617         PL_oldbufptr = s + oldprevlen;
 618         PL_oldoldbufptr = s + oldoldprevlen;
 619         if (PL_last_uni)
 620             PL_last_uni = s + oldunilen;
 621         if (PL_last_lop)
 622             PL_last_lop = s + oldloplen;
 623         incline(s);
 624
 625         /* debugger active and we're not compiling the debugger code,
 626          * so store the line into the debugger's array of lines
 627          */
 628         if (PERLDB_LINE && PL_curstash != PL_debstash) {
 629             SV *sv = NEWSV(85,0);
 630
 631             sv_upgrade(sv, SVt_PVMG);
 632             sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
 633             (void)SvIOK_on(sv);
 634             SvIVX(sv) = 0;
 635             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
 636         }
 637     }
 638 }
 639
 640 /*
 641  * S_check_uni
 642  * Check the unary operators to ensure there's no ambiguity in how they're
 643  * used.  An ambiguous piece of code would be:
 644  *     rand + 5
 645  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
 646  * the +5 is its argument.
 647  */
 648
 649 STATIC void
 650 S_check_uni(pTHX)
 651 {
 652     char *s;
 653     char *t;
 654
 655     if (PL_oldoldbufptr != PL_last_uni)
 656         return;
 657     while (isSPACE(*PL_last_uni))
 658         PL_last_uni++;
 659     for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
 660     if ((t = strchr(s, '(')) && t < PL_bufptr)
 661         return;
 662     if (ckWARN_d(WARN_AMBIGUOUS)){
 663         char ch = *s;
 664         *s = '\0';
 665         Perl_warner(aTHX_ WARN_AMBIGUOUS,
 666                    "Warning: Use of \"%s\" without parens is ambiguous",
 667                    PL_last_uni);
 668         *s = ch;
 669     }
 670 }
 671
 672 /* workaround to replace the UNI() macro with a function.  Only the
 673  * hints/uts.sh file mentions this.  Other comments elsewhere in the
 674  * source indicate Microport Unix might need it too.
 675  */
 676
 677 #ifdef CRIPPLED_CC
 678
 679 #undef UNI
 680 #define UNI(f) return uni(f,s)
 681
 682 STATIC int
 683 S_uni(pTHX_ I32 f, char *s)
 684 {
 685     yylval.ival = f;
 686     PL_expect = XTERM;
 687     PL_bufptr = s;
 688     PL_last_uni = PL_oldbufptr;
 689     PL_last_lop_op = f;
 690     if (*s == '(')
 691         return FUNC1;
 692     s = skipspace(s);
 693     if (*s == '(')
 694         return FUNC1;
 695     else
 696         return UNIOP;
 697 }
 698
 699 #endif /* CRIPPLED_CC */
 700
 701 /*
 702  * LOP : macro to build a list operator.  Its behaviour has been replaced
 703  * with a subroutine, S_lop() for which LOP is just another name.
 704  */
 705
 706 #define LOP(f,x) return lop(f,x,s)
 707
 708 /*
 709  * S_lop
 710  * Build a list operator (or something that might be one).  The rules:
 711  *  - if we have a next token, then it's a list operator [why?]
 712  *  - if the next thing is an opening paren, then it's a function
 713  *  - else it's a list operator
 714  */
 715
 716 STATIC I32
 717 S_lop(pTHX_ I32 f, int x, char *s)
 718 {
 719     yylval.ival = f;
 720     CLINE;
 721     REPORT("lop", f)
 722     PL_expect = x;
 723     PL_bufptr = s;
 724     PL_last_lop = PL_oldbufptr;
 725     PL_last_lop_op = f;
 726     if (PL_nexttoke)
 727         return LSTOP;
 728     if (*s == '(')
 729         return FUNC;
 730     s = skipspace(s);
 731     if (*s == '(')
 732         return FUNC;
 733     else
 734         return LSTOP;
 735 }
 736
 737 /*
 738  * S_force_next
 739  * When the lexer realizes it knows the next token (for instance,
 740  * it is reordering tokens for the parser) then it can call S_force_next
 741  * to know what token to return the next time the lexer is called.  Caller
 742  * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
 743  * handles the token correctly.
 744  */
 745
 746 STATIC void
 747 S_force_next(pTHX_ I32 type)
 748 {
 749     PL_nexttype[PL_nexttoke] = type;
 750     PL_nexttoke++;
 751     if (PL_lex_state != LEX_KNOWNEXT) {
 752         PL_lex_defer = PL_lex_state;
 753         PL_lex_expect = PL_expect;
 754         PL_lex_state = LEX_KNOWNEXT;
 755     }
 756 }
 757
 758 /*
 759  * S_force_word
 760  * When the lexer knows the next thing is a word (for instance, it has
 761  * just seen -> and it knows that the next char is a word char, then
 762  * it calls S_force_word to stick the next word into the PL_next lookahead.
 763  *
 764  * Arguments:
 765  *   char *start : buffer position (must be within PL_linestr)
 766  *   int token   : PL_next will be this type of bare word (e.g., METHOD,WORD)
 767  *   int check_keyword : if true, Perl checks to make sure the word isn't
 768  *       a keyword (do this if the word is a label, e.g. goto FOO)
 769  *   int allow_pack : if true, : characters will also be allowed (require,
 770  *       use, etc. do this)
 771  *   int allow_initial_tick : used by the "sub" lexer only.
 772  */
 773
 774 STATIC char *
 775 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
 776 {
 777     register char *s;
 778     STRLEN len;
 779
 780     start = skipspace(start);
 781     s = start;
 782     if (isIDFIRST_lazy_if(s,UTF) ||
 783         (allow_pack && *s == ':') ||
 784         (allow_initial_tick && *s == '\'') )
 785     {
 786         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
 787         if (check_keyword && keyword(PL_tokenbuf, len))
 788             return start;
 789         if (token == METHOD) {
 790             s = skipspace(s);
 791             if (*s == '(')
 792                 PL_expect = XTERM;
 793             else {
 794                 PL_expect = XOPERATOR;
 795             }
 796         }
 797         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
 798         PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
 799         force_next(token);
 800     }
 801     return s;
 802 }
 803
 804 /*
 805  * S_force_ident
 806  * Called when the lexer wants $foo *foo &foo etc, but the program
 807  * text only contains the "foo" portion.  The first argument is a pointer
 808  * to the "foo", and the second argument is the type symbol to prefix.
 809  * Forces the next token to be a "WORD".
 810  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
 811  */
 812
 813 STATIC void
 814 S_force_ident(pTHX_ register char *s, int kind)
 815 {
 816     if (s && *s) {
 817         OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
 818         PL_nextval[PL_nexttoke].opval = o;
 819         force_next(WORD);
 820         if (kind) {
 821             o->op_private = OPpCONST_ENTERED;
 822             /* XXX see note in pp_entereval() for why we forgo typo
 823                warnings if the symbol must be introduced in an eval.
 824                GSAR 96-10-12 */
 825             gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
 826                 kind == '$' ? SVt_PV :
 827                 kind == '@' ? SVt_PVAV :
 828                 kind == '%' ? SVt_PVHV :
 829                               SVt_PVGV
 830                 );
 831         }
 832     }
 833 }
 834
 835 NV
 836 Perl_str_to_version(pTHX_ SV *sv)
 837 {
 838     NV retval = 0.0;
 839     NV nshift = 1.0;
 840     STRLEN len;
 841     char *start = SvPVx(sv,len);
 842     bool utf = SvUTF8(sv) ? TRUE : FALSE;
 843     char *end = start + len;
 844     while (start < end) {
 845         STRLEN skip;
 846         UV n;
 847         if (utf)
 848             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
 849         else {
 850             n = *(U8*)start;
 851             skip = 1;
 852         }
 853         retval += ((NV)n)/nshift;
 854         start += skip;
 855         nshift *= 1000;
 856     }
 857     return retval;
 858 }
 859
 860 /*
 861  * S_force_version
 862  * Forces the next token to be a version number.
 863  * If the next token appears to be an invalid version number, (e.g. "v2b"),
 864  * and if "guessing" is TRUE, then no new token is created (and the caller
 865  * must use an alternative parsing method).
 866  */
 867
 868 STATIC char *
 869 S_force_version(pTHX_ char *s, int guessing)
 870 {
 871     OP *version = Nullop;
 872     char *d;
 873
 874     s = skipspace(s);
 875
 876     d = s;
 877     if (*d == 'v')
 878         d++;
 879     if (isDIGIT(*d)) {
 880         while (isDIGIT(*d) || *d == '_' || *d == '.')
 881             d++;
 882         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
 883             SV *ver;
 884             s = scan_num(s, &yylval);
 885             version = yylval.opval;
 886             ver = cSVOPx(version)->op_sv;
 887             if (SvPOK(ver) && !SvNIOK(ver)) {
 888                 (void)SvUPGRADE(ver, SVt_PVNV);
 889                 SvNVX(ver) = str_to_version(ver);
 890                 SvNOK_on(ver);          /* hint that it is a version */
 891             }
 892         }
 893         else if (guessing)
 894             return s;
 895     }
 896
 897     /* NOTE: The parser sees the package name and the VERSION swapped */
 898     PL_nextval[PL_nexttoke].opval = version;
 899     force_next(WORD);
 900
 901     return s;
 902 }
 903
 904 /*
 905  * S_tokeq
 906  * Tokenize a quoted string passed in as an SV.  It finds the next
 907  * chunk, up to end of string or a backslash.  It may make a new
 908  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
 909  * turns \\ into \.
 910  */
 911
 912 STATIC SV *
 913 S_tokeq(pTHX_ SV *sv)
 914 {
 915     register char *s;
 916     register char *send;
 917     register char *d;
 918     STRLEN len = 0;
 919     SV *pv = sv;
 920
 921     if (!SvLEN(sv))
 922         goto finish;
 923
 924     s = SvPV_force(sv, len);
 925     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
 926         goto finish;
 927     send = s + len;
 928     while (s < send && *s != '\\')
 929         s++;
 930     if (s == send)
 931         goto finish;
 932     d = s;
 933     if ( PL_hints & HINT_NEW_STRING ) {
 934         pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
 935         if (SvUTF8(sv))
 936             SvUTF8_on(pv);
 937     }
 938     while (s < send) {
 939         if (*s == '\\') {
 940             if (s + 1 < send && (s[1] == '\\'))
 941                 s++;            /* all that, just for this */
 942         }
 943         *d++ = *s++;
 944     }
 945     *d = '\0';
 946     SvCUR_set(sv, d - SvPVX(sv));
 947   finish:
 948     if ( PL_hints & HINT_NEW_STRING )
 949        return new_constant(NULL, 0, "q", sv, pv, "q");
 950     return sv;
 951 }
 952
 953 /*
 954  * Now come three functions related to double-quote context,
 955  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
 956  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
 957  * interact with PL_lex_state, and create fake ( ... ) argument lists
 958  * to handle functions and concatenation.
 959  * They assume that whoever calls them will be setting up a fake
 960  * join call, because each subthing puts a ',' after it.  This lets
 961  *   "lower \luPpEr"
 962  * become
 963  *  join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
 964  *
 965  * (I'm not sure whether the spurious commas at the end of lcfirst's
 966  * arguments and join's arguments are created or not).
 967  */
 968
 969 /*
 970  * S_sublex_start
 971  * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
 972  *
 973  * Pattern matching will set PL_lex_op to the pattern-matching op to
 974  * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
 975  *
 976  * OP_CONST and OP_READLINE are easy--just make the new op and return.
 977  *
 978  * Everything else becomes a FUNC.
 979  *
 980  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
 981  * had an OP_CONST or OP_READLINE).  This just sets us up for a
 982  * call to S_sublex_push().
 983  */
 984
 985 STATIC I32
 986 S_sublex_start(pTHX)
 987 {
 988     register I32 op_type = yylval.ival;
 989
 990     if (op_type == OP_NULL) {
 991         yylval.opval = PL_lex_op;
 992         PL_lex_op = Nullop;
 993         return THING;
 994     }
 995     if (op_type == OP_CONST || op_type == OP_READLINE) {
 996         SV *sv = tokeq(PL_lex_stuff);
 997
 998         if (SvTYPE(sv) == SVt_PVIV) {
 999             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1000             STRLEN len;
1001             char *p;
1002             SV *nsv;
1003
1004             p = SvPV(sv, len);
1005             nsv = newSVpvn(p, len);
1006             if (SvUTF8(sv))
1007                 SvUTF8_on(nsv);
1008             SvREFCNT_dec(sv);
1009             sv = nsv;
1010         }
1011         yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1012         PL_lex_stuff = Nullsv;
1013         return THING;
1014     }
1015
1016     PL_sublex_info.super_state = PL_lex_state;
1017     PL_sublex_info.sub_inwhat = op_type;
1018     PL_sublex_info.sub_op = PL_lex_op;
1019     PL_lex_state = LEX_INTERPPUSH;
1020
1021     PL_expect = XTERM;
1022     if (PL_lex_op) {
1023         yylval.opval = PL_lex_op;
1024         PL_lex_op = Nullop;
1025         return PMFUNC;
1026     }
1027     else
1028         return FUNC;
1029 }
1030
1031 /*
1032  * S_sublex_push
1033  * Create a new scope to save the lexing state.  The scope will be
1034  * ended in S_sublex_done.  Returns a '(', starting the function arguments
1035  * to the uc, lc, etc. found before.
1036  * Sets PL_lex_state to LEX_INTERPCONCAT.
1037  */
1038
1039 STATIC I32
1040 S_sublex_push(pTHX)
1041 {
1042     ENTER;
1043
1044     PL_lex_state = PL_sublex_info.super_state;
1045     SAVEI32(PL_lex_dojoin);
1046     SAVEI32(PL_lex_brackets);
1047     SAVEI32(PL_lex_casemods);
1048     SAVEI32(PL_lex_starts);
1049     SAVEI32(PL_lex_state);
1050     SAVEVPTR(PL_lex_inpat);
1051     SAVEI32(PL_lex_inwhat);
1052     SAVECOPLINE(PL_curcop);
1053     SAVEPPTR(PL_bufptr);
1054     SAVEPPTR(PL_bufend);
1055     SAVEPPTR(PL_oldbufptr);
1056     SAVEPPTR(PL_oldoldbufptr);
1057     SAVEPPTR(PL_last_lop);
1058     SAVEPPTR(PL_last_uni);
1059     SAVEPPTR(PL_linestart);
1060     SAVESPTR(PL_linestr);
1061     SAVEPPTR(PL_lex_brackstack);
1062     SAVEPPTR(PL_lex_casestack);
1063
1064     PL_linestr = PL_lex_stuff;
1065     PL_lex_stuff = Nullsv;
1066
1067     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1068         = SvPVX(PL_linestr);
1069     PL_bufend += SvCUR(PL_linestr);
1070     PL_last_lop = PL_last_uni = Nullch;
1071     SAVEFREESV(PL_linestr);
1072
1073     PL_lex_dojoin = FALSE;
1074     PL_lex_brackets = 0;
1075     New(899, PL_lex_brackstack, 120, char);
1076     New(899, PL_lex_casestack, 12, char);
1077     SAVEFREEPV(PL_lex_brackstack);
1078     SAVEFREEPV(PL_lex_casestack);
1079     PL_lex_casemods = 0;
1080     *PL_lex_casestack = '\0';
1081     PL_lex_starts = 0;
1082     PL_lex_state = LEX_INTERPCONCAT;
1083     CopLINE_set(PL_curcop, PL_multi_start);
1084
1085     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1086     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1087         PL_lex_inpat = PL_sublex_info.sub_op;
1088     else
1089         PL_lex_inpat = Nullop;
1090
1091     return '(';
1092 }
1093
1094 /*
1095  * S_sublex_done
1096  * Restores lexer state after a S_sublex_push.
1097  */
1098
1099 STATIC I32
1100 S_sublex_done(pTHX)
1101 {
1102     if (!PL_lex_starts++) {
1103         SV *sv = newSVpvn("",0);
1104         if (SvUTF8(PL_linestr))
1105             SvUTF8_on(sv);
1106         PL_expect = XOPERATOR;
1107         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1108         return THING;
1109     }
1110
1111     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
1112         PL_lex_state = LEX_INTERPCASEMOD;
1113         return yylex();
1114     }
1115
1116     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1117     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1118         PL_linestr = PL_lex_repl;
1119         PL_lex_inpat = 0;
1120         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1121         PL_bufend += SvCUR(PL_linestr);
1122         PL_last_lop = PL_last_uni = Nullch;
1123         SAVEFREESV(PL_linestr);
1124         PL_lex_dojoin = FALSE;
1125         PL_lex_brackets = 0;
1126         PL_lex_casemods = 0;
1127         *PL_lex_casestack = '\0';
1128         PL_lex_starts = 0;
1129         if (SvEVALED(PL_lex_repl)) {
1130             PL_lex_state = LEX_INTERPNORMAL;
1131             PL_lex_starts++;
1132             /*  we don't clear PL_lex_repl here, so that we can check later
1133                 whether this is an evalled subst; that means we rely on the
1134                 logic to ensure sublex_done() is called again only via the
1135                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1136         }
1137         else {
1138             PL_lex_state = LEX_INTERPCONCAT;
1139             PL_lex_repl = Nullsv;
1140         }
1141         return ',';
1142     }
1143     else {
1144         LEAVE;
1145         PL_bufend = SvPVX(PL_linestr);
1146         PL_bufend += SvCUR(PL_linestr);
1147         PL_expect = XOPERATOR;
1148         PL_sublex_info.sub_inwhat = 0;
1149         return ')';
1150     }
1151 }
1152
1153 /*
1154   scan_const
1155
1156   Extracts a pattern, double-quoted string, or transliteration.  This
1157   is terrifying code.
1158
1159   It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1160   processing a pattern (PL_lex_inpat is true), a transliteration
1161   (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1162
1163   Returns a pointer to the character scanned up to. Iff this is
1164   advanced from the start pointer supplied (ie if anything was
1165   successfully parsed), will leave an OP for the substring scanned
1166   in yylval. Caller must intuit reason for not parsing further
1167   by looking at the next characters herself.
1168
1169   In patterns:
1170     backslashes:
1171       double-quoted style: \r and \n
1172       regexp special ones: \D \s
1173       constants: \x3
1174       backrefs: \1 (deprecated in substitution replacements)
1175       case and quoting: \U \Q \E
1176     stops on @ and $, but not for $ as tail anchor
1177
1178   In transliterations:
1179     characters are VERY literal, except for - not at the start or end
1180     of the string, which indicates a range.  scan_const expands the
1181     range to the full set of intermediate characters.
1182
1183   In double-quoted strings:
1184     backslashes:
1185       double-quoted style: \r and \n
1186       constants: \x3
1187       backrefs: \1 (deprecated)
1188       case and quoting: \U \Q \E
1189     stops on @ and $
1190
1191   scan_const does *not* construct ops to handle interpolated strings.
1192   It stops processing as soon as it finds an embedded $ or @ variable
1193   and leaves it to the caller to work out what's going on.
1194
1195   @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1196
1197   $ in pattern could be $foo or could be tail anchor.  Assumption:
1198   it's a tail anchor if $ is the last thing in the string, or if it's
1199   followed by one of ")| \n\t"
1200
1201   \1 (backreferences) are turned into $1
1202
1203   The structure of the code is
1204       while (there's a character to process) {
1205           handle transliteration ranges
1206           skip regexp comments
1207           skip # initiated comments in //x patterns
1208           check for embedded @foo
1209           check for embedded scalars
1210           if (backslash) {
1211               leave intact backslashes from leave (below)
1212               deprecate \1 in strings and sub replacements
1213               handle string-changing backslashes \l \U \Q \E, etc.
1214               switch (what was escaped) {
1215                   handle - in a transliteration (becomes a literal -)
1216                   handle \132 octal characters
1217                   handle 0x15 hex characters
1218                   handle \cV (control V)
1219                   handle printf backslashes (\f, \r, \n, etc)
1220               } (end switch)
1221           } (end if backslash)
1222     } (end while character to read)
1223
1224 */
1225
1226 STATIC char *
1227 S_scan_const(pTHX_ char *start)
1228 {
1229     register char *send = PL_bufend;            /* end of the constant */
1230     SV *sv = NEWSV(93, send - start);           /* sv for the constant */
1231     register char *s = start;                   /* start of the constant */
1232     register char *d = SvPVX(sv);               /* destination for copies */
1233     bool dorange = FALSE;                       /* are we in a translit range? */
1234     bool didrange = FALSE;                      /* did we just finish a range? */
1235     I32  has_utf8 = FALSE;                      /* Output constant is UTF8 */
1236     I32  this_utf8 = UTF;                       /* The source string is assumed to be UTF8 */
1237     UV uv;
1238
1239     const char *leaveit =       /* set of acceptably-backslashed characters */
1240         PL_lex_inpat
1241             ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1242             : "";
1243
1244     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1245         /* If we are doing a trans and we know we want UTF8 set expectation */
1246         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1247         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1248     }
1249
1250
1251     while (s < send || dorange) {
1252         /* get transliterations out of the way (they're most literal) */
1253         if (PL_lex_inwhat == OP_TRANS) {
1254             /* expand a range A-Z to the full set of characters.  AIE! */
1255             if (dorange) {
1256                 I32 i;                          /* current expanded character */
1257                 I32 min;                        /* first character in range */
1258                 I32 max;                        /* last character in range */
1259
1260                 if (has_utf8) {
1261                     char *c = (char*)utf8_hop((U8*)d, -1);
1262                     char *e = d++;
1263                     while (e-- > c)
1264                         *(e + 1) = *e;
1265                     *c = (char)UTF_TO_NATIVE(0xff);
1266                     /* mark the range as done, and continue */
1267                     dorange = FALSE;
1268                     didrange = TRUE;
1269                     continue;
1270                 }
1271
1272                 i = d - SvPVX(sv);              /* remember current offset */
1273                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
1274                 d = SvPVX(sv) + i;              /* refresh d after realloc */
1275                 d -= 2;                         /* eat the first char and the - */
1276
1277                 min = (U8)*d;                   /* first char in range */
1278                 max = (U8)d[1];                 /* last char in range  */
1279
1280                 if (min > max) {
1281                     Perl_croak(aTHX_
1282                                "Invalid [] range \"%c-%c\" in transliteration operator",
1283                                (char)min, (char)max);
1284                 }
1285
1286 #ifdef EBCDIC
1287                 if ((isLOWER(min) && isLOWER(max)) ||
1288                     (isUPPER(min) && isUPPER(max))) {
1289                     if (isLOWER(min)) {
1290                         for (i = min; i <= max; i++)
1291                             if (isLOWER(i))
1292                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1293                     } else {
1294                         for (i = min; i <= max; i++)
1295                             if (isUPPER(i))
1296                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1297                     }
1298                 }
1299                 else
1300 #endif
1301                     for (i = min; i <= max; i++)
1302                         *d++ = i;
1303
1304                 /* mark the range as done, and continue */
1305                 dorange = FALSE;
1306                 didrange = TRUE;
1307                 continue;
1308             }
1309
1310             /* range begins (ignore - as first or last char) */
1311             else if (*s == '-' && s+1 < send  && s != start) {
1312                 if (didrange) {
1313                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1314                 }
1315                 if (has_utf8) {
1316                     *d++ = (char)UTF_TO_NATIVE(0xff);   /* use illegal utf8 byte--see pmtrans */
1317                     s++;
1318                     continue;
1319                 }
1320                 dorange = TRUE;
1321                 s++;
1322             }
1323             else {
1324                 didrange = FALSE;
1325             }
1326         }
1327
1328         /* if we get here, we're not doing a transliteration */
1329
1330         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1331            except for the last char, which will be done separately. */
1332         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1333             if (s[2] == '#') {
1334                 while (s < send && *s != ')')
1335                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1336             }
1337             else if (s[2] == '{' /* This should match regcomp.c */
1338                      || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1339             {
1340                 I32 count = 1;
1341                 char *regparse = s + (s[2] == '{' ? 3 : 4);
1342                 char c;
1343
1344                 while (count && (c = *regparse)) {
1345                     if (c == '\\' && regparse[1])
1346                         regparse++;
1347                     else if (c == '{')
1348                         count++;
1349                     else if (c == '}')
1350                         count--;
1351                     regparse++;
1352                 }
1353                 if (*regparse != ')') {
1354                     regparse--;         /* Leave one char for continuation. */
1355                     yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1356                 }
1357                 while (s < regparse)
1358                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1359             }
1360         }
1361
1362         /* likewise skip #-initiated comments in //x patterns */
1363         else if (*s == '#' && PL_lex_inpat &&
1364           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1365             while (s+1 < send && *s != '\n')
1366                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1367         }
1368
1369         /* check for embedded arrays
1370            (@foo, @:foo, @'foo, @{foo}, @$foo, @+, @-)
1371            */
1372         else if (*s == '@' && s[1]
1373                  && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1374             break;
1375
1376         /* check for embedded scalars.  only stop if we're sure it's a
1377            variable.
1378         */
1379         else if (*s == '$') {
1380             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
1381                 break;
1382             if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1383                 break;          /* in regexp, $ might be tail anchor */
1384         }
1385
1386         /* End of else if chain - OP_TRANS rejoin rest */
1387
1388         /* backslashes */
1389         if (*s == '\\' && s+1 < send) {
1390             s++;
1391
1392             /* some backslashes we leave behind */
1393             if (*leaveit && *s && strchr(leaveit, *s)) {
1394                 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1395                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1396                 continue;
1397             }
1398
1399             /* deprecate \1 in strings and substitution replacements */
1400             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1401                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1402             {
1403                 if (ckWARN(WARN_SYNTAX))
1404                     Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1405                 *--s = '$';
1406                 break;
1407             }
1408
1409             /* string-change backslash escapes */
1410             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1411                 --s;
1412                 break;
1413             }
1414
1415             /* if we get here, it's either a quoted -, or a digit */
1416             switch (*s) {
1417
1418             /* quoted - in transliterations */
1419             case '-':
1420                 if (PL_lex_inwhat == OP_TRANS) {
1421                     *d++ = *s++;
1422                     continue;
1423                 }
1424                 /* FALL THROUGH */
1425             default:
1426                 {
1427                     if (ckWARN(WARN_MISC) && isALNUM(*s))
1428                         Perl_warner(aTHX_ WARN_MISC,
1429                                "Unrecognized escape \\%c passed through",
1430                                *s);
1431                     /* default action is to copy the quoted character */
1432                     goto default_action;
1433                 }
1434
1435             /* \132 indicates an octal constant */
1436             case '0': case '1': case '2': case '3':
1437             case '4': case '5': case '6': case '7':
1438                 {
1439                     I32 flags = 0;
1440                     STRLEN len = 3;
1441                     uv = grok_oct(s, &len, &flags, NULL);
1442                     s += len;
1443                 }
1444                 goto NUM_ESCAPE_INSERT;
1445
1446             /* \x24 indicates a hex constant */
1447             case 'x':
1448                 ++s;
1449                 if (*s == '{') {
1450                     char* e = strchr(s, '}');
1451                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1452                       PERL_SCAN_DISALLOW_PREFIX;
1453                     STRLEN len;
1454
1455                     ++s;
1456                     if (!e) {
1457                         yyerror("Missing right brace on \\x{}");
1458                         continue;
1459                     }
1460                     len = e - s;
1461                     uv = grok_hex(s, &len, &flags, NULL);
1462                     s = e + 1;
1463                 }
1464                 else {
1465                     {
1466                         STRLEN len = 2;
1467                         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1468                         uv = grok_hex(s, &len, &flags, NULL);
1469                         s += len;
1470                     }
1471                 }
1472
1473               NUM_ESCAPE_INSERT:
1474                 /* Insert oct or hex escaped character.
1475                  * There will always enough room in sv since such
1476                  * escapes will be longer than any UTF-8 sequence
1477                  * they can end up as. */
1478
1479                 /* We need to map to chars to ASCII before doing the tests
1480                    to cover EBCDIC
1481                 */
1482                 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1483                     if (!has_utf8 && uv > 255) {
1484                         /* Might need to recode whatever we have
1485                          * accumulated so far if it contains any
1486                          * hibit chars.
1487                          *
1488                          * (Can't we keep track of that and avoid
1489                          *  this rescan? --jhi)
1490                          */
1491                         int hicount = 0;
1492                         U8 *c;
1493                         for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1494                             if (!NATIVE_IS_INVARIANT(*c)) {
1495                                 hicount++;
1496                             }
1497                         }
1498                         if (hicount) {
1499                             STRLEN offset = d - SvPVX(sv);
1500                             U8 *src, *dst;
1501                             d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1502                             src = (U8 *)d - 1;
1503                             dst = src+hicount;
1504                             d  += hicount;
1505                             while (src >= (U8 *)SvPVX(sv)) {
1506                                 if (!NATIVE_IS_INVARIANT(*src)) {
1507                                     U8 ch = NATIVE_TO_ASCII(*src);
1508                                     *dst-- = UTF8_EIGHT_BIT_LO(ch);
1509                                     *dst-- = UTF8_EIGHT_BIT_HI(ch);
1510                                 }
1511                                 else {
1512                                     *dst-- = *src;
1513                                 }
1514                                 src--;
1515                             }
1516                         }
1517                     }
1518
1519                     if (has_utf8 || uv > 255) {
1520                         d = (char*)uvchr_to_utf8((U8*)d, uv);
1521                         has_utf8 = TRUE;
1522                         if (PL_lex_inwhat == OP_TRANS &&
1523                             PL_sublex_info.sub_op) {
1524                             PL_sublex_info.sub_op->op_private |=
1525                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
1526                                              : OPpTRANS_TO_UTF);
1527                         }
1528                     }
1529                     else {
1530                         *d++ = (char)uv;
1531                     }
1532                 }
1533                 else {
1534                     *d++ = (char) uv;
1535                 }
1536                 continue;
1537
1538             /* \N{LATIN SMALL LETTER A} is a named character */
1539             case 'N':
1540                 ++s;
1541                 if (*s == '{') {
1542                     char* e = strchr(s, '}');
1543                     SV *res;
1544                     STRLEN len;
1545                     char *str;
1546
1547                     if (!e) {
1548                         yyerror("Missing right brace on \\N{}");
1549                         e = s - 1;
1550                         goto cont_scan;
1551                     }
1552                     res = newSVpvn(s + 1, e - s - 1);
1553                     res = new_constant( Nullch, 0, "charnames",
1554                                         res, Nullsv, "\\N{...}" );
1555                     if (has_utf8)
1556                         sv_utf8_upgrade(res);
1557                     str = SvPV(res,len);
1558                     if (!has_utf8 && SvUTF8(res)) {
1559                         char *ostart = SvPVX(sv);
1560                         SvCUR_set(sv, d - ostart);
1561                         SvPOK_on(sv);
1562                         *d = '\0';
1563                         sv_utf8_upgrade(sv);
1564                         /* this just broke our allocation above... */
1565                         SvGROW(sv, send - start);
1566                         d = SvPVX(sv) + SvCUR(sv);
1567                         has_utf8 = TRUE;
1568                     }
1569                     if (len > e - s + 4) { /* I _guess_ 4 is \N{} --jhi */
1570                         char *odest = SvPVX(sv);
1571
1572                         SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1573                         d = SvPVX(sv) + (d - odest);
1574                     }
1575                     Copy(str, d, len, char);
1576                     d += len;
1577                     SvREFCNT_dec(res);
1578                   cont_scan:
1579                     s = e + 1;
1580                 }
1581                 else
1582                     yyerror("Missing braces on \\N{}");
1583                 continue;
1584
1585             /* \c is a control character */
1586             case 'c':
1587                 s++;
1588                 {
1589                     U8 c = *s++;
1590 #ifdef EBCDIC
1591                     if (isLOWER(c))
1592                         c = toUPPER(c);
1593 #endif
1594                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1595                 }
1596                 continue;
1597
1598             /* printf-style backslashes, formfeeds, newlines, etc */
1599             case 'b':
1600                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1601                 break;
1602             case 'n':
1603                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1604                 break;
1605             case 'r':
1606                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1607                 break;
1608             case 'f':
1609                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1610                 break;
1611             case 't':
1612                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1613                 break;
1614             case 'e':
1615                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1616                 break;
1617             case 'a':
1618                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1619                 break;
1620             } /* end switch */
1621
1622             s++;
1623             continue;
1624         } /* end if (backslash) */
1625
1626     default_action:
1627         /* If we started with encoded form, or already know we want it
1628            and then encode the next character */
1629         if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1630             STRLEN len  = 1;
1631             UV uv       = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1632             STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1633             s += len;
1634             if (need > len) {
1635                 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1636                 STRLEN off = d - SvPVX(sv);
1637                 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1638             }
1639             d = (char*)uvchr_to_utf8((U8*)d, uv);
1640             has_utf8 = TRUE;
1641         }
1642         else {
1643             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1644         }
1645     } /* while loop to process each character */
1646
1647     /* terminate the string and set up the sv */
1648     *d = '\0';
1649     SvCUR_set(sv, d - SvPVX(sv));
1650     if (SvCUR(sv) >= SvLEN(sv))
1651       Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1652
1653     SvPOK_on(sv);
1654     if (PL_encoding && !has_utf8) {
1655         Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
1656         has_utf8 = TRUE;
1657     }
1658     if (has_utf8) {
1659         SvUTF8_on(sv);
1660         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1661                 PL_sublex_info.sub_op->op_private |=
1662                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1663         }
1664     }
1665
1666     /* shrink the sv if we allocated more than we used */
1667     if (SvCUR(sv) + 5 < SvLEN(sv)) {
1668         SvLEN_set(sv, SvCUR(sv) + 1);
1669         Renew(SvPVX(sv), SvLEN(sv), char);
1670     }
1671
1672     /* return the substring (via yylval) only if we parsed anything */
1673     if (s > PL_bufptr) {
1674         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1675             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1676                               sv, Nullsv,
1677                               ( PL_lex_inwhat == OP_TRANS
1678                                 ? "tr"
1679                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1680                                     ? "s"
1681                                     : "qq")));
1682         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1683     } else
1684         SvREFCNT_dec(sv);
1685     return s;
1686 }
1687
1688 /* S_intuit_more
1689  * Returns TRUE if there's more to the expression (e.g., a subscript),
1690  * FALSE otherwise.
1691  *
1692  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1693  *
1694  * ->[ and ->{ return TRUE
1695  * { and [ outside a pattern are always subscripts, so return TRUE
1696  * if we're outside a pattern and it's not { or [, then return FALSE
1697  * if we're in a pattern and the first char is a {
1698  *   {4,5} (any digits around the comma) returns FALSE
1699  * if we're in a pattern and the first char is a [
1700  *   [] returns FALSE
1701  *   [SOMETHING] has a funky algorithm to decide whether it's a
1702  *      character class or not.  It has to deal with things like
1703  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1704  * anything else returns TRUE
1705  */
1706
1707 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1708
1709 STATIC int
1710 S_intuit_more(pTHX_ register char *s)
1711 {
1712     if (PL_lex_brackets)
1713         return TRUE;
1714     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1715         return TRUE;
1716     if (*s != '{' && *s != '[')
1717         return FALSE;
1718     if (!PL_lex_inpat)
1719         return TRUE;
1720
1721     /* In a pattern, so maybe we have {n,m}. */
1722     if (*s == '{') {
1723         s++;
1724         if (!isDIGIT(*s))
1725             return TRUE;
1726         while (isDIGIT(*s))
1727             s++;
1728         if (*s == ',')
1729             s++;
1730         while (isDIGIT(*s))
1731             s++;
1732         if (*s == '}')
1733             return FALSE;
1734         return TRUE;
1735
1736     }
1737
1738     /* On the other hand, maybe we have a character class */
1739
1740     s++;
1741     if (*s == ']' || *s == '^')
1742         return FALSE;
1743     else {
1744         /* this is terrifying, and it works */
1745         int weight = 2;         /* let's weigh the evidence */
1746         char seen[256];
1747         unsigned char un_char = 255, last_un_char;
1748         char *send = strchr(s,']');
1749         char tmpbuf[sizeof PL_tokenbuf * 4];
1750
1751         if (!send)              /* has to be an expression */
1752             return TRUE;
1753
1754         Zero(seen,256,char);
1755         if (*s == '$')
1756             weight -= 3;
1757         else if (isDIGIT(*s)) {
1758             if (s[1] != ']') {
1759                 if (isDIGIT(s[1]) && s[2] == ']')
1760                     weight -= 10;
1761             }
1762             else
1763                 weight -= 100;
1764         }
1765         for (; s < send; s++) {
1766             last_un_char = un_char;
1767             un_char = (unsigned char)*s;
1768             switch (*s) {
1769             case '@':
1770             case '&':
1771             case '$':
1772                 weight -= seen[un_char] * 10;
1773                 if (isALNUM_lazy_if(s+1,UTF)) {
1774                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1775                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1776                         weight -= 100;
1777                     else
1778                         weight -= 10;
1779                 }
1780                 else if (*s == '$' && s[1] &&
1781                   strchr("[#!%*<>()-=",s[1])) {
1782                     if (/*{*/ strchr("])} =",s[2]))
1783                         weight -= 10;
1784                     else
1785                         weight -= 1;
1786                 }
1787                 break;
1788             case '\\':
1789                 un_char = 254;
1790                 if (s[1]) {
1791                     if (strchr("wds]",s[1]))
1792                         weight += 100;
1793                     else if (seen['\''] || seen['"'])
1794                         weight += 1;
1795                     else if (strchr("rnftbxcav",s[1]))
1796                         weight += 40;
1797                     else if (isDIGIT(s[1])) {
1798                         weight += 40;
1799                         while (s[1] && isDIGIT(s[1]))
1800                             s++;
1801                     }
1802                 }
1803                 else
1804                     weight += 100;
1805                 break;
1806             case '-':
1807                 if (s[1] == '\\')
1808                     weight += 50;
1809                 if (strchr("aA01! ",last_un_char))
1810                     weight += 30;
1811                 if (strchr("zZ79~",s[1]))
1812                     weight += 30;
1813                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1814                     weight -= 5;        /* cope with negative subscript */
1815                 break;
1816             default:
1817                 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1818                         isALPHA(*s) && s[1] && isALPHA(s[1])) {
1819                     char *d = tmpbuf;
1820                     while (isALPHA(*s))
1821                         *d++ = *s++;
1822                     *d = '\0';
1823                     if (keyword(tmpbuf, d - tmpbuf))
1824                         weight -= 150;
1825                 }
1826                 if (un_char == last_un_char + 1)
1827                     weight += 5;
1828                 weight -= seen[un_char];
1829                 break;
1830             }
1831             seen[un_char]++;
1832         }
1833         if (weight >= 0)        /* probably a character class */
1834             return FALSE;
1835     }
1836
1837     return TRUE;
1838 }
1839
1840 /*
1841  * S_intuit_method
1842  *
1843  * Does all the checking to disambiguate
1844  *   foo bar
1845  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
1846  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1847  *
1848  * First argument is the stuff after the first token, e.g. "bar".
1849  *
1850  * Not a method if bar is a filehandle.
1851  * Not a method if foo is a subroutine prototyped to take a filehandle.
1852  * Not a method if it's really "Foo $bar"
1853  * Method if it's "foo $bar"
1854  * Not a method if it's really "print foo $bar"
1855  * Method if it's really "foo package::" (interpreted as package->foo)
1856  * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1857  * Not a method if bar is a filehandle or package, but is quoted with
1858  *   =>
1859  */
1860
1861 STATIC int
1862 S_intuit_method(pTHX_ char *start, GV *gv)
1863 {
1864     char *s = start + (*start == '$');
1865     char tmpbuf[sizeof PL_tokenbuf];
1866     STRLEN len;
1867     GV* indirgv;
1868
1869     if (gv) {
1870         CV *cv;
1871         if (GvIO(gv))
1872             return 0;
1873         if ((cv = GvCVu(gv))) {
1874             char *proto = SvPVX(cv);
1875             if (proto) {
1876                 if (*proto == ';')
1877                     proto++;
1878                 if (*proto == '*')
1879                     return 0;
1880             }
1881         } else
1882             gv = 0;
1883     }
1884     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1885     /* start is the beginning of the possible filehandle/object,
1886      * and s is the end of it
1887      * tmpbuf is a copy of it
1888      */
1889
1890     if (*start == '$') {
1891         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1892             return 0;
1893         s = skipspace(s);
1894         PL_bufptr = start;
1895         PL_expect = XREF;
1896         return *s == '(' ? FUNCMETH : METHOD;
1897     }
1898     if (!keyword(tmpbuf, len)) {
1899         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1900             len -= 2;
1901             tmpbuf[len] = '\0';
1902             goto bare_package;
1903         }
1904         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1905         if (indirgv && GvCVu(indirgv))
1906             return 0;
1907         /* filehandle or package name makes it a method */
1908         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1909             s = skipspace(s);
1910             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1911                 return 0;       /* no assumptions -- "=>" quotes bearword */
1912       bare_package:
1913             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1914                                                    newSVpvn(tmpbuf,len));
1915             PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1916             PL_expect = XTERM;
1917             force_next(WORD);
1918             PL_bufptr = s;
1919             return *s == '(' ? FUNCMETH : METHOD;
1920         }
1921     }
1922     return 0;
1923 }
1924
1925 /*
1926  * S_incl_perldb
1927  * Return a string of Perl code to load the debugger.  If PERL5DB
1928  * is set, it will return the contents of that, otherwise a
1929  * compile-time require of perl5db.pl.
1930  */
1931
1932 STATIC char*
1933 S_incl_perldb(pTHX)
1934 {
1935     if (PL_perldb) {
1936         char *pdb = PerlEnv_getenv("PERL5DB");
1937
1938         if (pdb)
1939             return pdb;
1940         SETERRNO(0,SS$_NORMAL);
1941         return "BEGIN { require 'perl5db.pl' }";
1942     }
1943     return "";
1944 }
1945
1946
1947 /* Encoded script support. filter_add() effectively inserts a
1948  * 'pre-processing' function into the current source input stream.
1949  * Note that the filter function only applies to the current source file
1950  * (e.g., it will not affect files 'require'd or 'use'd by this one).
1951  *
1952  * The datasv parameter (which may be NULL) can be used to pass
1953  * private data to this instance of the filter. The filter function
1954  * can recover the SV using the FILTER_DATA macro and use it to
1955  * store private buffers and state information.
1956  *
1957  * The supplied datasv parameter is upgraded to a PVIO type
1958  * and the IoDIRP/IoANY field is used to store the function pointer,
1959  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1960  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1961  * private use must be set using malloc'd pointers.
1962  */
1963
1964 SV *
1965 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1966 {
1967     if (!funcp)
1968         return Nullsv;
1969
1970     if (!PL_rsfp_filters)
1971         PL_rsfp_filters = newAV();
1972     if (!datasv)
1973         datasv = NEWSV(255,0);
1974     if (!SvUPGRADE(datasv, SVt_PVIO))
1975         Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1976     IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
1977     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1978     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1979                           (void*)funcp, SvPV_nolen(datasv)));
1980     av_unshift(PL_rsfp_filters, 1);
1981     av_store(PL_rsfp_filters, 0, datasv) ;
1982     return(datasv);
1983 }
1984
1985
1986 /* Delete most recently added instance of this filter function. */
1987 void
1988 Perl_filter_del(pTHX_ filter_t funcp)
1989 {
1990     SV *datasv;
1991     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
1992     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1993         return;
1994     /* if filter is on top of stack (usual case) just pop it off */
1995     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1996     if (IoANY(datasv) == (void *)funcp) {
1997         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1998         IoANY(datasv) = (void *)NULL;
1999         sv_free(av_pop(PL_rsfp_filters));
2000
2001         return;
2002     }
2003     /* we need to search for the correct entry and clear it     */
2004     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2005 }
2006
2007
2008 /* Invoke the n'th filter function for the current rsfp.         */
2009 I32
2010 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2011
2012
2013                         /* 0 = read one text line */
2014 {
2015     filter_t funcp;
2016     SV *datasv = NULL;
2017
2018     if (!PL_rsfp_filters)
2019         return -1;
2020     if (idx > AvFILLp(PL_rsfp_filters)){       /* Any more filters?     */
2021         /* Provide a default input filter to make life easy.    */
2022         /* Note that we append to the line. This is handy.      */
2023         DEBUG_P(PerlIO_printf(Perl_debug_log,
2024                               "filter_read %d: from rsfp\n", idx));
2025         if (maxlen) {
2026             /* Want a block */
2027             int len ;
2028             int old_len = SvCUR(buf_sv) ;
2029
2030             /* ensure buf_sv is large enough */
2031             SvGROW(buf_sv, old_len + maxlen) ;
2032             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2033                 if (PerlIO_error(PL_rsfp))
2034                     return -1;          /* error */
2035                 else
2036                     return 0 ;          /* end of file */
2037             }
2038             SvCUR_set(buf_sv, old_len + len) ;
2039         } else {
2040             /* Want a line */
2041             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2042                 if (PerlIO_error(PL_rsfp))
2043                     return -1;          /* error */
2044                 else
2045                     return 0 ;          /* end of file */
2046             }
2047         }
2048         return SvCUR(buf_sv);
2049     }
2050     /* Skip this filter slot if filter has been deleted */
2051     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2052         DEBUG_P(PerlIO_printf(Perl_debug_log,
2053                               "filter_read %d: skipped (filter deleted)\n",
2054                               idx));
2055         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2056     }
2057     /* Get function pointer hidden within datasv        */
2058     funcp = (filter_t)IoANY(datasv);
2059     DEBUG_P(PerlIO_printf(Perl_debug_log,
2060                           "filter_read %d: via function %p (%s)\n",
2061                           idx, (void*)funcp, SvPV_nolen(datasv)));
2062     /* Call function. The function is expected to       */
2063     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2064     /* Return: <0:error, =0:eof, >0:not eof             */
2065     return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2066 }
2067
2068 STATIC char *
2069 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2070 {
2071 #ifdef PERL_CR_FILTER
2072     if (!PL_rsfp_filters) {
2073         filter_add(S_cr_textfilter,NULL);
2074     }
2075 #endif
2076     if (PL_rsfp_filters) {
2077
2078         if (!append)
2079             SvCUR_set(sv, 0);   /* start with empty line        */
2080         if (FILTER_READ(0, sv, 0) > 0)
2081             return ( SvPVX(sv) ) ;
2082         else
2083             return Nullch ;
2084     }
2085     else
2086         return (sv_gets(sv, fp, append));
2087 }
2088
2089 STATIC HV *
2090 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2091 {
2092     GV *gv;
2093
2094     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2095         return PL_curstash;
2096
2097     if (len > 2 &&
2098         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2099         (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2100     {
2101         return GvHV(gv);                        /* Foo:: */
2102     }
2103
2104     /* use constant CLASS => 'MyClass' */
2105     if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2106         SV *sv;
2107         if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2108             pkgname = SvPV_nolen(sv);
2109         }
2110     }
2111
2112     return gv_stashpv(pkgname, FALSE);
2113 }
2114
2115 #ifdef DEBUGGING
2116     static char* exp_name[] =
2117         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2118           "ATTRTERM", "TERMBLOCK"
2119         };
2120 #endif
2121
2122 /*
2123   yylex
2124
2125   Works out what to call the token just pulled out of the input
2126   stream.  The yacc parser takes care of taking the ops we return and
2127   stitching them into a tree.
2128
2129   Returns:
2130     PRIVATEREF
2131
2132   Structure:
2133       if read an identifier
2134           if we're in a my declaration
2135               croak if they tried to say my($foo::bar)
2136               build the ops for a my() declaration
2137           if it's an access to a my() variable
2138               are we in a sort block?
2139                   croak if my($a); $a <=> $b
2140               build ops for access to a my() variable
2141           if in a dq string, and they've said @foo and we can't find @foo
2142               croak
2143           build ops for a bareword
2144       if we already built the token before, use it.
2145 */
2146
2147 #ifdef USE_PURE_BISON
2148 int
2149 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
2150 {
2151     int r;
2152
2153     yyactlevel++;
2154     yylval_pointer[yyactlevel] = lvalp;
2155     yychar_pointer[yyactlevel] = lcharp;
2156     if (yyactlevel >= YYMAXLEVEL)
2157         Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2158
2159     r = Perl_yylex(aTHX);
2160
2161     if (yyactlevel > 0)
2162        yyactlevel--;
2163
2164     return r;
2165 }
2166 #endif
2167
2168 #ifdef __SC__
2169 #pragma segment Perl_yylex
2170 #endif
2171 int
2172 Perl_yylex(pTHX)
2173 {
2174     register char *s;
2175     register char *d;
2176     register I32 tmp;
2177     STRLEN len;
2178     GV *gv = Nullgv;
2179     GV **gvp = 0;
2180     bool bof = FALSE;
2181
2182     /* check if there's an identifier for us to look at */
2183     if (PL_pending_ident)
2184         return S_pending_ident(aTHX);
2185
2186     /* no identifier pending identification */
2187
2188     switch (PL_lex_state) {
2189 #ifdef COMMENTARY
2190     case LEX_NORMAL:            /* Some compilers will produce faster */
2191     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2192         break;
2193 #endif
2194
2195     /* when we've already built the next token, just pull it out of the queue */
2196     case LEX_KNOWNEXT:
2197         PL_nexttoke--;
2198         yylval = PL_nextval[PL_nexttoke];
2199         if (!PL_nexttoke) {
2200             PL_lex_state = PL_lex_defer;
2201             PL_expect = PL_lex_expect;
2202             PL_lex_defer = LEX_NORMAL;
2203         }
2204         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2205               "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2206               (IV)PL_nexttype[PL_nexttoke]); });
2207
2208         return(PL_nexttype[PL_nexttoke]);
2209
2210     /* interpolated case modifiers like \L \U, including \Q and \E.
2211        when we get here, PL_bufptr is at the \
2212     */
2213     case LEX_INTERPCASEMOD:
2214 #ifdef DEBUGGING
2215         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2216             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2217 #endif
2218         /* handle \E or end of string */
2219         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2220             char oldmod;
2221
2222             /* if at a \E */
2223             if (PL_lex_casemods) {
2224                 oldmod = PL_lex_casestack[--PL_lex_casemods];
2225                 PL_lex_casestack[PL_lex_casemods] = '\0';
2226
2227                 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2228                     PL_bufptr += 2;
2229                     PL_lex_state = LEX_INTERPCONCAT;
2230                 }
2231                 return ')';
2232             }
2233             if (PL_bufptr != PL_bufend)
2234                 PL_bufptr += 2;
2235             PL_lex_state = LEX_INTERPCONCAT;
2236             return yylex();
2237         }
2238         else {
2239             DEBUG_T({ PerlIO_printf(Perl_debug_log,
2240               "### Saw case modifier at '%s'\n", PL_bufptr); });
2241             s = PL_bufptr + 1;
2242             if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2243                 tmp = *s, *s = s[2], s[2] = tmp;        /* misordered... */
2244             if (strchr("LU", *s) &&
2245                 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2246             {
2247                 PL_lex_casestack[--PL_lex_casemods] = '\0';
2248                 return ')';
2249             }
2250             if (PL_lex_casemods > 10) {
2251                 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2252                 if (newlb != PL_lex_casestack) {
2253                     SAVEFREEPV(newlb);
2254                     PL_lex_casestack = newlb;
2255                 }
2256             }
2257             PL_lex_casestack[PL_lex_casemods++] = *s;
2258             PL_lex_casestack[PL_lex_casemods] = '\0';
2259             PL_lex_state = LEX_INTERPCONCAT;
2260             PL_nextval[PL_nexttoke].ival = 0;
2261             force_next('(');
2262             if (*s == 'l')
2263                 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2264             else if (*s == 'u')
2265                 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2266             else if (*s == 'L')
2267                 PL_nextval[PL_nexttoke].ival = OP_LC;
2268             else if (*s == 'U')
2269                 PL_nextval[PL_nexttoke].ival = OP_UC;
2270             else if (*s == 'Q')
2271                 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2272             else
2273                 Perl_croak(aTHX_ "panic: yylex");
2274             PL_bufptr = s + 1;
2275             force_next(FUNC);
2276             if (PL_lex_starts) {
2277                 s = PL_bufptr;
2278                 PL_lex_starts = 0;
2279                 Aop(OP_CONCAT);
2280             }
2281             else
2282                 return yylex();
2283         }
2284
2285     case LEX_INTERPPUSH:
2286         return sublex_push();
2287
2288     case LEX_INTERPSTART:
2289         if (PL_bufptr == PL_bufend)
2290             return sublex_done();
2291         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2292               "### Interpolated variable at '%s'\n", PL_bufptr); });
2293         PL_expect = XTERM;
2294         PL_lex_dojoin = (*PL_bufptr == '@');
2295         PL_lex_state = LEX_INTERPNORMAL;
2296         if (PL_lex_dojoin) {
2297             PL_nextval[PL_nexttoke].ival = 0;
2298             force_next(',');
2299 #ifdef USE_5005THREADS
2300             PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2301             PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2302             force_next(PRIVATEREF);
2303 #else
2304             force_ident("\"", '$');
2305 #endif /* USE_5005THREADS */
2306             PL_nextval[PL_nexttoke].ival = 0;
2307             force_next('$');
2308             PL_nextval[PL_nexttoke].ival = 0;
2309             force_next('(');
2310             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2311             force_next(FUNC);
2312         }
2313         if (PL_lex_starts++) {
2314             s = PL_bufptr;
2315             Aop(OP_CONCAT);
2316         }
2317         return yylex();
2318
2319     case LEX_INTERPENDMAYBE:
2320         if (intuit_more(PL_bufptr)) {
2321             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2322             break;
2323         }
2324         /* FALL THROUGH */
2325
2326     case LEX_INTERPEND:
2327         if (PL_lex_dojoin) {
2328             PL_lex_dojoin = FALSE;
2329             PL_lex_state = LEX_INTERPCONCAT;
2330             return ')';
2331         }
2332         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2333             && SvEVALED(PL_lex_repl))
2334         {
2335             if (PL_bufptr != PL_bufend)
2336                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2337             PL_lex_repl = Nullsv;
2338         }
2339         /* FALLTHROUGH */
2340     case LEX_INTERPCONCAT:
2341 #ifdef DEBUGGING
2342         if (PL_lex_brackets)
2343             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2344 #endif
2345         if (PL_bufptr == PL_bufend)
2346             return sublex_done();
2347
2348         if (SvIVX(PL_linestr) == '\'') {
2349             SV *sv = newSVsv(PL_linestr);
2350             if (!PL_lex_inpat)
2351                 sv = tokeq(sv);
2352             else if ( PL_hints & HINT_NEW_RE )
2353                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2354             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2355             s = PL_bufend;
2356         }
2357         else {
2358             s = scan_const(PL_bufptr);
2359             if (*s == '\\')
2360                 PL_lex_state = LEX_INTERPCASEMOD;
2361             else
2362                 PL_lex_state = LEX_INTERPSTART;
2363         }
2364
2365         if (s != PL_bufptr) {
2366             PL_nextval[PL_nexttoke] = yylval;
2367             PL_expect = XTERM;
2368             force_next(THING);
2369             if (PL_lex_starts++)
2370                 Aop(OP_CONCAT);
2371             else {
2372                 PL_bufptr = s;
2373                 return yylex();
2374             }
2375         }
2376
2377         return yylex();
2378     case LEX_FORMLINE:
2379         PL_lex_state = LEX_NORMAL;
2380         s = scan_formline(PL_bufptr);
2381         if (!PL_lex_formbrack)
2382             goto rightbracket;
2383         OPERATOR(';');
2384     }
2385
2386     s = PL_bufptr;
2387     PL_oldoldbufptr = PL_oldbufptr;
2388     PL_oldbufptr = s;
2389     DEBUG_T( {
2390         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2391                       exp_name[PL_expect], s);
2392     } );
2393
2394   retry:
2395     switch (*s) {
2396     default:
2397         if (isIDFIRST_lazy_if(s,UTF))
2398             goto keylookup;
2399         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2400     case 4:
2401     case 26:
2402         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2403     case 0:
2404         if (!PL_rsfp) {
2405             PL_last_uni = 0;
2406             PL_last_lop = 0;
2407             if (PL_lex_brackets)
2408                 yyerror("Missing right curly or square bracket");
2409             DEBUG_T( { PerlIO_printf(Perl_debug_log,
2410                         "### Tokener got EOF\n");
2411             } );
2412             TOKEN(0);
2413         }
2414         if (s++ < PL_bufend)
2415             goto retry;                 /* ignore stray nulls */
2416         PL_last_uni = 0;
2417         PL_last_lop = 0;
2418         if (!PL_in_eval && !PL_preambled) {
2419             PL_preambled = TRUE;
2420             sv_setpv(PL_linestr,incl_perldb());
2421             if (SvCUR(PL_linestr))
2422                 sv_catpv(PL_linestr,";");
2423             if (PL_preambleav){
2424                 while(AvFILLp(PL_preambleav) >= 0) {
2425                     SV *tmpsv = av_shift(PL_preambleav);
2426                     sv_catsv(PL_linestr, tmpsv);
2427                     sv_catpv(PL_linestr, ";");
2428                     sv_free(tmpsv);
2429                 }
2430                 sv_free((SV*)PL_preambleav);
2431                 PL_preambleav = NULL;
2432             }
2433             if (PL_minus_n || PL_minus_p) {
2434                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2435                 if (PL_minus_l)
2436                     sv_catpv(PL_linestr,"chomp;");
2437                 if (PL_minus_a) {
2438                     if (PL_minus_F) {
2439                         if (strchr("/'\"", *PL_splitstr)
2440                               && strchr(PL_splitstr + 1, *PL_splitstr))
2441                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2442                         else {
2443                             char delim;
2444                             s = "'~#\200\1'"; /* surely one char is unused...*/
2445                             while (s[1] && strchr(PL_splitstr, *s))  s++;
2446                             delim = *s;
2447                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2448                                       "q" + (delim == '\''), delim);
2449                             for (s = PL_splitstr; *s; s++) {
2450                                 if (*s == '\\')
2451                                     sv_catpvn(PL_linestr, "\\", 1);
2452                                 sv_catpvn(PL_linestr, s, 1);
2453                             }
2454                             Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2455                         }
2456                     }
2457                     else
2458                         sv_catpv(PL_linestr,"our @F=split(' ');");
2459                 }
2460             }
2461             sv_catpv(PL_linestr, "\n");
2462             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2463             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2464             PL_last_lop = PL_last_uni = Nullch;
2465             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2466                 SV *sv = NEWSV(85,0);
2467
2468                 sv_upgrade(sv, SVt_PVMG);
2469                 sv_setsv(sv,PL_linestr);
2470                 (void)SvIOK_on(sv);
2471                 SvIVX(sv) = 0;
2472                 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2473             }
2474             goto retry;
2475         }
2476         do {
2477             bof = PL_rsfp ? TRUE : FALSE;
2478             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2479               fake_eof:
2480                 if (PL_rsfp) {
2481                     if (PL_preprocess && !PL_in_eval)
2482                         (void)PerlProc_pclose(PL_rsfp);
2483                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2484                         PerlIO_clearerr(PL_rsfp);
2485                     else
2486                         (void)PerlIO_close(PL_rsfp);
2487                     PL_rsfp = Nullfp;
2488                     PL_doextract = FALSE;
2489                 }
2490                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2491                     sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2492                     sv_catpv(PL_linestr,";}");
2493                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2494                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2495                     PL_last_lop = PL_last_uni = Nullch;
2496                     PL_minus_n = PL_minus_p = 0;
2497                     goto retry;
2498                 }
2499                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2500                 PL_last_lop = PL_last_uni = Nullch;
2501                 sv_setpv(PL_linestr,"");
2502                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2503             }
2504             /* if it looks like the start of a BOM, check if it in fact is */
2505             else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2506 #ifdef PERLIO_IS_STDIO
2507 #  ifdef __GNU_LIBRARY__
2508 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2509 #      define FTELL_FOR_PIPE_IS_BROKEN
2510 #    endif
2511 #  else
2512 #    ifdef __GLIBC__
2513 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2514 #        define FTELL_FOR_PIPE_IS_BROKEN
2515 #      endif
2516 #    endif
2517 #  endif
2518 #endif
2519 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2520                 /* This loses the possibility to detect the bof
2521                  * situation on perl -P when the libc5 is being used.
2522                  * Workaround?  Maybe attach some extra state to PL_rsfp?
2523                  */
2524                 if (!PL_preprocess)
2525                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2526 #else
2527                 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2528 #endif
2529                 if (bof) {
2530                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2531                     s = swallow_bom((U8*)s);
2532                 }
2533             }
2534             if (PL_doextract) {
2535                 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2536                     PL_doextract = FALSE;
2537
2538                 /* Incest with pod. */
2539                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2540                     sv_setpv(PL_linestr, "");
2541                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2542                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2543                     PL_last_lop = PL_last_uni = Nullch;
2544                     PL_doextract = FALSE;
2545                 }
2546             }
2547             incline(s);
2548         } while (PL_doextract);
2549         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2550         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2551             SV *sv = NEWSV(85,0);
2552
2553             sv_upgrade(sv, SVt_PVMG);
2554             sv_setsv(sv,PL_linestr);
2555             (void)SvIOK_on(sv);
2556             SvIVX(sv) = 0;
2557             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2558         }
2559         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2560         PL_last_lop = PL_last_uni = Nullch;
2561         if (CopLINE(PL_curcop) == 1) {
2562             while (s < PL_bufend && isSPACE(*s))
2563                 s++;
2564             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2565                 s++;
2566             d = Nullch;
2567             if (!PL_in_eval) {
2568                 if (*s == '#' && *(s+1) == '!')
2569                     d = s + 2;
2570 #ifdef ALTERNATE_SHEBANG
2571                 else {
2572                     static char as[] = ALTERNATE_SHEBANG;
2573                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2574                         d = s + (sizeof(as) - 1);
2575                 }
2576 #endif /* ALTERNATE_SHEBANG */
2577             }
2578             if (d) {
2579                 char *ipath;
2580                 char *ipathend;
2581
2582                 while (isSPACE(*d))
2583                     d++;
2584                 ipath = d;
2585                 while (*d && !isSPACE(*d))
2586                     d++;
2587                 ipathend = d;
2588
2589 #ifdef ARG_ZERO_IS_SCRIPT
2590                 if (ipathend > ipath) {
2591                     /*
2592                      * HP-UX (at least) sets argv[0] to the script name,
2593                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2594                      * at least, set argv[0] to the basename of the Perl
2595                      * interpreter. So, having found "#!", we'll set it right.
2596                      */
2597                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2598                     assert(SvPOK(x) || SvGMAGICAL(x));
2599                     if (sv_eq(x, CopFILESV(PL_curcop))) {
2600                         sv_setpvn(x, ipath, ipathend - ipath);
2601                         SvSETMAGIC(x);
2602                     }
2603                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2604                 }
2605 #endif /* ARG_ZERO_IS_SCRIPT */
2606
2607                 /*
2608                  * Look for options.
2609                  */
2610                 d = instr(s,"perl -");
2611                 if (!d) {
2612                     d = instr(s,"perl");
2613 #if defined(DOSISH)
2614                     /* avoid getting into infinite loops when shebang
2615                      * line contains "Perl" rather than "perl" */
2616                     if (!d) {
2617                         for (d = ipathend-4; d >= ipath; --d) {
2618                             if ((*d == 'p' || *d == 'P')
2619                                 && !ibcmp(d, "perl", 4))
2620                             {
2621                                 break;
2622                             }
2623                         }
2624                         if (d < ipath)
2625                             d = Nullch;
2626                     }
2627 #endif
2628                 }
2629 #ifdef ALTERNATE_SHEBANG
2630                 /*
2631                  * If the ALTERNATE_SHEBANG on this system starts with a
2632                  * character that can be part of a Perl expression, then if
2633                  * we see it but not "perl", we're probably looking at the
2634                  * start of Perl code, not a request to hand off to some
2635                  * other interpreter.  Similarly, if "perl" is there, but
2636                  * not in the first 'word' of the line, we assume the line
2637                  * contains the start of the Perl program.
2638                  */
2639                 if (d && *s != '#') {
2640                     char *c = ipath;
2641                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2642                         c++;
2643                     if (c < d)
2644                         d = Nullch;     /* "perl" not in first word; ignore */
2645                     else
2646                         *s = '#';       /* Don't try to parse shebang line */
2647                 }
2648 #endif /* ALTERNATE_SHEBANG */
2649 #ifndef MACOS_TRADITIONAL
2650                 if (!d &&
2651                     *s == '#' &&
2652                     ipathend > ipath &&
2653                     !PL_minus_c &&
2654                     !instr(s,"indir") &&
2655                     instr(PL_origargv[0],"perl"))
2656                 {
2657                     char **newargv;
2658
2659                     *ipathend = '\0';
2660                     s = ipathend + 1;
2661                     while (s < PL_bufend && isSPACE(*s))
2662                         s++;
2663                     if (s < PL_bufend) {
2664                         Newz(899,newargv,PL_origargc+3,char*);
2665                         newargv[1] = s;
2666                         while (s < PL_bufend && !isSPACE(*s))
2667                             s++;
2668                         *s = '\0';
2669                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2670                     }
2671                     else
2672                         newargv = PL_origargv;
2673                     newargv[0] = ipath;
2674                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2675                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2676                 }
2677 #endif
2678                 if (d) {
2679                     U32 oldpdb = PL_perldb;
2680                     bool oldn = PL_minus_n;
2681                     bool oldp = PL_minus_p;
2682
2683                     while (*d && !isSPACE(*d)) d++;
2684                     while (SPACE_OR_TAB(*d)) d++;
2685
2686                     if (*d++ == '-') {
2687                         bool switches_done = PL_doswitches;
2688                         do {
2689                             if (*d == 'M' || *d == 'm') {
2690                                 char *m = d;
2691                                 while (*d && !isSPACE(*d)) d++;
2692                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2693                                       (int)(d - m), m);
2694                             }
2695                             d = moreswitches(d);
2696                         } while (d);
2697                         if ((PERLDB_LINE && !oldpdb) ||
2698                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2699                               /* if we have already added "LINE: while (<>) {",
2700                                  we must not do it again */
2701                         {
2702                             sv_setpv(PL_linestr, "");
2703                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2704                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2705                             PL_last_lop = PL_last_uni = Nullch;
2706                             PL_preambled = FALSE;
2707                             if (PERLDB_LINE)
2708                                 (void)gv_fetchfile(PL_origfilename);
2709                             goto retry;
2710                         }
2711                         if (PL_doswitches && !switches_done) {
2712                             int argc = PL_origargc;
2713                             char **argv = PL_origargv;
2714                             do {
2715                                 argc--,argv++;
2716                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2717                             init_argv_symbols(argc,argv);
2718                         }
2719                     }
2720                 }
2721             }
2722         }
2723         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2724             PL_bufptr = s;
2725             PL_lex_state = LEX_FORMLINE;
2726             return yylex();
2727         }
2728         goto retry;
2729     case '\r':
2730 #ifdef PERL_STRICT_CR
2731         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2732         Perl_croak(aTHX_
2733       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2734 #endif
2735     case ' ': case '\t': case '\f': case 013:
2736 #ifdef MACOS_TRADITIONAL
2737     case '\312':
2738 #endif
2739         s++;
2740         goto retry;
2741     case '#':
2742     case '\n':
2743         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2744             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2745                 /* handle eval qq[#line 1 "foo"\n ...] */
2746                 CopLINE_dec(PL_curcop);
2747                 incline(s);
2748             }
2749             d = PL_bufend;
2750             while (s < d && *s != '\n')
2751                 s++;
2752             if (s < d)
2753                 s++;
2754             else if (s > d) /* Found by Ilya: feed random input to Perl. */
2755               Perl_croak(aTHX_ "panic: input overflow");
2756             incline(s);
2757             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2758                 PL_bufptr = s;
2759                 PL_lex_state = LEX_FORMLINE;
2760                 return yylex();
2761             }
2762         }
2763         else {
2764             *s = '\0';
2765             PL_bufend = s;
2766         }
2767         goto retry;
2768     case '-':
2769         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2770             I32 ftst = 0;
2771
2772             s++;
2773             PL_bufptr = s;
2774             tmp = *s++;
2775
2776             while (s < PL_bufend && SPACE_OR_TAB(*s))
2777                 s++;
2778
2779             if (strnEQ(s,"=>",2)) {
2780                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2781                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2782                             "### Saw unary minus before =>, forcing word '%s'\n", s);
2783                 } );
2784                 OPERATOR('-');          /* unary minus */
2785             }
2786             PL_last_uni = PL_oldbufptr;
2787             switch (tmp) {
2788             case 'r': ftst = OP_FTEREAD;        break;
2789             case 'w': ftst = OP_FTEWRITE;       break;
2790             case 'x': ftst = OP_FTEEXEC;        break;
2791             case 'o': ftst = OP_FTEOWNED;       break;
2792             case 'R': ftst = OP_FTRREAD;        break;
2793             case 'W': ftst = OP_FTRWRITE;       break;
2794             case 'X': ftst = OP_FTREXEC;        break;
2795             case 'O': ftst = OP_FTROWNED;       break;
2796             case 'e': ftst = OP_FTIS;           break;
2797             case 'z': ftst = OP_FTZERO;         break;
2798             case 's': ftst = OP_FTSIZE;         break;
2799             case 'f': ftst = OP_FTFILE;         break;
2800             case 'd': ftst = OP_FTDIR;          break;
2801             case 'l': ftst = OP_FTLINK;         break;
2802             case 'p': ftst = OP_FTPIPE;         break;
2803             case 'S': ftst = OP_FTSOCK;         break;
2804             case 'u': ftst = OP_FTSUID;         break;
2805             case 'g': ftst = OP_FTSGID;         break;
2806             case 'k': ftst = OP_FTSVTX;         break;
2807             case 'b': ftst = OP_FTBLK;          break;
2808             case 'c': ftst = OP_FTCHR;          break;
2809             case 't': ftst = OP_FTTTY;          break;
2810             case 'T': ftst = OP_FTTEXT;         break;
2811             case 'B': ftst = OP_FTBINARY;       break;
2812             case 'M': case 'A': case 'C':
2813                 gv_fetchpv("\024",TRUE, SVt_PV);
2814                 switch (tmp) {
2815                 case 'M': ftst = OP_FTMTIME;    break;
2816                 case 'A': ftst = OP_FTATIME;    break;
2817                 case 'C': ftst = OP_FTCTIME;    break;
2818                 default:                        break;
2819                 }
2820                 break;
2821             default:
2822                 break;
2823             }
2824             if (ftst) {
2825                 PL_last_lop_op = ftst;
2826                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2827                         "### Saw file test %c\n", (int)ftst);
2828                 } );
2829                 FTST(ftst);
2830             }
2831             else {
2832                 /* Assume it was a minus followed by a one-letter named
2833                  * subroutine call (or a -bareword), then. */
2834                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2835                         "### %c looked like a file test but was not\n",
2836                         (int)ftst);
2837                 } );
2838                 s -= 2;
2839             }
2840         }
2841         tmp = *s++;
2842         if (*s == tmp) {
2843             s++;
2844             if (PL_expect == XOPERATOR)
2845                 TERM(POSTDEC);
2846             else
2847                 OPERATOR(PREDEC);
2848         }
2849         else if (*s == '>') {
2850             s++;
2851             s = skipspace(s);
2852             if (isIDFIRST_lazy_if(s,UTF)) {
2853                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2854                 TOKEN(ARROW);
2855             }
2856             else if (*s == '$')
2857                 OPERATOR(ARROW);
2858             else
2859                 TERM(ARROW);
2860         }
2861         if (PL_expect == XOPERATOR)
2862             Aop(OP_SUBTRACT);
2863         else {
2864             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2865                 check_uni();
2866             OPERATOR('-');              /* unary minus */
2867         }
2868
2869     case '+':
2870         tmp = *s++;
2871         if (*s == tmp) {
2872             s++;
2873             if (PL_expect == XOPERATOR)
2874                 TERM(POSTINC);
2875             else
2876                 OPERATOR(PREINC);
2877         }
2878         if (PL_expect == XOPERATOR)
2879             Aop(OP_ADD);
2880         else {
2881             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2882                 check_uni();
2883             OPERATOR('+');
2884         }
2885
2886     case '*':
2887         if (PL_expect != XOPERATOR) {
2888             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2889             PL_expect = XOPERATOR;
2890             force_ident(PL_tokenbuf, '*');
2891             if (!*PL_tokenbuf)
2892                 PREREF('*');
2893             TERM('*');
2894         }
2895         s++;
2896         if (*s == '*') {
2897             s++;
2898             PWop(OP_POW);
2899         }
2900         Mop(OP_MULTIPLY);
2901
2902     case '%':
2903         if (PL_expect == XOPERATOR) {
2904             ++s;
2905             Mop(OP_MODULO);
2906         }
2907         PL_tokenbuf[0] = '%';
2908         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2909         if (!PL_tokenbuf[1]) {
2910             if (s == PL_bufend)
2911                 yyerror("Final % should be \\% or %name");
2912             PREREF('%');
2913         }
2914         PL_pending_ident = '%';
2915         TERM('%');
2916
2917     case '^':
2918         s++;
2919         BOop(OP_BIT_XOR);
2920     case '[':
2921         PL_lex_brackets++;
2922         /* FALL THROUGH */
2923     case '~':
2924     case ',':
2925         tmp = *s++;
2926         OPERATOR(tmp);
2927     case ':':
2928         if (s[1] == ':') {
2929             len = 0;
2930             goto just_a_word;
2931         }
2932         s++;
2933         switch (PL_expect) {
2934             OP *attrs;
2935         case XOPERATOR:
2936             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2937                 break;
2938             PL_bufptr = s;      /* update in case we back off */
2939             goto grabattrs;
2940         case XATTRBLOCK:
2941             PL_expect = XBLOCK;
2942             goto grabattrs;
2943         case XATTRTERM:
2944             PL_expect = XTERMBLOCK;
2945          grabattrs:
2946             s = skipspace(s);
2947             attrs = Nullop;
2948             while (isIDFIRST_lazy_if(s,UTF)) {
2949                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2950                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2951                     if (tmp < 0) tmp = -tmp;
2952                     switch (tmp) {
2953                     case KEY_or:
2954                     case KEY_and:
2955                     case KEY_for:
2956                     case KEY_unless:
2957                     case KEY_if:
2958                     case KEY_while:
2959                     case KEY_until:
2960                         goto got_attrs;
2961                     default:
2962                         break;
2963                     }
2964                 }
2965                 if (*d == '(') {
2966                     d = scan_str(d,TRUE,TRUE);
2967                     if (!d) {
2968                         /* MUST advance bufptr here to avoid bogus
2969                            "at end of line" context messages from yyerror().
2970                          */
2971                         PL_bufptr = s + len;
2972                         yyerror("Unterminated attribute parameter in attribute list");
2973                         if (attrs)
2974                             op_free(attrs);
2975                         return 0;       /* EOF indicator */
2976                     }
2977                 }
2978                 if (PL_lex_stuff) {
2979                     SV *sv = newSVpvn(s, len);
2980                     sv_catsv(sv, PL_lex_stuff);
2981                     attrs = append_elem(OP_LIST, attrs,
2982                                         newSVOP(OP_CONST, 0, sv));
2983                     SvREFCNT_dec(PL_lex_stuff);
2984                     PL_lex_stuff = Nullsv;
2985                 }
2986                 else {
2987                     if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
2988                         CvLVALUE_on(PL_compcv);
2989                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
2990                         CvLOCKED_on(PL_compcv);
2991                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
2992                         CvMETHOD_on(PL_compcv);
2993 #ifdef USE_ITHREADS
2994       else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "unique", len))
2995                         GvUNIQUE_on(cGVOPx_gv(yylval.opval));
2996 #endif
2997                     /* After we've set the flags, it could be argued that
2998                        we don't need to do the attributes.pm-based setting
2999                        process, and shouldn't bother appending recognized
3000                        flags. To experiment with that, uncomment the
3001                        following "else": */
3002                     else
3003                         attrs = append_elem(OP_LIST, attrs,
3004                                             newSVOP(OP_CONST, 0,
3005                                                     newSVpvn(s, len)));
3006                 }
3007                 s = skipspace(d);
3008                 if (*s == ':' && s[1] != ':')
3009                     s = skipspace(s+1);
3010                 else if (s == d)
3011                     break;      /* require real whitespace or :'s */
3012             }
3013             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3014             if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
3015                 char q = ((*s == '\'') ? '"' : '\'');
3016                 /* If here for an expression, and parsed no attrs, back off. */
3017                 if (tmp == '=' && !attrs) {
3018                     s = PL_bufptr;
3019                     break;
3020                 }
3021                 /* MUST advance bufptr here to avoid bogus "at end of line"
3022                    context messages from yyerror().
3023                  */
3024                 PL_bufptr = s;
3025                 if (!*s)
3026                     yyerror("Unterminated attribute list");
3027                 else
3028                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3029                                       q, *s, q));
3030                 if (attrs)
3031                     op_free(attrs);
3032                 OPERATOR(':');
3033             }
3034         got_attrs:
3035             if (attrs) {
3036                 PL_nextval[PL_nexttoke].opval = attrs;
3037                 force_next(THING);
3038             }
3039             TOKEN(COLONATTR);
3040         }
3041         OPERATOR(':');
3042     case '(':
3043         s++;
3044         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3045             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
3046         else
3047             PL_expect = XTERM;
3048         TOKEN('(');
3049     case ';':
3050         CLINE;
3051         tmp = *s++;
3052         OPERATOR(tmp);
3053     case ')':
3054         tmp = *s++;
3055         s = skipspace(s);
3056         if (*s == '{')
3057             PREBLOCK(tmp);
3058         TERM(tmp);
3059     case ']':
3060         s++;
3061         if (PL_lex_brackets <= 0)
3062             yyerror("Unmatched right square bracket");
3063         else
3064             --PL_lex_brackets;
3065         if (PL_lex_state == LEX_INTERPNORMAL) {
3066             if (PL_lex_brackets == 0) {
3067                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3068                     PL_lex_state = LEX_INTERPEND;
3069             }
3070         }
3071         TERM(']');
3072     case '{':
3073       leftbracket:
3074         s++;
3075         if (PL_lex_brackets > 100) {
3076             char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3077             if (newlb != PL_lex_brackstack) {
3078                 SAVEFREEPV(newlb);
3079                 PL_lex_brackstack = newlb;
3080             }
3081         }
3082         switch (PL_expect) {
3083         case XTERM:
3084             if (PL_lex_formbrack) {
3085                 s--;
3086                 PRETERMBLOCK(DO);
3087             }
3088             if (PL_oldoldbufptr == PL_last_lop)
3089                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3090             else
3091                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3092             OPERATOR(HASHBRACK);
3093         case XOPERATOR:
3094             while (s < PL_bufend && SPACE_OR_TAB(*s))
3095                 s++;
3096             d = s;
3097             PL_tokenbuf[0] = '\0';
3098             if (d < PL_bufend && *d == '-') {
3099                 PL_tokenbuf[0] = '-';
3100                 d++;
3101                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3102                     d++;
3103             }
3104             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3105                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3106                               FALSE, &len);
3107                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3108                     d++;
3109                 if (*d == '}') {
3110                     char minus = (PL_tokenbuf[0] == '-');
3111                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3112                     if (minus)
3113                         force_next('-');
3114                 }
3115             }
3116             /* FALL THROUGH */
3117         case XATTRBLOCK:
3118         case XBLOCK:
3119             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3120             PL_expect = XSTATE;
3121             break;
3122         case XATTRTERM:
3123         case XTERMBLOCK:
3124             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3125             PL_expect = XSTATE;
3126             break;
3127         default: {
3128                 char *t;
3129                 if (PL_oldoldbufptr == PL_last_lop)
3130                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3131                 else
3132                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3133                 s = skipspace(s);
3134                 if (*s == '}') {
3135                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3136                         PL_expect = XTERM;
3137                         /* This hack is to get the ${} in the message. */
3138                         PL_bufptr = s+1;
3139                         yyerror("syntax error");
3140                         break;
3141                     }
3142                     OPERATOR(HASHBRACK);
3143                 }
3144                 /* This hack serves to disambiguate a pair of curlies
3145                  * as being a block or an anon hash.  Normally, expectation
3146                  * determines that, but in cases where we're not in a
3147                  * position to expect anything in particular (like inside
3148                  * eval"") we have to resolve the ambiguity.  This code
3149                  * covers the case where the first term in the curlies is a
3150                  * quoted string.  Most other cases need to be explicitly
3151                  * disambiguated by prepending a `+' before the opening
3152                  * curly in order to force resolution as an anon hash.
3153                  *
3154                  * XXX should probably propagate the outer expectation
3155                  * into eval"" to rely less on this hack, but that could
3156                  * potentially break current behavior of eval"".
3157                  * GSAR 97-07-21
3158                  */
3159                 t = s;
3160                 if (*s == '\'' || *s == '"' || *s == '`') {
3161                     /* common case: get past first string, handling escapes */
3162                     for (t++; t < PL_bufend && *t != *s;)
3163                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3164                             t++;
3165                     t++;
3166                 }
3167                 else if (*s == 'q') {
3168                     if (++t < PL_bufend
3169                         && (!isALNUM(*t)
3170                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3171                                 && !isALNUM(*t))))
3172                     {
3173                         char *tmps;
3174                         char open, close, term;
3175                         I32 brackets = 1;
3176
3177                         while (t < PL_bufend && isSPACE(*t))
3178                             t++;
3179                         term = *t;
3180                         open = term;
3181                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3182                             term = tmps[5];
3183                         close = term;
3184                         if (open == close)
3185                             for (t++; t < PL_bufend; t++) {
3186                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3187                                     t++;
3188                                 else if (*t == open)
3189                                     break;
3190                             }
3191                         else
3192                             for (t++; t < PL_bufend; t++) {
3193                                 if (*t == '\\' && t+1 < PL_bufend)
3194                                     t++;
3195                                 else if (*t == close && --brackets <= 0)
3196                                     break;
3197                                 else if (*t == open)
3198                                     brackets++;
3199                             }
3200                     }
3201                     t++;
3202                 }
3203                 else if (isALNUM_lazy_if(t,UTF)) {
3204                     t += UTF8SKIP(t);
3205                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3206                          t += UTF8SKIP(t);
3207                 }
3208                 while (t < PL_bufend && isSPACE(*t))
3209                     t++;
3210                 /* if comma follows first term, call it an anon hash */
3211                 /* XXX it could be a comma expression with loop modifiers */
3212                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3213                                    || (*t == '=' && t[1] == '>')))
3214                     OPERATOR(HASHBRACK);
3215                 if (PL_expect == XREF)
3216                     PL_expect = XTERM;
3217                 else {
3218                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3219                     PL_expect = XSTATE;
3220                 }
3221             }
3222             break;
3223         }
3224         yylval.ival = CopLINE(PL_curcop);
3225         if (isSPACE(*s) || *s == '#')
3226             PL_copline = NOLINE;   /* invalidate current command line number */
3227         TOKEN('{');
3228     case '}':
3229       rightbracket:
3230         s++;
3231         if (PL_lex_brackets <= 0)
3232             yyerror("Unmatched right curly bracket");
3233         else
3234             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3235         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3236             PL_lex_formbrack = 0;
3237         if (PL_lex_state == LEX_INTERPNORMAL) {
3238             if (PL_lex_brackets == 0) {
3239                 if (PL_expect & XFAKEBRACK) {
3240                     PL_expect &= XENUMMASK;
3241                     PL_lex_state = LEX_INTERPEND;
3242                     PL_bufptr = s;
3243                     return yylex();     /* ignore fake brackets */
3244                 }
3245                 if (*s == '-' && s[1] == '>')
3246                     PL_lex_state = LEX_INTERPENDMAYBE;
3247                 else if (*s != '[' && *s != '{')
3248                     PL_lex_state = LEX_INTERPEND;
3249             }
3250         }
3251         if (PL_expect & XFAKEBRACK) {
3252             PL_expect &= XENUMMASK;
3253             PL_bufptr = s;
3254             return yylex();             /* ignore fake brackets */
3255         }
3256         force_next('}');
3257         TOKEN(';');
3258     case '&':
3259         s++;
3260         tmp = *s++;
3261         if (tmp == '&')
3262             AOPERATOR(ANDAND);
3263         s--;
3264         if (PL_expect == XOPERATOR) {
3265             if (ckWARN(WARN_SEMICOLON)
3266                 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3267             {
3268                 CopLINE_dec(PL_curcop);
3269                 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3270                 CopLINE_inc(PL_curcop);
3271             }
3272             BAop(OP_BIT_AND);
3273         }
3274
3275         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3276         if (*PL_tokenbuf) {
3277             PL_expect = XOPERATOR;
3278             force_ident(PL_tokenbuf, '&');
3279         }
3280         else
3281             PREREF('&');
3282         yylval.ival = (OPpENTERSUB_AMPER<<8);
3283         TERM('&');
3284
3285     case '|':
3286         s++;
3287         tmp = *s++;
3288         if (tmp == '|')
3289             AOPERATOR(OROR);
3290         s--;
3291         BOop(OP_BIT_OR);
3292     case '=':
3293         s++;
3294         tmp = *s++;
3295         if (tmp == '=')
3296             Eop(OP_EQ);
3297         if (tmp == '>')
3298             OPERATOR(',');
3299         if (tmp == '~')
3300             PMop(OP_MATCH);
3301         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3302             Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3303         s--;
3304         if (PL_expect == XSTATE && isALPHA(tmp) &&
3305                 (s == PL_linestart+1 || s[-2] == '\n') )
3306         {
3307             if (PL_in_eval && !PL_rsfp) {
3308                 d = PL_bufend;
3309                 while (s < d) {
3310                     if (*s++ == '\n') {
3311                         incline(s);
3312                         if (strnEQ(s,"=cut",4)) {
3313                             s = strchr(s,'\n');
3314                             if (s)
3315                                 s++;
3316                             else
3317                                 s = d;
3318                             incline(s);
3319                             goto retry;
3320                         }
3321                     }
3322                 }
3323                 goto retry;
3324             }
3325             s = PL_bufend;
3326             PL_doextract = TRUE;
3327             goto retry;
3328         }
3329         if (PL_lex_brackets < PL_lex_formbrack) {
3330             char *t;
3331 #ifdef PERL_STRICT_CR
3332             for (t = s; SPACE_OR_TAB(*t); t++) ;
3333 #else
3334             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3335 #endif
3336             if (*t == '\n' || *t == '#') {
3337                 s--;
3338                 PL_expect = XBLOCK;
3339                 goto leftbracket;
3340             }
3341         }
3342         yylval.ival = 0;
3343         OPERATOR(ASSIGNOP);
3344     case '!':
3345         s++;
3346         tmp = *s++;
3347         if (tmp == '=')
3348             Eop(OP_NE);
3349         if (tmp == '~')
3350             PMop(OP_NOT);
3351         s--;
3352         OPERATOR('!');
3353     case '<':
3354         if (PL_expect != XOPERATOR) {
3355             if (s[1] != '<' && !strchr(s,'>'))
3356                 check_uni();
3357             if (s[1] == '<')
3358                 s = scan_heredoc(s);
3359             else
3360                 s = scan_inputsymbol(s);
3361             TERM(sublex_start());
3362         }
3363         s++;
3364         tmp = *s++;
3365         if (tmp == '<')
3366             SHop(OP_LEFT_SHIFT);
3367         if (tmp == '=') {
3368             tmp = *s++;
3369             if (tmp == '>')
3370                 Eop(OP_NCMP);
3371             s--;
3372             Rop(OP_LE);
3373         }
3374         s--;
3375         Rop(OP_LT);
3376     case '>':
3377         s++;
3378         tmp = *s++;
3379         if (tmp == '>')
3380             SHop(OP_RIGHT_SHIFT);
3381         if (tmp == '=')
3382             Rop(OP_GE);
3383         s--;
3384         Rop(OP_GT);
3385
3386     case '$':
3387         CLINE;
3388
3389         if (PL_expect == XOPERATOR) {
3390             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3391                 PL_expect = XTERM;
3392                 depcom();
3393                 return ','; /* grandfather non-comma-format format */
3394             }
3395         }
3396
3397         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3398             PL_tokenbuf[0] = '@';
3399             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3400                            sizeof PL_tokenbuf - 1, FALSE);
3401             if (PL_expect == XOPERATOR)
3402                 no_op("Array length", s);
3403             if (!PL_tokenbuf[1])
3404                 PREREF(DOLSHARP);
3405             PL_expect = XOPERATOR;
3406             PL_pending_ident = '#';
3407             TOKEN(DOLSHARP);
3408         }
3409
3410         PL_tokenbuf[0] = '$';
3411         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3412                        sizeof PL_tokenbuf - 1, FALSE);
3413         if (PL_expect == XOPERATOR)
3414             no_op("Scalar", s);
3415         if (!PL_tokenbuf[1]) {
3416             if (s == PL_bufend)
3417                 yyerror("Final $ should be \\$ or $name");
3418             PREREF('$');
3419         }
3420
3421         /* This kludge not intended to be bulletproof. */
3422         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3423             yylval.opval = newSVOP(OP_CONST, 0,
3424                                    newSViv(PL_compiling.cop_arybase));
3425             yylval.opval->op_private = OPpCONST_ARYBASE;
3426             TERM(THING);
3427         }
3428
3429         d = s;
3430         tmp = (I32)*s;
3431         if (PL_lex_state == LEX_NORMAL)
3432             s = skipspace(s);
3433
3434         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3435             char *t;
3436             if (*s == '[') {
3437                 PL_tokenbuf[0] = '@';
3438                 if (ckWARN(WARN_SYNTAX)) {
3439                     for(t = s + 1;
3440                         isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3441                         t++) ;
3442                     if (*t++ == ',') {
3443                         PL_bufptr = skipspace(PL_bufptr);
3444                         while (t < PL_bufend && *t != ']')
3445                             t++;
3446                         Perl_warner(aTHX_ WARN_SYNTAX,
3447                                 "Multidimensional syntax %.*s not supported",
3448                                 (t - PL_bufptr) + 1, PL_bufptr);
3449                     }
3450                 }
3451             }
3452             else if (*s == '{') {
3453                 PL_tokenbuf[0] = '%';
3454                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3455                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3456                 {
3457                     char tmpbuf[sizeof PL_tokenbuf];
3458                     STRLEN len;
3459                     for (t++; isSPACE(*t); t++) ;
3460                     if (isIDFIRST_lazy_if(t,UTF)) {
3461                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3462                         for (; isSPACE(*t); t++) ;
3463                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3464                             Perl_warner(aTHX_ WARN_SYNTAX,
3465                                 "You need to quote \"%s\"", tmpbuf);
3466                     }
3467                 }
3468             }
3469         }
3470
3471         PL_expect = XOPERATOR;
3472         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3473             bool islop = (PL_last_lop == PL_oldoldbufptr);
3474             if (!islop || PL_last_lop_op == OP_GREPSTART)
3475                 PL_expect = XOPERATOR;
3476             else if (strchr("$@\"'`q", *s))
3477                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3478             else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3479                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3480             else if (isIDFIRST_lazy_if(s,UTF)) {
3481                 char tmpbuf[sizeof PL_tokenbuf];
3482                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3483                 if ((tmp = keyword(tmpbuf, len))) {
3484                     /* binary operators exclude handle interpretations */
3485                     switch (tmp) {
3486                     case -KEY_x:
3487                     case -KEY_eq:
3488                     case -KEY_ne:
3489                     case -KEY_gt:
3490                     case -KEY_lt:
3491                     case -KEY_ge:
3492                     case -KEY_le:
3493                     case -KEY_cmp:
3494                         break;
3495                     default:
3496                         PL_expect = XTERM;      /* e.g. print $fh length() */
3497                         break;
3498                     }
3499                 }
3500                 else {
3501                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3502                     if (gv && GvCVu(gv))
3503                         PL_expect = XTERM;      /* e.g. print $fh subr() */
3504                 }
3505             }
3506             else if (isDIGIT(*s))
3507                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3508             else if (*s == '.' && isDIGIT(s[1]))
3509                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3510             else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3511                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3512             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3513                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3514         }
3515         PL_pending_ident = '$';
3516         TOKEN('$');
3517
3518     case '@':
3519         if (PL_expect == XOPERATOR)
3520             no_op("Array", s);
3521         PL_tokenbuf[0] = '@';
3522         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3523         if (!PL_tokenbuf[1]) {
3524             if (s == PL_bufend)
3525                 yyerror("Final @ should be \\@ or @name");
3526             PREREF('@');
3527         }
3528         if (PL_lex_state == LEX_NORMAL)
3529             s = skipspace(s);
3530         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3531             if (*s == '{')
3532                 PL_tokenbuf[0] = '%';
3533
3534             /* Warn about @ where they meant $. */
3535             if (ckWARN(WARN_SYNTAX)) {
3536                 if (*s == '[' || *s == '{') {
3537                     char *t = s + 1;
3538                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3539                         t++;
3540                     if (*t == '}' || *t == ']') {
3541                         t++;
3542                         PL_bufptr = skipspace(PL_bufptr);
3543                         Perl_warner(aTHX_ WARN_SYNTAX,
3544                             "Scalar value %.*s better written as $%.*s",
3545                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3546                     }
3547                 }
3548             }
3549         }
3550         PL_pending_ident = '@';
3551         TERM('@');
3552
3553     case '/':                   /* may either be division or pattern */
3554     case '?':                   /* may either be conditional or pattern */
3555         if (PL_expect != XOPERATOR) {
3556             /* Disable warning on "study /blah/" */
3557             if (PL_oldoldbufptr == PL_last_uni
3558                 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3559                     || memNE(PL_last_uni, "study", 5)
3560                     || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3561                 check_uni();
3562             s = scan_pat(s,OP_MATCH);
3563             TERM(sublex_start());
3564         }
3565         tmp = *s++;
3566         if (tmp == '/')
3567             Mop(OP_DIVIDE);
3568         OPERATOR(tmp);
3569
3570     case '.':
3571         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3572 #ifdef PERL_STRICT_CR
3573             && s[1] == '\n'
3574 #else
3575             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3576 #endif
3577             && (s == PL_linestart || s[-1] == '\n') )
3578         {
3579             PL_lex_formbrack = 0;
3580             PL_expect = XSTATE;
3581             goto rightbracket;
3582         }
3583         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3584             tmp = *s++;
3585             if (*s == tmp) {
3586                 s++;
3587                 if (*s == tmp) {
3588                     s++;
3589                     yylval.ival = OPf_SPECIAL;
3590                 }
3591                 else
3592                     yylval.ival = 0;
3593                 OPERATOR(DOTDOT);
3594             }
3595             if (PL_expect != XOPERATOR)
3596                 check_uni();
3597             Aop(OP_CONCAT);
3598         }
3599         /* FALL THROUGH */
3600     case '0': case '1': case '2': case '3': case '4':
3601     case '5': case '6': case '7': case '8': case '9':
3602         s = scan_num(s, &yylval);
3603         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3604                     "### Saw number in '%s'\n", s);
3605         } );
3606         if (PL_expect == XOPERATOR)
3607             no_op("Number",s);
3608         TERM(THING);
3609
3610     case '\'':
3611         s = scan_str(s,FALSE,FALSE);
3612         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3613                     "### Saw string before '%s'\n", s);
3614         } );
3615         if (PL_expect == XOPERATOR) {
3616             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3617                 PL_expect = XTERM;
3618                 depcom();
3619                 return ',';     /* grandfather non-comma-format format */
3620             }
3621             else
3622                 no_op("String",s);
3623         }
3624         if (!s)
3625             missingterm((char*)0);
3626         yylval.ival = OP_CONST;
3627         TERM(sublex_start());
3628
3629     case '"':
3630         s = scan_str(s,FALSE,FALSE);
3631         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3632                     "### Saw string before '%s'\n", s);
3633         } );
3634         if (PL_expect == XOPERATOR) {
3635             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3636                 PL_expect = XTERM;
3637                 depcom();
3638                 return ',';     /* grandfather non-comma-format format */
3639             }
3640             else
3641                 no_op("String",s);
3642         }
3643         if (!s)
3644             missingterm((char*)0);
3645         yylval.ival = OP_CONST;
3646         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3647             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3648                 yylval.ival = OP_STRINGIFY;
3649                 break;
3650             }
3651         }
3652         TERM(sublex_start());
3653
3654     case '`':
3655         s = scan_str(s,FALSE,FALSE);
3656         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3657                     "### Saw backtick string before '%s'\n", s);
3658         } );
3659         if (PL_expect == XOPERATOR)
3660             no_op("Backticks",s);
3661         if (!s)
3662             missingterm((char*)0);
3663         yylval.ival = OP_BACKTICK;
3664         set_csh();
3665         TERM(sublex_start());
3666
3667     case '\\':
3668         s++;
3669         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3670             Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3671                         *s, *s);
3672         if (PL_expect == XOPERATOR)
3673             no_op("Backslash",s);
3674         OPERATOR(REFGEN);
3675
3676     case 'v':
3677         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3678             char *start = s;
3679             start++;
3680             start++;
3681             while (isDIGIT(*start) || *start == '_')
3682                 start++;
3683             if (*start == '.' && isDIGIT(start[1])) {
3684                 s = scan_num(s, &yylval);
3685                 TERM(THING);
3686             }
3687             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3688             else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
3689                 char c = *start;
3690                 GV *gv;
3691                 *start = '\0';
3692                 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3693                 *start = c;
3694                 if (!gv) {
3695                     s = scan_num(s, &yylval);
3696                     TERM(THING);
3697                 }
3698             }
3699         }
3700         goto keylookup;
3701     case 'x':
3702         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3703             s++;
3704             Mop(OP_REPEAT);
3705         }
3706         goto keylookup;
3707
3708     case '_':
3709     case 'a': case 'A':
3710     case 'b': case 'B':
3711     case 'c': case 'C':
3712     case 'd': case 'D':
3713     case 'e': case 'E':
3714     case 'f': case 'F':
3715     case 'g': case 'G':
3716     case 'h': case 'H':
3717     case 'i': case 'I':
3718     case 'j': case 'J':
3719     case 'k': case 'K':
3720     case 'l': case 'L':
3721     case 'm': case 'M':
3722     case 'n': case 'N':
3723     case 'o': case 'O':
3724     case 'p': case 'P':
3725     case 'q': case 'Q':
3726     case 'r': case 'R':
3727     case 's': case 'S':
3728     case 't': case 'T':
3729     case 'u': case 'U':
3730               case 'V':
3731     case 'w': case 'W':
3732               case 'X':
3733     case 'y': case 'Y':
3734     case 'z': case 'Z':
3735
3736       keylookup: {
3737         gv = Nullgv;
3738         gvp = 0;
3739
3740         PL_bufptr = s;
3741         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3742
3743         /* Some keywords can be followed by any delimiter, including ':' */
3744         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3745                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3746                              (PL_tokenbuf[0] == 'q' &&
3747                               strchr("qwxr", PL_tokenbuf[1])))));
3748
3749         /* x::* is just a word, unless x is "CORE" */
3750         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3751             goto just_a_word;
3752
3753         d = s;
3754         while (d < PL_bufend && isSPACE(*d))
3755                 d++;    /* no comments skipped here, or s### is misparsed */
3756
3757         /* Is this a label? */
3758         if (!tmp && PL_expect == XSTATE
3759               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3760             s = d + 1;
3761             yylval.pval = savepv(PL_tokenbuf);
3762             CLINE;
3763             TOKEN(LABEL);
3764         }
3765
3766         /* Check for keywords */
3767         tmp = keyword(PL_tokenbuf, len);
3768
3769         /* Is this a word before a => operator? */
3770         if (*d == '=' && d[1] == '>') {
3771             CLINE;
3772             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3773             yylval.opval->op_private = OPpCONST_BARE;
3774             if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3775               SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3776             TERM(WORD);
3777         }
3778
3779         if (tmp < 0) {                  /* second-class keyword? */
3780             GV *ogv = Nullgv;   /* override (winner) */
3781             GV *hgv = Nullgv;   /* hidden (loser) */
3782             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3783                 CV *cv;
3784                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3785                     (cv = GvCVu(gv)))
3786                 {
3787                     if (GvIMPORTED_CV(gv))
3788                         ogv = gv;
3789                     else if (! CvMETHOD(cv))
3790                         hgv = gv;
3791                 }
3792                 if (!ogv &&
3793                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3794                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3795                     GvCVu(gv) && GvIMPORTED_CV(gv))
3796                 {
3797                     ogv = gv;
3798                 }
3799             }
3800             if (ogv) {
3801                 tmp = 0;                /* overridden by import or by GLOBAL */
3802             }
3803             else if (gv && !gvp
3804                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3805                      && GvCVu(gv)
3806                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3807             {
3808                 tmp = 0;                /* any sub overrides "weak" keyword */
3809             }
3810             else {                      /* no override */
3811                 tmp = -tmp;
3812                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
3813                     Perl_warner(aTHX_ WARN_MISC,
3814                             "dump() better written as CORE::dump()");
3815                 }
3816                 gv = Nullgv;
3817                 gvp = 0;
3818                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3819                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3820                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3821                         "Ambiguous call resolved as CORE::%s(), %s",
3822                          GvENAME(hgv), "qualify as such or use &");
3823             }
3824         }
3825
3826       reserved_word:
3827         switch (tmp) {
3828
3829         default:                        /* not a keyword */
3830           just_a_word: {
3831                 SV *sv;
3832                 int pkgname = 0;
3833                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3834
3835                 /* Get the rest if it looks like a package qualifier */
3836
3837                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3838                     STRLEN morelen;
3839                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3840                                   TRUE, &morelen);
3841                     if (!morelen)
3842                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3843                                 *s == '\'' ? "'" : "::");
3844                     len += morelen;
3845                     pkgname = 1;
3846                 }
3847
3848                 if (PL_expect == XOPERATOR) {
3849                     if (PL_bufptr == PL_linestart) {
3850                         CopLINE_dec(PL_curcop);
3851                         Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3852                         CopLINE_inc(PL_curcop);
3853                     }
3854                     else
3855                         no_op("Bareword",s);
3856                 }
3857
3858                 /* Look for a subroutine with this name in current package,
3859                    unless name is "Foo::", in which case Foo is a bearword
3860                    (and a package name). */
3861
3862                 if (len > 2 &&
3863                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3864                 {
3865                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3866                         Perl_warner(aTHX_ WARN_BAREWORD,
3867                             "Bareword \"%s\" refers to nonexistent package",
3868                              PL_tokenbuf);
3869                     len -= 2;
3870                     PL_tokenbuf[len] = '\0';
3871                     gv = Nullgv;
3872                     gvp = 0;
3873                 }
3874                 else {
3875                     len = 0;
3876                     if (!gv)
3877                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3878                 }
3879
3880                 /* if we saw a global override before, get the right name */
3881
3882                 if (gvp) {
3883                     sv = newSVpvn("CORE::GLOBAL::",14);
3884                     sv_catpv(sv,PL_tokenbuf);
3885                 }
3886                 else
3887                     sv = newSVpv(PL_tokenbuf,0);
3888
3889                 /* Presume this is going to be a bareword of some sort. */
3890
3891                 CLINE;
3892                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3893                 yylval.opval->op_private = OPpCONST_BARE;
3894
3895                 /* And if "Foo::", then that's what it certainly is. */
3896
3897                 if (len)
3898                     goto safe_bareword;
3899
3900                 /* See if it's the indirect object for a list operator. */
3901
3902                 if (PL_oldoldbufptr &&
3903                     PL_oldoldbufptr < PL_bufptr &&
3904                     (PL_oldoldbufptr == PL_last_lop
3905                      || PL_oldoldbufptr == PL_last_uni) &&
3906                     /* NO SKIPSPACE BEFORE HERE! */
3907                     (PL_expect == XREF ||
3908                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3909                 {
3910                     bool immediate_paren = *s == '(';
3911
3912                     /* (Now we can afford to cross potential line boundary.) */
3913                     s = skipspace(s);
3914
3915                     /* Two barewords in a row may indicate method call. */
3916
3917                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3918                         return tmp;
3919
3920                     /* If not a declared subroutine, it's an indirect object. */
3921                     /* (But it's an indir obj regardless for sort.) */
3922
3923                     if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
3924                          ((!gv || !GvCVu(gv)) &&
3925                         (PL_last_lop_op != OP_MAPSTART &&
3926                          PL_last_lop_op != OP_GREPSTART))))
3927                     {
3928                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3929                         goto bareword;
3930                     }
3931                 }
3932
3933                 PL_expect = XOPERATOR;
3934                 s = skipspace(s);
3935
3936                 /* Is this a word before a => operator? */
3937                 if (*s == '=' && s[1] == '>' && !pkgname) {
3938                     CLINE;
3939                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
3940                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3941                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3942                     TERM(WORD);
3943                 }
3944
3945                 /* If followed by a paren, it's certainly a subroutine. */
3946                 if (*s == '(') {
3947                     CLINE;
3948                     if (gv && GvCVu(gv)) {
3949                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
3950                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3951                             s = d + 1;
3952                             goto its_constant;
3953                         }
3954                     }
3955                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3956                     PL_expect = XOPERATOR;
3957                     force_next(WORD);
3958                     yylval.ival = 0;
3959                     TOKEN('&');
3960                 }
3961
3962                 /* If followed by var or block, call it a method (unless sub) */
3963
3964                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3965                     PL_last_lop = PL_oldbufptr;
3966                     PL_last_lop_op = OP_METHOD;
3967                     PREBLOCK(METHOD);
3968                 }
3969
3970                 /* If followed by a bareword, see if it looks like indir obj. */
3971
3972                 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3973                     return tmp;
3974
3975                 /* Not a method, so call it a subroutine (if defined) */
3976
3977                 if (gv && GvCVu(gv)) {
3978                     CV* cv;
3979                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3980                         Perl_warner(aTHX_ WARN_AMBIGUOUS,
3981                                 "Ambiguous use of -%s resolved as -&%s()",
3982                                 PL_tokenbuf, PL_tokenbuf);
3983                     /* Check for a constant sub */
3984                     cv = GvCV(gv);
3985                     if ((sv = cv_const_sv(cv))) {
3986                   its_constant:
3987                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3988                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3989                         yylval.opval->op_private = 0;
3990                         TOKEN(WORD);
3991                     }
3992
3993                     /* Resolve to GV now. */
3994                     op_free(yylval.opval);
3995                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3996                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3997                     PL_last_lop = PL_oldbufptr;
3998                     PL_last_lop_op = OP_ENTERSUB;
3999                     /* Is there a prototype? */
4000                     if (SvPOK(cv)) {
4001                         STRLEN len;
4002                         char *proto = SvPV((SV*)cv, len);
4003                         if (!len)
4004                             TERM(FUNC0SUB);
4005                         if (strEQ(proto, "$"))
4006                             OPERATOR(UNIOPSUB);
4007                         if (*proto == '&' && *s == '{') {
4008                             sv_setpv(PL_subname,"__ANON__");
4009                             PREBLOCK(LSTOPSUB);
4010                         }
4011                     }
4012                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4013                     PL_expect = XTERM;
4014                     force_next(WORD);
4015                     TOKEN(NOAMP);
4016                 }
4017
4018                 /* Call it a bare word */
4019
4020                 if (PL_hints & HINT_STRICT_SUBS)
4021                     yylval.opval->op_private |= OPpCONST_STRICT;
4022                 else {
4023                 bareword:
4024                     if (ckWARN(WARN_RESERVED)) {
4025                         if (lastchar != '-') {
4026                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4027                             if (!*d && strNE(PL_tokenbuf,"main"))
4028                                 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
4029                                        PL_tokenbuf);
4030                         }
4031                     }
4032                 }
4033
4034             safe_bareword:
4035                 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4036                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
4037                         "Operator or semicolon missing before %c%s",
4038                         lastchar, PL_tokenbuf);
4039                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
4040                         "Ambiguous use of %c resolved as operator %c",
4041                         lastchar, lastchar);
4042                 }
4043                 TOKEN(WORD);
4044             }
4045
4046         case KEY___FILE__:
4047             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4048                                         newSVpv(CopFILE(PL_curcop),0));
4049             TERM(THING);
4050
4051         case KEY___LINE__:
4052             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4053                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4054             TERM(THING);
4055
4056         case KEY___PACKAGE__:
4057             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4058                                         (PL_curstash
4059                                          ? newSVsv(PL_curstname)
4060                                          : &PL_sv_undef));
4061             TERM(THING);
4062
4063         case KEY___DATA__:
4064         case KEY___END__: {
4065             GV *gv;
4066
4067             /*SUPPRESS 560*/
4068             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4069                 char *pname = "main";
4070                 if (PL_tokenbuf[2] == 'D')
4071                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4072                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4073                 GvMULTI_on(gv);
4074                 if (!GvIO(gv))
4075                     GvIOp(gv) = newIO();
4076                 IoIFP(GvIOp(gv)) = PL_rsfp;
4077 #if defined(HAS_FCNTL) && defined(F_SETFD)
4078                 {
4079                     int fd = PerlIO_fileno(PL_rsfp);
4080                     fcntl(fd,F_SETFD,fd >= 3);
4081                 }
4082 #endif
4083                 /* Mark this internal pseudo-handle as clean */
4084                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4085                 if (PL_preprocess)
4086                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4087                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4088                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4089                 else
4090                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4091 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4092                 /* if the script was opened in binmode, we need to revert
4093                  * it to text mode for compatibility; but only iff it has CRs
4094                  * XXX this is a questionable hack at best. */
4095                 if (PL_bufend-PL_bufptr > 2
4096                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4097                 {
4098                     Off_t loc = 0;
4099                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4100                         loc = PerlIO_tell(PL_rsfp);
4101                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
4102                     }
4103 #ifdef NETWARE
4104                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4105 #else
4106                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4107 #endif  /* NETWARE */
4108 #ifdef PERLIO_IS_STDIO /* really? */
4109 #  if defined(__BORLANDC__)
4110                         /* XXX see note in do_binmode() */
4111                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4112 #  endif
4113 #endif
4114                         if (loc > 0)
4115                             PerlIO_seek(PL_rsfp, loc, 0);
4116                     }
4117                 }
4118 #endif
4119 #ifdef PERLIO_LAYERS
4120                 if (UTF && !IN_BYTES)
4121                     PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4122 #endif
4123                 PL_rsfp = Nullfp;
4124             }
4125             goto fake_eof;
4126         }
4127
4128         case KEY_AUTOLOAD:
4129         case KEY_DESTROY:
4130         case KEY_BEGIN:
4131         case KEY_CHECK:
4132         case KEY_INIT:
4133         case KEY_END:
4134             if (PL_expect == XSTATE) {
4135                 s = PL_bufptr;
4136                 goto really_sub;
4137             }
4138             goto just_a_word;
4139
4140         case KEY_CORE:
4141             if (*s == ':' && s[1] == ':') {
4142                 s += 2;
4143                 d = s;
4144                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4145                 if (!(tmp = keyword(PL_tokenbuf, len)))
4146                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4147                 if (tmp < 0)
4148                     tmp = -tmp;
4149                 goto reserved_word;
4150             }
4151             goto just_a_word;
4152
4153         case KEY_abs:
4154             UNI(OP_ABS);
4155
4156         case KEY_alarm:
4157             UNI(OP_ALARM);
4158
4159         case KEY_accept:
4160             LOP(OP_ACCEPT,XTERM);
4161
4162         case KEY_and:
4163             OPERATOR(ANDOP);
4164
4165         case KEY_atan2:
4166             LOP(OP_ATAN2,XTERM);
4167
4168         case KEY_bind:
4169             LOP(OP_BIND,XTERM);
4170
4171         case KEY_binmode:
4172             LOP(OP_BINMODE,XTERM);
4173
4174         case KEY_bless:
4175             LOP(OP_BLESS,XTERM);
4176
4177         case KEY_chop:
4178             UNI(OP_CHOP);
4179
4180         case KEY_continue:
4181             PREBLOCK(CONTINUE);
4182
4183         case KEY_chdir:
4184             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
4185             UNI(OP_CHDIR);
4186
4187         case KEY_close:
4188             UNI(OP_CLOSE);
4189
4190         case KEY_closedir:
4191             UNI(OP_CLOSEDIR);
4192
4193         case KEY_cmp:
4194             Eop(OP_SCMP);
4195
4196         case KEY_caller:
4197             UNI(OP_CALLER);
4198
4199         case KEY_crypt:
4200 #ifdef FCRYPT
4201             if (!PL_cryptseen) {
4202                 PL_cryptseen = TRUE;
4203                 init_des();
4204             }
4205 #endif
4206             LOP(OP_CRYPT,XTERM);
4207
4208         case KEY_chmod:
4209             LOP(OP_CHMOD,XTERM);
4210
4211         case KEY_chown:
4212             LOP(OP_CHOWN,XTERM);
4213
4214         case KEY_connect:
4215             LOP(OP_CONNECT,XTERM);
4216
4217         case KEY_chr:
4218             UNI(OP_CHR);
4219
4220         case KEY_cos:
4221             UNI(OP_COS);
4222
4223         case KEY_chroot:
4224             UNI(OP_CHROOT);
4225
4226         case KEY_do:
4227             s = skipspace(s);
4228             if (*s == '{')
4229                 PRETERMBLOCK(DO);
4230             if (*s != '\'')
4231                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4232             OPERATOR(DO);
4233
4234         case KEY_die:
4235             PL_hints |= HINT_BLOCK_SCOPE;
4236             LOP(OP_DIE,XTERM);
4237
4238         case KEY_defined:
4239             UNI(OP_DEFINED);
4240
4241         case KEY_delete:
4242             UNI(OP_DELETE);
4243
4244         case KEY_dbmopen:
4245             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4246             LOP(OP_DBMOPEN,XTERM);
4247
4248         case KEY_dbmclose:
4249             UNI(OP_DBMCLOSE);
4250
4251         case KEY_dump:
4252             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4253             LOOPX(OP_DUMP);
4254
4255         case KEY_else:
4256             PREBLOCK(ELSE);
4257
4258         case KEY_elsif:
4259             yylval.ival = CopLINE(PL_curcop);
4260             OPERATOR(ELSIF);
4261
4262         case KEY_eq:
4263             Eop(OP_SEQ);
4264
4265         case KEY_exists:
4266             UNI(OP_EXISTS);
4267
4268         case KEY_exit:
4269             UNI(OP_EXIT);
4270
4271         case KEY_eval:
4272             s = skipspace(s);
4273             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4274             UNIBRACK(OP_ENTEREVAL);
4275
4276         case KEY_eof:
4277             UNI(OP_EOF);
4278
4279         case KEY_exp:
4280             UNI(OP_EXP);
4281
4282         case KEY_each:
4283             UNI(OP_EACH);
4284
4285         case KEY_exec:
4286             set_csh();
4287             LOP(OP_EXEC,XREF);
4288
4289         case KEY_endhostent:
4290             FUN0(OP_EHOSTENT);
4291
4292         case KEY_endnetent:
4293             FUN0(OP_ENETENT);
4294
4295         case KEY_endservent:
4296             FUN0(OP_ESERVENT);
4297
4298         case KEY_endprotoent:
4299             FUN0(OP_EPROTOENT);
4300
4301         case KEY_endpwent:
4302             FUN0(OP_EPWENT);
4303
4304         case KEY_endgrent:
4305             FUN0(OP_EGRENT);
4306
4307         case KEY_for:
4308         case KEY_foreach:
4309             yylval.ival = CopLINE(PL_curcop);
4310             s = skipspace(s);
4311             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4312                 char *p = s;
4313                 if ((PL_bufend - p) >= 3 &&
4314                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4315                     p += 2;
4316                 else if ((PL_bufend - p) >= 4 &&
4317                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4318                     p += 3;
4319                 p = skipspace(p);
4320                 if (isIDFIRST_lazy_if(p,UTF)) {
4321                     p = scan_ident(p, PL_bufend,
4322                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4323                     p = skipspace(p);
4324                 }
4325                 if (*p != '$')
4326                     Perl_croak(aTHX_ "Missing $ on loop variable");
4327             }
4328             OPERATOR(FOR);
4329
4330         case KEY_formline:
4331             LOP(OP_FORMLINE,XTERM);
4332
4333         case KEY_fork:
4334             FUN0(OP_FORK);
4335
4336         case KEY_fcntl:
4337             LOP(OP_FCNTL,XTERM);
4338
4339         case KEY_fileno:
4340             UNI(OP_FILENO);
4341
4342         case KEY_flock:
4343             LOP(OP_FLOCK,XTERM);
4344
4345         case KEY_gt:
4346             Rop(OP_SGT);
4347
4348         case KEY_ge:
4349             Rop(OP_SGE);
4350
4351         case KEY_grep:
4352             LOP(OP_GREPSTART, XREF);
4353
4354         case KEY_goto:
4355             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4356             LOOPX(OP_GOTO);
4357
4358         case KEY_gmtime:
4359             UNI(OP_GMTIME);
4360
4361         case KEY_getc:
4362             UNI(OP_GETC);
4363
4364         case KEY_getppid:
4365             FUN0(OP_GETPPID);
4366
4367         case KEY_getpgrp:
4368             UNI(OP_GETPGRP);
4369
4370         case KEY_getpriority:
4371             LOP(OP_GETPRIORITY,XTERM);
4372
4373         case KEY_getprotobyname:
4374             UNI(OP_GPBYNAME);
4375
4376         case KEY_getprotobynumber:
4377             LOP(OP_GPBYNUMBER,XTERM);
4378
4379         case KEY_getprotoent:
4380             FUN0(OP_GPROTOENT);
4381
4382         case KEY_getpwent:
4383             FUN0(OP_GPWENT);
4384
4385         case KEY_getpwnam:
4386             UNI(OP_GPWNAM);
4387
4388         case KEY_getpwuid:
4389             UNI(OP_GPWUID);
4390
4391         case KEY_getpeername:
4392             UNI(OP_GETPEERNAME);
4393
4394         case KEY_gethostbyname:
4395             UNI(OP_GHBYNAME);
4396
4397         case KEY_gethostbyaddr:
4398             LOP(OP_GHBYADDR,XTERM);
4399
4400         case KEY_gethostent:
4401             FUN0(OP_GHOSTENT);
4402
4403         case KEY_getnetbyname:
4404             UNI(OP_GNBYNAME);
4405
4406         case KEY_getnetbyaddr:
4407             LOP(OP_GNBYADDR,XTERM);
4408
4409         case KEY_getnetent:
4410             FUN0(OP_GNETENT);
4411
4412         case KEY_getservbyname:
4413             LOP(OP_GSBYNAME,XTERM);
4414
4415         case KEY_getservbyport:
4416             LOP(OP_GSBYPORT,XTERM);
4417
4418         case KEY_getservent:
4419             FUN0(OP_GSERVENT);
4420
4421         case KEY_getsockname:
4422             UNI(OP_GETSOCKNAME);
4423
4424         case KEY_getsockopt:
4425             LOP(OP_GSOCKOPT,XTERM);
4426
4427         case KEY_getgrent:
4428             FUN0(OP_GGRENT);
4429
4430         case KEY_getgrnam:
4431             UNI(OP_GGRNAM);
4432
4433         case KEY_getgrgid:
4434             UNI(OP_GGRGID);
4435
4436         case KEY_getlogin:
4437             FUN0(OP_GETLOGIN);
4438
4439         case KEY_glob:
4440             set_csh();
4441             LOP(OP_GLOB,XTERM);
4442
4443         case KEY_hex:
4444             UNI(OP_HEX);
4445
4446         case KEY_if:
4447             yylval.ival = CopLINE(PL_curcop);
4448             OPERATOR(IF);
4449
4450         case KEY_index:
4451             LOP(OP_INDEX,XTERM);
4452
4453         case KEY_int:
4454             UNI(OP_INT);
4455
4456         case KEY_ioctl:
4457             LOP(OP_IOCTL,XTERM);
4458
4459         case KEY_join:
4460             LOP(OP_JOIN,XTERM);
4461
4462         case KEY_keys:
4463             UNI(OP_KEYS);
4464
4465         case KEY_kill:
4466             LOP(OP_KILL,XTERM);
4467
4468         case KEY_last:
4469             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4470             LOOPX(OP_LAST);
4471
4472         case KEY_lc:
4473             UNI(OP_LC);
4474
4475         case KEY_lcfirst:
4476             UNI(OP_LCFIRST);
4477
4478         case KEY_local:
4479             yylval.ival = 0;
4480             OPERATOR(LOCAL);
4481
4482         case KEY_length:
4483             UNI(OP_LENGTH);
4484
4485         case KEY_lt:
4486             Rop(OP_SLT);
4487
4488         case KEY_le:
4489             Rop(OP_SLE);
4490
4491         case KEY_localtime:
4492             UNI(OP_LOCALTIME);
4493
4494         case KEY_log:
4495             UNI(OP_LOG);
4496
4497         case KEY_link:
4498             LOP(OP_LINK,XTERM);
4499
4500         case KEY_listen:
4501             LOP(OP_LISTEN,XTERM);
4502
4503         case KEY_lock:
4504             UNI(OP_LOCK);
4505
4506         case KEY_lstat:
4507             UNI(OP_LSTAT);
4508
4509         case KEY_m:
4510             s = scan_pat(s,OP_MATCH);
4511             TERM(sublex_start());
4512
4513         case KEY_map:
4514             LOP(OP_MAPSTART, XREF);
4515
4516         case KEY_mkdir:
4517             LOP(OP_MKDIR,XTERM);
4518
4519         case KEY_msgctl:
4520             LOP(OP_MSGCTL,XTERM);
4521
4522         case KEY_msgget:
4523             LOP(OP_MSGGET,XTERM);
4524
4525         case KEY_msgrcv:
4526             LOP(OP_MSGRCV,XTERM);
4527
4528         case KEY_msgsnd:
4529             LOP(OP_MSGSND,XTERM);
4530
4531         case KEY_our:
4532         case KEY_my:
4533             PL_in_my = tmp;
4534             s = skipspace(s);
4535             if (isIDFIRST_lazy_if(s,UTF)) {
4536                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4537                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4538                     goto really_sub;
4539                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4540                 if (!PL_in_my_stash) {
4541                     char tmpbuf[1024];
4542                     PL_bufptr = s;
4543                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4544                     yyerror(tmpbuf);
4545                 }
4546             }
4547             yylval.ival = 1;
4548             OPERATOR(MY);
4549
4550         case KEY_next:
4551             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4552             LOOPX(OP_NEXT);
4553
4554         case KEY_ne:
4555             Eop(OP_SNE);
4556
4557         case KEY_no:
4558             if (PL_expect != XSTATE)
4559                 yyerror("\"no\" not allowed in expression");
4560             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4561             s = force_version(s, FALSE);
4562             yylval.ival = 0;
4563             OPERATOR(USE);
4564
4565         case KEY_not:
4566             if (*s == '(' || (s = skipspace(s), *s == '('))
4567                 FUN1(OP_NOT);
4568             else
4569                 OPERATOR(NOTOP);
4570
4571         case KEY_open:
4572             s = skipspace(s);
4573             if (isIDFIRST_lazy_if(s,UTF)) {
4574                 char *t;
4575                 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4576                 t = skipspace(d);
4577                 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4578                     Perl_warner(aTHX_ WARN_PRECEDENCE,
4579                            "Precedence problem: open %.*s should be open(%.*s)",
4580                             d-s,s, d-s,s);
4581             }
4582             LOP(OP_OPEN,XTERM);
4583
4584         case KEY_or:
4585             yylval.ival = OP_OR;
4586             OPERATOR(OROP);
4587
4588         case KEY_ord:
4589             UNI(OP_ORD);
4590
4591         case KEY_oct:
4592             UNI(OP_OCT);
4593
4594         case KEY_opendir:
4595             LOP(OP_OPEN_DIR,XTERM);
4596
4597         case KEY_print:
4598             checkcomma(s,PL_tokenbuf,"filehandle");
4599             LOP(OP_PRINT,XREF);
4600
4601         case KEY_printf:
4602             checkcomma(s,PL_tokenbuf,"filehandle");
4603             LOP(OP_PRTF,XREF);
4604
4605         case KEY_prototype:
4606             UNI(OP_PROTOTYPE);
4607
4608         case KEY_push:
4609             LOP(OP_PUSH,XTERM);
4610
4611         case KEY_pop:
4612             UNI(OP_POP);
4613
4614         case KEY_pos:
4615             UNI(OP_POS);
4616
4617         case KEY_pack:
4618             LOP(OP_PACK,XTERM);
4619
4620         case KEY_package:
4621             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4622             OPERATOR(PACKAGE);
4623
4624         case KEY_pipe:
4625             LOP(OP_PIPE_OP,XTERM);
4626
4627         case KEY_q:
4628             s = scan_str(s,FALSE,FALSE);
4629             if (!s)
4630                 missingterm((char*)0);
4631             yylval.ival = OP_CONST;
4632             TERM(sublex_start());
4633
4634         case KEY_quotemeta:
4635             UNI(OP_QUOTEMETA);
4636
4637         case KEY_qw:
4638             s = scan_str(s,FALSE,FALSE);
4639             if (!s)
4640                 missingterm((char*)0);
4641             force_next(')');
4642             if (SvCUR(PL_lex_stuff)) {
4643                 OP *words = Nullop;
4644                 int warned = 0;
4645                 d = SvPV_force(PL_lex_stuff, len);
4646                 while (len) {
4647                     SV *sv;
4648                     for (; isSPACE(*d) && len; --len, ++d) ;
4649                     if (len) {
4650                         char *b = d;
4651                         if (!warned && ckWARN(WARN_QW)) {
4652                             for (; !isSPACE(*d) && len; --len, ++d) {
4653                                 if (*d == ',') {
4654                                     Perl_warner(aTHX_ WARN_QW,
4655                                         "Possible attempt to separate words with commas");
4656                                     ++warned;
4657                                 }
4658                                 else if (*d == '#') {
4659                                     Perl_warner(aTHX_ WARN_QW,
4660                                         "Possible attempt to put comments in qw() list");
4661                                     ++warned;
4662                                 }
4663                             }
4664                         }
4665                         else {
4666                             for (; !isSPACE(*d) && len; --len, ++d) ;
4667                         }
4668                         sv = newSVpvn(b, d-b);
4669                         if (DO_UTF8(PL_lex_stuff))
4670                             SvUTF8_on(sv);
4671                         words = append_elem(OP_LIST, words,
4672                                             newSVOP(OP_CONST, 0, tokeq(sv)));
4673                     }
4674                 }
4675                 if (words) {
4676                     PL_nextval[PL_nexttoke].opval = words;
4677                     force_next(THING);
4678                 }
4679             }
4680             if (PL_lex_stuff) {
4681                 SvREFCNT_dec(PL_lex_stuff);
4682                 PL_lex_stuff = Nullsv;
4683             }
4684             PL_expect = XTERM;
4685             TOKEN('(');
4686
4687         case KEY_qq:
4688             s = scan_str(s,FALSE,FALSE);
4689             if (!s)
4690                 missingterm((char*)0);
4691             yylval.ival = OP_STRINGIFY;
4692             if (SvIVX(PL_lex_stuff) == '\'')
4693                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
4694             TERM(sublex_start());
4695
4696         case KEY_qr:
4697             s = scan_pat(s,OP_QR);
4698             TERM(sublex_start());
4699
4700         case KEY_qx:
4701             s = scan_str(s,FALSE,FALSE);
4702             if (!s)
4703                 missingterm((char*)0);
4704             yylval.ival = OP_BACKTICK;
4705             set_csh();
4706             TERM(sublex_start());
4707
4708         case KEY_return:
4709             OLDLOP(OP_RETURN);
4710
4711         case KEY_require:
4712             s = skipspace(s);
4713             if (isDIGIT(*s)) {
4714                 s = force_version(s, FALSE);
4715             }
4716             else if (*s != 'v' || !isDIGIT(s[1])
4717                     || (s = force_version(s, TRUE), *s == 'v'))
4718             {
4719                 *PL_tokenbuf = '\0';
4720                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4721                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4722                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4723                 else if (*s == '<')
4724                     yyerror("<> should be quotes");
4725             }
4726             UNI(OP_REQUIRE);
4727
4728         case KEY_reset:
4729             UNI(OP_RESET);
4730
4731         case KEY_redo:
4732             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4733             LOOPX(OP_REDO);
4734
4735         case KEY_rename:
4736             LOP(OP_RENAME,XTERM);
4737
4738         case KEY_rand:
4739             UNI(OP_RAND);
4740
4741         case KEY_rmdir:
4742             UNI(OP_RMDIR);
4743
4744         case KEY_rindex:
4745             LOP(OP_RINDEX,XTERM);
4746
4747         case KEY_read:
4748             LOP(OP_READ,XTERM);
4749
4750         case KEY_readdir:
4751             UNI(OP_READDIR);
4752
4753         case KEY_readline:
4754             set_csh();
4755             UNI(OP_READLINE);
4756
4757         case KEY_readpipe:
4758             set_csh();
4759             UNI(OP_BACKTICK);
4760
4761         case KEY_rewinddir:
4762             UNI(OP_REWINDDIR);
4763
4764         case KEY_recv:
4765             LOP(OP_RECV,XTERM);
4766
4767         case KEY_reverse:
4768             LOP(OP_REVERSE,XTERM);
4769
4770         case KEY_readlink:
4771             UNI(OP_READLINK);
4772
4773         case KEY_ref:
4774             UNI(OP_REF);
4775
4776         case KEY_s:
4777             s = scan_subst(s);
4778             if (yylval.opval)
4779                 TERM(sublex_start());
4780             else
4781                 TOKEN(1);       /* force error */
4782
4783         case KEY_chomp:
4784             UNI(OP_CHOMP);
4785
4786         case KEY_scalar:
4787             UNI(OP_SCALAR);
4788
4789         case KEY_select:
4790             LOP(OP_SELECT,XTERM);
4791
4792         case KEY_seek:
4793             LOP(OP_SEEK,XTERM);
4794
4795         case KEY_semctl:
4796             LOP(OP_SEMCTL,XTERM);
4797
4798         case KEY_semget:
4799             LOP(OP_SEMGET,XTERM);
4800
4801         case KEY_semop:
4802             LOP(OP_SEMOP,XTERM);
4803
4804         case KEY_send:
4805             LOP(OP_SEND,XTERM);
4806
4807         case KEY_setpgrp:
4808             LOP(OP_SETPGRP,XTERM);
4809
4810         case KEY_setpriority:
4811             LOP(OP_SETPRIORITY,XTERM);
4812
4813         case KEY_sethostent:
4814             UNI(OP_SHOSTENT);
4815
4816         case KEY_setnetent:
4817             UNI(OP_SNETENT);
4818
4819         case KEY_setservent:
4820             UNI(OP_SSERVENT);
4821
4822         case KEY_setprotoent:
4823             UNI(OP_SPROTOENT);
4824
4825         case KEY_setpwent:
4826             FUN0(OP_SPWENT);
4827
4828         case KEY_setgrent:
4829             FUN0(OP_SGRENT);
4830
4831         case KEY_seekdir:
4832             LOP(OP_SEEKDIR,XTERM);
4833
4834         case KEY_setsockopt:
4835             LOP(OP_SSOCKOPT,XTERM);
4836
4837         case KEY_shift:
4838             UNI(OP_SHIFT);
4839
4840         case KEY_shmctl:
4841             LOP(OP_SHMCTL,XTERM);
4842
4843         case KEY_shmget:
4844             LOP(OP_SHMGET,XTERM);
4845
4846         case KEY_shmread:
4847             LOP(OP_SHMREAD,XTERM);
4848
4849         case KEY_shmwrite:
4850             LOP(OP_SHMWRITE,XTERM);
4851
4852         case KEY_shutdown:
4853             LOP(OP_SHUTDOWN,XTERM);
4854
4855         case KEY_sin:
4856             UNI(OP_SIN);
4857
4858         case KEY_sleep:
4859             UNI(OP_SLEEP);
4860
4861         case KEY_socket:
4862             LOP(OP_SOCKET,XTERM);
4863
4864         case KEY_socketpair:
4865             LOP(OP_SOCKPAIR,XTERM);
4866
4867         case KEY_sort:
4868             checkcomma(s,PL_tokenbuf,"subroutine name");
4869             s = skipspace(s);
4870             if (*s == ';' || *s == ')')         /* probably a close */
4871                 Perl_croak(aTHX_ "sort is now a reserved word");
4872             PL_expect = XTERM;
4873             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4874             LOP(OP_SORT,XREF);
4875
4876         case KEY_split:
4877             LOP(OP_SPLIT,XTERM);
4878
4879         case KEY_sprintf:
4880             LOP(OP_SPRINTF,XTERM);
4881
4882         case KEY_splice:
4883             LOP(OP_SPLICE,XTERM);
4884
4885         case KEY_sqrt:
4886             UNI(OP_SQRT);
4887
4888         case KEY_srand:
4889             UNI(OP_SRAND);
4890
4891         case KEY_stat:
4892             UNI(OP_STAT);
4893
4894         case KEY_study:
4895             UNI(OP_STUDY);
4896
4897         case KEY_substr:
4898             LOP(OP_SUBSTR,XTERM);
4899
4900         case KEY_format:
4901         case KEY_sub:
4902           really_sub:
4903             {
4904                 char tmpbuf[sizeof PL_tokenbuf];
4905                 SSize_t tboffset = 0;
4906                 expectation attrful;
4907                 bool have_name, have_proto, bad_proto;
4908                 int key = tmp;
4909
4910                 s = skipspace(s);
4911
4912                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4913                     (*s == ':' && s[1] == ':'))
4914                 {
4915                     PL_expect = XBLOCK;
4916                     attrful = XATTRBLOCK;
4917                     /* remember buffer pos'n for later force_word */
4918                     tboffset = s - PL_oldbufptr;
4919                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4920                     if (strchr(tmpbuf, ':'))
4921                         sv_setpv(PL_subname, tmpbuf);
4922                     else {
4923                         sv_setsv(PL_subname,PL_curstname);
4924                         sv_catpvn(PL_subname,"::",2);
4925                         sv_catpvn(PL_subname,tmpbuf,len);
4926                     }
4927                     s = skipspace(d);
4928                     have_name = TRUE;
4929                 }
4930                 else {
4931                     if (key == KEY_my)
4932                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
4933                     PL_expect = XTERMBLOCK;
4934                     attrful = XATTRTERM;
4935                     sv_setpv(PL_subname,"?");
4936                     have_name = FALSE;
4937                 }
4938
4939                 if (key == KEY_format) {
4940                     if (*s == '=')
4941                         PL_lex_formbrack = PL_lex_brackets + 1;
4942                     if (have_name)
4943                         (void) force_word(PL_oldbufptr + tboffset, WORD,
4944                                           FALSE, TRUE, TRUE);
4945                     OPERATOR(FORMAT);
4946                 }
4947
4948                 /* Look for a prototype */
4949                 if (*s == '(') {
4950                     char *p;
4951
4952                     s = scan_str(s,FALSE,FALSE);
4953                     if (!s)
4954                         Perl_croak(aTHX_ "Prototype not terminated");
4955                     /* strip spaces and check for bad characters */
4956                     d = SvPVX(PL_lex_stuff);
4957                     tmp = 0;
4958                     bad_proto = FALSE;
4959                     for (p = d; *p; ++p) {
4960                         if (!isSPACE(*p)) {
4961                             d[tmp++] = *p;
4962                             if (!strchr("$@%*;[]&\\", *p))
4963                                 bad_proto = TRUE;
4964                         }
4965                     }
4966                     d[tmp] = '\0';
4967                     if (bad_proto && ckWARN(WARN_SYNTAX))
4968                         Perl_warner(aTHX_ WARN_SYNTAX,
4969                                     "Illegal character in prototype for %s : %s",
4970                                     SvPVX(PL_subname), d);
4971                     SvCUR(PL_lex_stuff) = tmp;
4972                     have_proto = TRUE;
4973
4974                     s = skipspace(s);
4975                 }
4976                 else
4977                     have_proto = FALSE;
4978
4979                 if (*s == ':' && s[1] != ':')
4980                     PL_expect = attrful;
4981
4982                 if (have_proto) {
4983                     PL_nextval[PL_nexttoke].opval =
4984                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4985                     PL_lex_stuff = Nullsv;
4986                     force_next(THING);
4987                 }
4988                 if (!have_name) {
4989                     sv_setpv(PL_subname,"__ANON__");
4990                     TOKEN(ANONSUB);
4991                 }
4992                 (void) force_word(PL_oldbufptr + tboffset, WORD,
4993                                   FALSE, TRUE, TRUE);
4994                 if (key == KEY_my)
4995                     TOKEN(MYSUB);
4996                 TOKEN(SUB);
4997             }
4998
4999         case KEY_system:
5000             set_csh();
5001             LOP(OP_SYSTEM,XREF);
5002
5003         case KEY_symlink:
5004             LOP(OP_SYMLINK,XTERM);
5005
5006         case KEY_syscall:
5007             LOP(OP_SYSCALL,XTERM);
5008
5009         case KEY_sysopen:
5010             LOP(OP_SYSOPEN,XTERM);
5011
5012         case KEY_sysseek:
5013             LOP(OP_SYSSEEK,XTERM);
5014
5015         case KEY_sysread:
5016             LOP(OP_SYSREAD,XTERM);
5017
5018         case KEY_syswrite:
5019             LOP(OP_SYSWRITE,XTERM);
5020
5021         case KEY_tr:
5022             s = scan_trans(s);
5023             TERM(sublex_start());
5024
5025         case KEY_tell:
5026             UNI(OP_TELL);
5027
5028         case KEY_telldir:
5029             UNI(OP_TELLDIR);
5030
5031         case KEY_tie:
5032             LOP(OP_TIE,XTERM);
5033
5034         case KEY_tied:
5035             UNI(OP_TIED);
5036
5037         case KEY_time:
5038             FUN0(OP_TIME);
5039
5040         case KEY_times:
5041             FUN0(OP_TMS);
5042
5043         case KEY_truncate:
5044             LOP(OP_TRUNCATE,XTERM);
5045
5046         case KEY_uc:
5047             UNI(OP_UC);
5048
5049         case KEY_ucfirst:
5050             UNI(OP_UCFIRST);
5051
5052         case KEY_untie:
5053             UNI(OP_UNTIE);
5054
5055         case KEY_until:
5056             yylval.ival = CopLINE(PL_curcop);
5057             OPERATOR(UNTIL);
5058
5059         case KEY_unless:
5060             yylval.ival = CopLINE(PL_curcop);
5061             OPERATOR(UNLESS);
5062
5063         case KEY_unlink:
5064             LOP(OP_UNLINK,XTERM);
5065
5066         case KEY_undef:
5067             UNI(OP_UNDEF);
5068
5069         case KEY_unpack:
5070             LOP(OP_UNPACK,XTERM);
5071
5072         case KEY_utime:
5073             LOP(OP_UTIME,XTERM);
5074
5075         case KEY_umask:
5076             UNI(OP_UMASK);
5077
5078         case KEY_unshift:
5079             LOP(OP_UNSHIFT,XTERM);
5080
5081         case KEY_use:
5082             if (PL_expect != XSTATE)
5083                 yyerror("\"use\" not allowed in expression");
5084             s = skipspace(s);
5085             if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5086                 s = force_version(s, TRUE);
5087                 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5088                     PL_nextval[PL_nexttoke].opval = Nullop;
5089                     force_next(WORD);
5090                 }
5091                 else if (*s == 'v') {
5092                     s = force_word(s,WORD,FALSE,TRUE,FALSE);
5093                     s = force_version(s, FALSE);
5094                 }
5095             }
5096             else {
5097                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5098                 s = force_version(s, FALSE);
5099             }
5100             yylval.ival = 1;
5101             OPERATOR(USE);
5102
5103         case KEY_values:
5104             UNI(OP_VALUES);
5105
5106         case KEY_vec:
5107             LOP(OP_VEC,XTERM);
5108
5109         case KEY_while:
5110             yylval.ival = CopLINE(PL_curcop);
5111             OPERATOR(WHILE);
5112
5113         case KEY_warn:
5114             PL_hints |= HINT_BLOCK_SCOPE;
5115             LOP(OP_WARN,XTERM);
5116
5117         case KEY_wait:
5118             FUN0(OP_WAIT);
5119
5120         case KEY_waitpid:
5121             LOP(OP_WAITPID,XTERM);
5122
5123         case KEY_wantarray:
5124             FUN0(OP_WANTARRAY);
5125
5126         case KEY_write:
5127 #ifdef EBCDIC
5128         {
5129             char ctl_l[2];
5130             ctl_l[0] = toCTRL('L');
5131             ctl_l[1] = '\0';
5132             gv_fetchpv(ctl_l,TRUE, SVt_PV);
5133         }
5134 #else
5135             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
5136 #endif
5137             UNI(OP_ENTERWRITE);
5138
5139         case KEY_x:
5140             if (PL_expect == XOPERATOR)
5141                 Mop(OP_REPEAT);
5142             check_uni();
5143             goto just_a_word;
5144
5145         case KEY_xor:
5146             yylval.ival = OP_XOR;
5147             OPERATOR(OROP);
5148
5149         case KEY_y:
5150             s = scan_trans(s);
5151             TERM(sublex_start());
5152         }
5153     }}
5154 }
5155 #ifdef __SC__
5156 #pragma segment Main
5157 #endif
5158
5159 static int
5160 S_pending_ident(pTHX)
5161 {
5162     register char *d;
5163     register I32 tmp;
5164     /* pit holds the identifier we read and pending_ident is reset */
5165     char pit = PL_pending_ident;
5166     PL_pending_ident = 0;
5167
5168     DEBUG_T({ PerlIO_printf(Perl_debug_log,
5169           "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5170
5171     /* if we're in a my(), we can't allow dynamics here.
5172        $foo'bar has already been turned into $foo::bar, so
5173        just check for colons.
5174
5175        if it's a legal name, the OP is a PADANY.
5176     */
5177     if (PL_in_my) {
5178         if (PL_in_my == KEY_our) {      /* "our" is merely analogous to "my" */
5179             if (strchr(PL_tokenbuf,':'))
5180                 yyerror(Perl_form(aTHX_ "No package name allowed for "
5181                                   "variable %s in \"our\"",
5182                                   PL_tokenbuf));
5183             tmp = pad_allocmy(PL_tokenbuf);
5184         }
5185         else {
5186             if (strchr(PL_tokenbuf,':'))
5187                 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5188
5189             yylval.opval = newOP(OP_PADANY, 0);
5190             yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
5191             return PRIVATEREF;
5192         }
5193     }
5194
5195     /*
5196        build the ops for accesses to a my() variable.
5197
5198        Deny my($a) or my($b) in a sort block, *if* $a or $b is
5199        then used in a comparison.  This catches most, but not
5200        all cases.  For instance, it catches
5201            sort { my($a); $a <=> $b }
5202        but not
5203            sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5204        (although why you'd do that is anyone's guess).
5205     */
5206
5207     if (!strchr(PL_tokenbuf,':')) {
5208 #ifdef USE_5005THREADS
5209         /* Check for single character per-thread SVs */
5210         if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
5211             && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
5212             && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
5213         {
5214             yylval.opval = newOP(OP_THREADSV, 0);
5215             yylval.opval->op_targ = tmp;
5216             return PRIVATEREF;
5217         }
5218 #endif /* USE_5005THREADS */
5219         if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
5220             SV *namesv = AvARRAY(PL_comppad_name)[tmp];
5221             /* might be an "our" variable" */
5222             if (SvFLAGS(namesv) & SVpad_OUR) {
5223                 /* build ops for a bareword */
5224                 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
5225                 sv_catpvn(sym, "::", 2);
5226                 sv_catpv(sym, PL_tokenbuf+1);
5227                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5228                 yylval.opval->op_private = OPpCONST_ENTERED;
5229                 gv_fetchpv(SvPVX(sym),
5230                     (PL_in_eval
5231                         ? (GV_ADDMULTI | GV_ADDINEVAL)
5232                         : GV_ADDMULTI
5233                     ),
5234                     ((PL_tokenbuf[0] == '$') ? SVt_PV
5235                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5236                      : SVt_PVHV));
5237                 return WORD;
5238             }
5239
5240             /* if it's a sort block and they're naming $a or $b */
5241             if (PL_last_lop_op == OP_SORT &&
5242                 PL_tokenbuf[0] == '$' &&
5243                 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5244                 && !PL_tokenbuf[2])
5245             {
5246                 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5247                      d < PL_bufend && *d != '\n';
5248                      d++)
5249                 {
5250                     if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5251                         Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5252                               PL_tokenbuf);
5253                     }
5254                 }
5255             }
5256
5257             yylval.opval = newOP(OP_PADANY, 0);
5258             yylval.opval->op_targ = tmp;
5259             return PRIVATEREF;
5260         }
5261     }
5262
5263     /*
5264        Whine if they've said @foo in a doublequoted string,
5265        and @foo isn't a variable we can find in the symbol
5266        table.
5267     */
5268     if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5269         GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5270         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5271              && ckWARN(WARN_AMBIGUOUS))
5272         {
5273             /* Downgraded from fatal to warning 20000522 mjd */
5274             Perl_warner(aTHX_ WARN_AMBIGUOUS,
5275                         "Possible unintended interpolation of %s in string",
5276                          PL_tokenbuf);
5277         }
5278     }
5279
5280     /* build ops for a bareword */
5281     yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5282     yylval.opval->op_private = OPpCONST_ENTERED;
5283     gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5284                ((PL_tokenbuf[0] == '$') ? SVt_PV
5285                 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5286                 : SVt_PVHV));
5287     return WORD;
5288 }
5289
5290 I32
5291 Perl_keyword(pTHX_ register char *d, I32 len)
5292 {
5293     switch (*d) {
5294     case '_':
5295         if (d[1] == '_') {
5296             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
5297             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
5298             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
5299             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
5300             if (strEQ(d,"__END__"))             return KEY___END__;
5301         }
5302         break;
5303     case 'A':
5304         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
5305         break;
5306     case 'a':
5307         switch (len) {
5308         case 3:
5309             if (strEQ(d,"and"))                 return -KEY_and;
5310             if (strEQ(d,"abs"))                 return -KEY_abs;
5311             break;
5312         case 5:
5313             if (strEQ(d,"alarm"))               return -KEY_alarm;
5314             if (strEQ(d,"atan2"))               return -KEY_atan2;
5315             break;
5316         case 6:
5317             if (strEQ(d,"accept"))              return -KEY_accept;
5318             break;
5319         }
5320         break;
5321     case 'B':
5322         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
5323         break;
5324     case 'b':
5325         if (strEQ(d,"bless"))                   return -KEY_bless;
5326         if (strEQ(d,"bind"))                    return -KEY_bind;
5327         if (strEQ(d,"binmode"))                 return -KEY_binmode;
5328         break;
5329     case 'C':
5330         if (strEQ(d,"CORE"))                    return -KEY_CORE;
5331         if (strEQ(d,"CHECK"))                   return KEY_CHECK;
5332         break;
5333     case 'c':
5334         switch (len) {
5335         case 3:
5336             if (strEQ(d,"cmp"))                 return -KEY_cmp;
5337             if (strEQ(d,"chr"))                 return -KEY_chr;
5338             if (strEQ(d,"cos"))                 return -KEY_cos;
5339             break;
5340         case 4:
5341             if (strEQ(d,"chop"))                return -KEY_chop;
5342             break;
5343         case 5:
5344             if (strEQ(d,"close"))               return -KEY_close;
5345             if (strEQ(d,"chdir"))               return -KEY_chdir;
5346             if (strEQ(d,"chomp"))               return -KEY_chomp;
5347             if (strEQ(d,"chmod"))               return -KEY_chmod;
5348             if (strEQ(d,"chown"))               return -KEY_chown;
5349             if (strEQ(d,"crypt"))               return -KEY_crypt;
5350             break;
5351         case 6:
5352             if (strEQ(d,"chroot"))              return -KEY_chroot;
5353             if (strEQ(d,"caller"))              return -KEY_caller;
5354             break;
5355         case 7:
5356             if (strEQ(d,"connect"))             return -KEY_connect;
5357             break;
5358         case 8:
5359             if (strEQ(d,"closedir"))            return -KEY_closedir;
5360             if (strEQ(d,"continue"))            return -KEY_continue;
5361             break;
5362         }
5363         break;
5364     case 'D':
5365         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
5366         break;
5367     case 'd':
5368         switch (len) {
5369         case 2:
5370             if (strEQ(d,"do"))                  return KEY_do;
5371             break;
5372         case 3:
5373             if (strEQ(d,"die"))                 return -KEY_die;
5374             break;
5375         case 4:
5376             if (strEQ(d,"dump"))                return -KEY_dump;
5377             break;
5378         case 6:
5379             if (strEQ(d,"delete"))              return KEY_delete;
5380             break;
5381         case 7:
5382             if (strEQ(d,"defined"))             return KEY_defined;
5383             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
5384             break;
5385         case 8:
5386             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
5387             break;
5388         }
5389         break;
5390     case 'E':
5391         if (strEQ(d,"END"))                     return KEY_END;
5392         break;
5393     case 'e':
5394         switch (len) {
5395         case 2:
5396             if (strEQ(d,"eq"))                  return -KEY_eq;
5397             break;
5398         case 3:
5399             if (strEQ(d,"eof"))                 return -KEY_eof;
5400             if (strEQ(d,"exp"))                 return -KEY_exp;
5401             break;
5402         case 4:
5403             if (strEQ(d,"else"))                return KEY_else;
5404             if (strEQ(d,"exit"))                return -KEY_exit;
5405             if (strEQ(d,"eval"))                return KEY_eval;
5406             if (strEQ(d,"exec"))                return -KEY_exec;
5407            if (strEQ(d,"each"))                return -KEY_each;
5408             break;
5409         case 5:
5410             if (strEQ(d,"elsif"))               return KEY_elsif;
5411             break;
5412         case 6:
5413             if (strEQ(d,"exists"))              return KEY_exists;
5414             if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5415             break;
5416         case 8:
5417             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
5418             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
5419             break;
5420         case 9:
5421             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
5422             break;
5423         case 10:
5424             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
5425             if (strEQ(d,"endservent"))          return -KEY_endservent;
5426             break;
5427         case 11:
5428             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
5429             break;
5430         }
5431         break;
5432     case 'f':
5433         switch (len) {
5434         case 3:
5435             if (strEQ(d,"for"))                 return KEY_for;
5436             break;
5437         case 4:
5438             if (strEQ(d,"fork"))                return -KEY_fork;
5439             break;
5440         case 5:
5441             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
5442             if (strEQ(d,"flock"))               return -KEY_flock;
5443             break;
5444         case 6:
5445             if (strEQ(d,"format"))              return KEY_format;
5446             if (strEQ(d,"fileno"))              return -KEY_fileno;
5447             break;
5448         case 7:
5449             if (strEQ(d,"foreach"))             return KEY_foreach;
5450             break;
5451         case 8:
5452             if (strEQ(d,"formline"))            return -KEY_formline;
5453             break;
5454         }
5455         break;
5456     case 'g':
5457         if (strnEQ(d,"get",3)) {
5458             d += 3;
5459             if (*d == 'p') {
5460                 switch (len) {
5461                 case 7:
5462                     if (strEQ(d,"ppid"))        return -KEY_getppid;
5463                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
5464                     break;
5465                 case 8:
5466                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
5467                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
5468                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
5469                     break;
5470                 case 11:
5471                     if (strEQ(d,"peername"))    return -KEY_getpeername;
5472                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
5473                     if (strEQ(d,"priority"))    return -KEY_getpriority;
5474                     break;
5475                 case 14:
5476                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5477                     break;
5478                 case 16:
5479                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5480                     break;
5481                 }
5482             }
5483             else if (*d == 'h') {
5484                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
5485                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
5486                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
5487             }
5488             else if (*d == 'n') {
5489                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
5490                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
5491                 if (strEQ(d,"netent"))          return -KEY_getnetent;
5492             }
5493             else if (*d == 's') {
5494                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
5495                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
5496                 if (strEQ(d,"servent"))         return -KEY_getservent;
5497                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
5498                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
5499             }
5500             else if (*d == 'g') {
5501                 if (strEQ(d,"grent"))           return -KEY_getgrent;
5502                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
5503                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
5504             }
5505             else if (*d == 'l') {
5506                 if (strEQ(d,"login"))           return -KEY_getlogin;
5507             }
5508             else if (strEQ(d,"c"))              return -KEY_getc;
5509             break;
5510         }
5511         switch (len) {
5512         case 2:
5513             if (strEQ(d,"gt"))                  return -KEY_gt;
5514             if (strEQ(d,"ge"))                  return -KEY_ge;
5515             break;
5516         case 4:
5517             if (strEQ(d,"grep"))                return KEY_grep;
5518             if (strEQ(d,"goto"))                return KEY_goto;
5519             if (strEQ(d,"glob"))                return KEY_glob;
5520             break;
5521         case 6:
5522             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
5523             break;
5524         }
5525         break;
5526     case 'h':
5527         if (strEQ(d,"hex"))                     return -KEY_hex;
5528         break;
5529     case 'I':
5530         if (strEQ(d,"INIT"))                    return KEY_INIT;
5531         break;
5532     case 'i':
5533         switch (len) {
5534         case 2:
5535             if (strEQ(d,"if"))                  return KEY_if;
5536             break;
5537         case 3:
5538             if (strEQ(d,"int"))                 return -KEY_int;
5539             break;
5540         case 5:
5541             if (strEQ(d,"index"))               return -KEY_index;
5542             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
5543             break;
5544         }
5545         break;
5546     case 'j':
5547         if (strEQ(d,"join"))                    return -KEY_join;
5548         break;
5549     case 'k':
5550         if (len == 4) {
5551            if (strEQ(d,"keys"))                return -KEY_keys;
5552             if (strEQ(d,"kill"))                return -KEY_kill;
5553         }
5554         break;
5555     case 'l':
5556         switch (len) {
5557         case 2:
5558             if (strEQ(d,"lt"))                  return -KEY_lt;
5559             if (strEQ(d,"le"))                  return -KEY_le;
5560             if (strEQ(d,"lc"))                  return -KEY_lc;
5561             break;
5562         case 3:
5563             if (strEQ(d,"log"))                 return -KEY_log;
5564             break;
5565         case 4:
5566             if (strEQ(d,"last"))                return KEY_last;
5567             if (strEQ(d,"link"))                return -KEY_link;
5568             if (strEQ(d,"lock"))                return -KEY_lock;
5569             break;
5570         case 5:
5571             if (strEQ(d,"local"))               return KEY_local;
5572             if (strEQ(d,"lstat"))               return -KEY_lstat;
5573             break;
5574         case 6:
5575             if (strEQ(d,"length"))              return -KEY_length;
5576             if (strEQ(d,"listen"))              return -KEY_listen;
5577             break;
5578         case 7:
5579             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
5580             break;
5581         case 9:
5582             if (strEQ(d,"localtime"))           return -KEY_localtime;
5583             break;
5584         }
5585         break;
5586     case 'm':
5587         switch (len) {
5588         case 1:                                 return KEY_m;
5589         case 2:
5590             if (strEQ(d,"my"))                  return KEY_my;
5591             break;
5592         case 3:
5593             if (strEQ(d,"map"))                 return KEY_map;
5594             break;
5595         case 5:
5596             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
5597             break;
5598         case 6:
5599             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
5600             if (strEQ(d,"msgget"))              return -KEY_msgget;
5601             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
5602             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
5603             break;
5604         }
5605         break;
5606     case 'n':
5607         if (strEQ(d,"next"))                    return KEY_next;
5608         if (strEQ(d,"ne"))                      return -KEY_ne;
5609         if (strEQ(d,"not"))                     return -KEY_not;
5610         if (strEQ(d,"no"))                      return KEY_no;
5611         break;
5612     case 'o':
5613         switch (len) {
5614         case 2:
5615             if (strEQ(d,"or"))                  return -KEY_or;
5616             break;
5617         case 3:
5618             if (strEQ(d,"ord"))                 return -KEY_ord;
5619             if (strEQ(d,"oct"))                 return -KEY_oct;
5620             if (strEQ(d,"our"))                 return KEY_our;
5621             break;
5622         case 4:
5623             if (strEQ(d,"open"))                return -KEY_open;
5624             break;
5625         case 7:
5626             if (strEQ(d,"opendir"))             return -KEY_opendir;
5627             break;
5628         }
5629         break;
5630     case 'p':
5631         switch (len) {
5632         case 3:
5633            if (strEQ(d,"pop"))                 return -KEY_pop;
5634             if (strEQ(d,"pos"))                 return KEY_pos;
5635             break;
5636         case 4:
5637            if (strEQ(d,"push"))                return -KEY_push;
5638             if (strEQ(d,"pack"))                return -KEY_pack;
5639             if (strEQ(d,"pipe"))                return -KEY_pipe;
5640             break;
5641         case 5:
5642             if (strEQ(d,"print"))               return KEY_print;
5643             break;
5644         case 6:
5645             if (strEQ(d,"printf"))              return KEY_printf;
5646             break;
5647         case 7:
5648             if (strEQ(d,"package"))             return KEY_package;
5649             break;
5650         case 9:
5651             if (strEQ(d,"prototype"))           return KEY_prototype;
5652         }
5653         break;
5654     case 'q':
5655         if (len <= 2) {
5656             if (strEQ(d,"q"))                   return KEY_q;
5657             if (strEQ(d,"qr"))                  return KEY_qr;
5658             if (strEQ(d,"qq"))                  return KEY_qq;
5659             if (strEQ(d,"qw"))                  return KEY_qw;
5660             if (strEQ(d,"qx"))                  return KEY_qx;
5661         }
5662         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
5663         break;
5664     case 'r':
5665         switch (len) {
5666         case 3:
5667             if (strEQ(d,"ref"))                 return -KEY_ref;
5668             break;
5669         case 4:
5670             if (strEQ(d,"read"))                return -KEY_read;
5671             if (strEQ(d,"rand"))                return -KEY_rand;
5672             if (strEQ(d,"recv"))                return -KEY_recv;
5673             if (strEQ(d,"redo"))                return KEY_redo;
5674             break;
5675         case 5:
5676             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
5677             if (strEQ(d,"reset"))               return -KEY_reset;
5678             break;
5679         case 6:
5680             if (strEQ(d,"return"))              return KEY_return;
5681             if (strEQ(d,"rename"))              return -KEY_rename;
5682             if (strEQ(d,"rindex"))              return -KEY_rindex;
5683             break;
5684         case 7:
5685             if (strEQ(d,"require"))             return KEY_require;
5686             if (strEQ(d,"reverse"))             return -KEY_reverse;
5687             if (strEQ(d,"readdir"))             return -KEY_readdir;
5688             break;
5689         case 8:
5690             if (strEQ(d,"readlink"))            return -KEY_readlink;
5691             if (strEQ(d,"readline"))            return -KEY_readline;
5692             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
5693             break;
5694         case 9:
5695             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
5696             break;
5697         }
5698         break;
5699     case 's':
5700         switch (d[1]) {
5701         case 0:                                 return KEY_s;
5702         case 'c':
5703             if (strEQ(d,"scalar"))              return KEY_scalar;
5704             break;
5705         case 'e':
5706             switch (len) {
5707             case 4:
5708                 if (strEQ(d,"seek"))            return -KEY_seek;
5709                 if (strEQ(d,"send"))            return -KEY_send;
5710                 break;
5711             case 5:
5712                 if (strEQ(d,"semop"))           return -KEY_semop;
5713                 break;
5714             case 6:
5715                 if (strEQ(d,"select"))          return -KEY_select;
5716                 if (strEQ(d,"semctl"))          return -KEY_semctl;
5717                 if (strEQ(d,"semget"))          return -KEY_semget;
5718                 break;
5719             case 7:
5720                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
5721                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
5722                 break;
5723             case 8:
5724                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
5725                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
5726                 break;
5727             case 9:
5728                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
5729                 break;
5730             case 10:
5731                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
5732                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
5733                 if (strEQ(d,"setservent"))      return -KEY_setservent;
5734                 break;
5735             case 11:
5736                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
5737                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
5738                 break;
5739             }
5740             break;
5741         case 'h':
5742             switch (len) {
5743             case 5:
5744                if (strEQ(d,"shift"))           return -KEY_shift;
5745                 break;
5746             case 6:
5747                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
5748                 if (strEQ(d,"shmget"))          return -KEY_shmget;
5749                 break;
5750             case 7:
5751                 if (strEQ(d,"shmread"))         return -KEY_shmread;
5752                 break;
5753             case 8:
5754                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
5755                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
5756                 break;
5757             }
5758             break;
5759         case 'i':
5760             if (strEQ(d,"sin"))                 return -KEY_sin;
5761             break;
5762         case 'l':
5763             if (strEQ(d,"sleep"))               return -KEY_sleep;
5764             break;
5765         case 'o':
5766             if (strEQ(d,"sort"))                return KEY_sort;
5767             if (strEQ(d,"socket"))              return -KEY_socket;
5768             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
5769             break;
5770         case 'p':
5771             if (strEQ(d,"split"))               return KEY_split;
5772             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
5773            if (strEQ(d,"splice"))              return -KEY_splice;
5774             break;
5775         case 'q':
5776             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
5777             break;
5778         case 'r':
5779             if (strEQ(d,"srand"))               return -KEY_srand;
5780             break;
5781         case 't':
5782             if (strEQ(d,"stat"))                return -KEY_stat;
5783             if (strEQ(d,"study"))               return KEY_study;
5784             break;
5785         case 'u':
5786             if (strEQ(d,"substr"))              return -KEY_substr;
5787             if (strEQ(d,"sub"))                 return KEY_sub;
5788             break;
5789         case 'y':
5790             switch (len) {
5791             case 6:
5792                 if (strEQ(d,"system"))          return -KEY_system;
5793                 break;
5794             case 7:
5795                 if (strEQ(d,"symlink"))         return -KEY_symlink;
5796                 if (strEQ(d,"syscall"))         return -KEY_syscall;
5797                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
5798                 if (strEQ(d,"sysread"))         return -KEY_sysread;
5799                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
5800                 break;
5801             case 8:
5802                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
5803                 break;
5804             }
5805             break;
5806         }
5807         break;
5808     case 't':
5809         switch (len) {
5810         case 2:
5811             if (strEQ(d,"tr"))                  return KEY_tr;
5812             break;
5813         case 3:
5814             if (strEQ(d,"tie"))                 return KEY_tie;
5815             break;
5816         case 4:
5817             if (strEQ(d,"tell"))                return -KEY_tell;
5818             if (strEQ(d,"tied"))                return KEY_tied;
5819             if (strEQ(d,"time"))                return -KEY_time;
5820             break;
5821         case 5:
5822             if (strEQ(d,"times"))               return -KEY_times;
5823             break;
5824         case 7:
5825             if (strEQ(d,"telldir"))             return -KEY_telldir;
5826             break;
5827         case 8:
5828             if (strEQ(d,"truncate"))            return -KEY_truncate;
5829             break;
5830         }
5831         break;
5832     case 'u':
5833         switch (len) {
5834         case 2:
5835             if (strEQ(d,"uc"))                  return -KEY_uc;
5836             break;
5837         case 3:
5838             if (strEQ(d,"use"))                 return KEY_use;
5839             break;
5840         case 5:
5841             if (strEQ(d,"undef"))               return KEY_undef;
5842             if (strEQ(d,"until"))               return KEY_until;
5843             if (strEQ(d,"untie"))               return KEY_untie;
5844             if (strEQ(d,"utime"))               return -KEY_utime;
5845             if (strEQ(d,"umask"))               return -KEY_umask;
5846             break;
5847         case 6:
5848             if (strEQ(d,"unless"))              return KEY_unless;
5849             if (strEQ(d,"unpack"))              return -KEY_unpack;
5850             if (strEQ(d,"unlink"))              return -KEY_unlink;
5851             break;
5852         case 7:
5853            if (strEQ(d,"unshift"))             return -KEY_unshift;
5854             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
5855             break;
5856         }
5857         break;
5858     case 'v':
5859         if (strEQ(d,"values"))                  return -KEY_values;
5860         if (strEQ(d,"vec"))                     return -KEY_vec;
5861         break;
5862     case 'w':
5863         switch (len) {
5864         case 4:
5865             if (strEQ(d,"warn"))                return -KEY_warn;
5866             if (strEQ(d,"wait"))                return -KEY_wait;
5867             break;
5868         case 5:
5869             if (strEQ(d,"while"))               return KEY_while;
5870             if (strEQ(d,"write"))               return -KEY_write;
5871             break;
5872         case 7:
5873             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
5874             break;
5875         case 9:
5876             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
5877             break;
5878         }
5879         break;
5880     case 'x':
5881         if (len == 1)                           return -KEY_x;
5882         if (strEQ(d,"xor"))                     return -KEY_xor;
5883         break;
5884     case 'y':
5885         if (len == 1)                           return KEY_y;
5886         break;
5887     case 'z':
5888         break;
5889     }
5890     return 0;
5891 }
5892
5893 STATIC void
5894 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5895 {
5896     char *w;
5897
5898     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
5899         if (ckWARN(WARN_SYNTAX)) {
5900             int level = 1;
5901             for (w = s+2; *w && level; w++) {
5902                 if (*w == '(')
5903                     ++level;
5904                 else if (*w == ')')
5905                     --level;
5906             }
5907             if (*w)
5908                 for (; *w && isSPACE(*w); w++) ;
5909             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
5910                 Perl_warner(aTHX_ WARN_SYNTAX,
5911                             "%s (...) interpreted as function",name);
5912         }
5913     }
5914     while (s < PL_bufend && isSPACE(*s))
5915         s++;
5916     if (*s == '(')
5917         s++;
5918     while (s < PL_bufend && isSPACE(*s))
5919         s++;
5920     if (isIDFIRST_lazy_if(s,UTF)) {
5921         w = s++;
5922         while (isALNUM_lazy_if(s,UTF))
5923             s++;
5924         while (s < PL_bufend && isSPACE(*s))
5925             s++;
5926         if (*s == ',') {
5927             int kw;
5928             *s = '\0';
5929             kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5930             *s = ',';
5931             if (kw)
5932                 return;
5933             Perl_croak(aTHX_ "No comma allowed after %s", what);
5934         }
5935     }
5936 }
5937
5938 /* Either returns sv, or mortalizes sv and returns a new SV*.
5939    Best used as sv=new_constant(..., sv, ...).
5940    If s, pv are NULL, calls subroutine with one argument,
5941    and type is used with error messages only. */
5942
5943 STATIC SV *
5944 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5945                const char *type)
5946 {
5947     dSP;
5948     HV *table = GvHV(PL_hintgv);                 /* ^H */
5949     SV *res;
5950     SV **cvp;
5951     SV *cv, *typesv;
5952     const char *why1, *why2, *why3;
5953
5954     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5955         SV *msg;
5956
5957         why2 = strEQ(key,"charnames")
5958                ? "(possibly a missing \"use charnames ...\")"
5959                : "";
5960         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
5961                             (type ? type: "undef"), why2);
5962
5963         /* This is convoluted and evil ("goto considered harmful")
5964          * but I do not understand the intricacies of all the different
5965          * failure modes of %^H in here.  The goal here is to make
5966          * the most probable error message user-friendly. --jhi */
5967
5968         goto msgdone;
5969
5970     report:
5971         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
5972                             (type ? type: "undef"), why1, why2, why3);
5973     msgdone:
5974         yyerror(SvPVX(msg));
5975         SvREFCNT_dec(msg);
5976         return sv;
5977     }
5978     cvp = hv_fetch(table, key, strlen(key), FALSE);
5979     if (!cvp || !SvOK(*cvp)) {
5980         why1 = "$^H{";
5981         why2 = key;
5982         why3 = "} is not defined";
5983         goto report;
5984     }
5985     sv_2mortal(sv);                     /* Parent created it permanently */
5986     cv = *cvp;
5987     if (!pv && s)
5988         pv = sv_2mortal(newSVpvn(s, len));
5989     if (type && pv)
5990         typesv = sv_2mortal(newSVpv(type, 0));
5991     else
5992         typesv = &PL_sv_undef;
5993
5994     PUSHSTACKi(PERLSI_OVERLOAD);
5995     ENTER ;
5996     SAVETMPS;
5997
5998     PUSHMARK(SP) ;
5999     EXTEND(sp, 3);
6000     if (pv)
6001         PUSHs(pv);
6002     PUSHs(sv);
6003     if (pv)
6004         PUSHs(typesv);
6005     PUTBACK;
6006     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
6007
6008     SPAGAIN ;
6009
6010     /* Check the eval first */
6011     if (!PL_in_eval && SvTRUE(ERRSV)) {
6012         STRLEN n_a;
6013         sv_catpv(ERRSV, "Propagated");
6014         yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
6015         (void)POPs;
6016         res = SvREFCNT_inc(sv);
6017     }
6018     else {
6019         res = POPs;
6020         (void)SvREFCNT_inc(res);
6021     }
6022
6023     PUTBACK ;
6024     FREETMPS ;
6025     LEAVE ;
6026     POPSTACK;
6027
6028     if (!SvOK(res)) {
6029         why1 = "Call to &{$^H{";
6030         why2 = key;
6031         why3 = "}} did not return a defined value";
6032         sv = res;
6033         goto report;
6034     }
6035
6036     return res;
6037 }
6038
6039 STATIC char *
6040 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
6041 {
6042     register char *d = dest;
6043     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
6044     for (;;) {
6045         if (d >= e)
6046             Perl_croak(aTHX_ ident_too_long);
6047         if (isALNUM(*s))        /* UTF handled below */
6048             *d++ = *s++;
6049         else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6050             *d++ = ':';
6051             *d++ = ':';
6052             s++;
6053         }
6054         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6055             *d++ = *s++;
6056             *d++ = *s++;
6057         }
6058         else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6059             char *t = s + UTF8SKIP(s);
6060             while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6061                 t += UTF8SKIP(t);
6062             if (d + (t - s) > e)
6063                 Perl_croak(aTHX_ ident_too_long);
6064             Copy(s, d, t - s, char);
6065             d += t - s;
6066             s = t;
6067         }
6068         else {
6069             *d = '\0';
6070             *slp = d - dest;
6071             return s;
6072         }
6073     }
6074 }
6075
6076 STATIC char *
6077 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6078 {
6079     register char *d;
6080     register char *e;
6081     char *bracket = 0;
6082     char funny = *s++;
6083
6084     if (isSPACE(*s))
6085         s = skipspace(s);
6086     d = dest;
6087     e = d + destlen - 3;        /* two-character token, ending NUL */
6088     if (isDIGIT(*s)) {
6089         while (isDIGIT(*s)) {
6090             if (d >= e)
6091                 Perl_croak(aTHX_ ident_too_long);
6092             *d++ = *s++;
6093         }
6094     }
6095     else {
6096         for (;;) {
6097             if (d >= e)
6098                 Perl_croak(aTHX_ ident_too_long);
6099             if (isALNUM(*s))    /* UTF handled below */
6100                 *d++ = *s++;
6101             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6102                 *d++ = ':';
6103                 *d++ = ':';
6104                 s++;
6105             }
6106             else if (*s == ':' && s[1] == ':') {
6107                 *d++ = *s++;
6108                 *d++ = *s++;
6109             }
6110             else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6111                 char *t = s + UTF8SKIP(s);
6112                 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6113                     t += UTF8SKIP(t);
6114                 if (d + (t - s) > e)
6115                     Perl_croak(aTHX_ ident_too_long);
6116                 Copy(s, d, t - s, char);
6117                 d += t - s;
6118                 s = t;
6119             }
6120             else
6121                 break;
6122         }
6123     }
6124     *d = '\0';
6125     d = dest;
6126     if (*d) {
6127         if (PL_lex_state != LEX_NORMAL)
6128             PL_lex_state = LEX_INTERPENDMAYBE;
6129         return s;
6130     }
6131     if (*s == '$' && s[1] &&
6132         (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6133     {
6134         return s;
6135     }
6136     if (*s == '{') {
6137         bracket = s;
6138         s++;
6139     }
6140     else if (ck_uni)
6141         check_uni();
6142     if (s < send)
6143         *d = *s++;
6144     d[1] = '\0';
6145     if (*d == '^' && *s && isCONTROLVAR(*s)) {
6146         *d = toCTRL(*s);
6147         s++;
6148     }
6149     if (bracket) {
6150         if (isSPACE(s[-1])) {
6151             while (s < send) {
6152                 char ch = *s++;
6153                 if (!SPACE_OR_TAB(ch)) {
6154                     *d = ch;
6155                     break;
6156                 }
6157             }
6158         }
6159         if (isIDFIRST_lazy_if(d,UTF)) {
6160             d++;
6161             if (UTF) {
6162                 e = s;
6163                 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6164                     e += UTF8SKIP(e);
6165                     while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6166                         e += UTF8SKIP(e);
6167                 }
6168                 Copy(s, d, e - s, char);
6169                 d += e - s;
6170                 s = e;
6171             }
6172             else {
6173                 while ((isALNUM(*s) || *s == ':') && d < e)
6174                     *d++ = *s++;
6175                 if (d >= e)
6176                     Perl_croak(aTHX_ ident_too_long);
6177             }
6178             *d = '\0';
6179             while (s < send && SPACE_OR_TAB(*s)) s++;
6180             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6181                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6182                     const char *brack = *s == '[' ? "[...]" : "{...}";
6183                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
6184                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6185                         funny, dest, brack, funny, dest, brack);
6186                 }
6187                 bracket++;
6188                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6189                 return s;
6190             }
6191         }
6192         /* Handle extended ${^Foo} variables
6193          * 1999-02-27 mjd-perl-patch@plover.com */
6194         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6195                  && isALNUM(*s))
6196         {
6197             d++;
6198             while (isALNUM(*s) && d < e) {
6199                 *d++ = *s++;
6200             }
6201             if (d >= e)
6202                 Perl_croak(aTHX_ ident_too_long);
6203             *d = '\0';
6204         }
6205         if (*s == '}') {
6206             s++;
6207             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
6208                 PL_lex_state = LEX_INTERPEND;
6209             if (funny == '#')
6210                 funny = '@';
6211             if (PL_lex_state == LEX_NORMAL) {
6212                 if (ckWARN(WARN_AMBIGUOUS) &&
6213                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6214                 {
6215                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
6216                         "Ambiguous use of %c{%s} resolved to %c%s",
6217                         funny, dest, funny, dest);
6218                 }
6219             }
6220         }
6221         else {
6222             s = bracket;                /* let the parser handle it */
6223             *dest = '\0';
6224         }
6225     }
6226     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6227         PL_lex_state = LEX_INTERPEND;
6228     return s;
6229 }
6230
6231 void
6232 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
6233 {
6234     if (ch == 'i')
6235         *pmfl |= PMf_FOLD;
6236     else if (ch == 'g')
6237         *pmfl |= PMf_GLOBAL;
6238     else if (ch == 'c')
6239         *pmfl |= PMf_CONTINUE;
6240     else if (ch == 'o')
6241         *pmfl |= PMf_KEEP;
6242     else if (ch == 'm')
6243         *pmfl |= PMf_MULTILINE;
6244     else if (ch == 's')
6245         *pmfl |= PMf_SINGLELINE;
6246     else if (ch == 'x')
6247         *pmfl |= PMf_EXTENDED;
6248 }
6249
6250 STATIC char *
6251 S_scan_pat(pTHX_ char *start, I32 type)
6252 {
6253     PMOP *pm;
6254     char *s;
6255
6256     s = scan_str(start,FALSE,FALSE);
6257     if (!s)
6258         Perl_croak(aTHX_ "Search pattern not terminated");
6259
6260     pm = (PMOP*)newPMOP(type, 0);
6261     if (PL_multi_open == '?')
6262         pm->op_pmflags |= PMf_ONCE;
6263     if(type == OP_QR) {
6264         while (*s && strchr("iomsx", *s))
6265             pmflag(&pm->op_pmflags,*s++);
6266     }
6267     else {
6268         while (*s && strchr("iogcmsx", *s))
6269             pmflag(&pm->op_pmflags,*s++);
6270     }
6271     pm->op_pmpermflags = pm->op_pmflags;
6272
6273     PL_lex_op = (OP*)pm;
6274     yylval.ival = OP_MATCH;
6275     return s;
6276 }
6277
6278 STATIC char *
6279 S_scan_subst(pTHX_ char *start)
6280 {
6281     register char *s;
6282     register PMOP *pm;
6283     I32 first_start;
6284     I32 es = 0;
6285
6286     yylval.ival = OP_NULL;
6287
6288     s = scan_str(start,FALSE,FALSE);
6289
6290     if (!s)
6291         Perl_croak(aTHX_ "Substitution pattern not terminated");
6292
6293     if (s[-1] == PL_multi_open)
6294         s--;
6295
6296     first_start = PL_multi_start;
6297     s = scan_str(s,FALSE,FALSE);
6298     if (!s) {
6299         if (PL_lex_stuff) {
6300             SvREFCNT_dec(PL_lex_stuff);
6301             PL_lex_stuff = Nullsv;
6302         }
6303         Perl_croak(aTHX_ "Substitution replacement not terminated");
6304     }
6305     PL_multi_start = first_start;       /* so whole substitution is taken together */
6306
6307     pm = (PMOP*)newPMOP(OP_SUBST, 0);
6308     while (*s) {
6309         if (*s == 'e') {
6310             s++;
6311             es++;
6312         }
6313         else if (strchr("iogcmsx", *s))
6314             pmflag(&pm->op_pmflags,*s++);
6315         else
6316             break;
6317     }
6318
6319     if (es) {
6320         SV *repl;
6321         PL_sublex_info.super_bufptr = s;
6322         PL_sublex_info.super_bufend = PL_bufend;
6323         PL_multi_end = 0;
6324         pm->op_pmflags |= PMf_EVAL;
6325         repl = newSVpvn("",0);
6326         while (es-- > 0)
6327             sv_catpv(repl, es ? "eval " : "do ");
6328         sv_catpvn(repl, "{ ", 2);
6329         sv_catsv(repl, PL_lex_repl);
6330         sv_catpvn(repl, " };", 2);
6331         SvEVALED_on(repl);
6332         SvREFCNT_dec(PL_lex_repl);
6333         PL_lex_repl = repl;
6334     }
6335
6336     pm->op_pmpermflags = pm->op_pmflags;
6337     PL_lex_op = (OP*)pm;
6338     yylval.ival = OP_SUBST;
6339     return s;
6340 }
6341
6342 STATIC char *
6343 S_scan_trans(pTHX_ char *start)
6344 {
6345     register char* s;
6346     OP *o;
6347     short *tbl;
6348     I32 squash;
6349     I32 del;
6350     I32 complement;
6351
6352     yylval.ival = OP_NULL;
6353
6354     s = scan_str(start,FALSE,FALSE);
6355     if (!s)
6356         Perl_croak(aTHX_ "Transliteration pattern not terminated");
6357     if (s[-1] == PL_multi_open)
6358         s--;
6359
6360     s = scan_str(s,FALSE,FALSE);
6361     if (!s) {
6362         if (PL_lex_stuff) {
6363             SvREFCNT_dec(PL_lex_stuff);
6364             PL_lex_stuff = Nullsv;
6365         }
6366         Perl_croak(aTHX_ "Transliteration replacement not terminated");
6367     }
6368
6369     complement = del = squash = 0;
6370     while (strchr("cds", *s)) {
6371         if (*s == 'c')
6372             complement = OPpTRANS_COMPLEMENT;
6373         else if (*s == 'd')
6374             del = OPpTRANS_DELETE;
6375         else if (*s == 's')
6376             squash = OPpTRANS_SQUASH;
6377         s++;
6378     }
6379
6380     New(803, tbl, complement&&!del?258:256, short);
6381     o = newPVOP(OP_TRANS, 0, (char*)tbl);
6382     o->op_private = del|squash|complement|
6383       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6384       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
6385
6386     PL_lex_op = o;
6387     yylval.ival = OP_TRANS;
6388     return s;
6389 }
6390
6391 STATIC char *
6392 S_scan_heredoc(pTHX_ register char *s)
6393 {
6394     SV *herewas;
6395     I32 op_type = OP_SCALAR;
6396     I32 len;
6397     SV *tmpstr;
6398     char term;
6399     register char *d;
6400     register char *e;
6401     char *peek;
6402     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6403
6404     s += 2;
6405     d = PL_tokenbuf;
6406     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6407     if (!outer)
6408         *d++ = '\n';
6409     for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6410     if (*peek && strchr("`'\"",*peek)) {
6411         s = peek;
6412         term = *s++;
6413         s = delimcpy(d, e, s, PL_bufend, term, &len);
6414         d += len;
6415         if (s < PL_bufend)
6416             s++;
6417     }
6418     else {
6419         if (*s == '\\')
6420             s++, term = '\'';
6421         else
6422             term = '"';
6423         if (!isALNUM_lazy_if(s,UTF))
6424             deprecate("bare << to mean <<\"\"");
6425         for (; isALNUM_lazy_if(s,UTF); s++) {
6426             if (d < e)
6427                 *d++ = *s;
6428         }
6429     }
6430     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6431         Perl_croak(aTHX_ "Delimiter for here document is too long");
6432     *d++ = '\n';
6433     *d = '\0';
6434     len = d - PL_tokenbuf;
6435 #ifndef PERL_STRICT_CR
6436     d = strchr(s, '\r');
6437     if (d) {
6438         char *olds = s;
6439         s = d;
6440         while (s < PL_bufend) {
6441             if (*s == '\r') {
6442                 *d++ = '\n';
6443                 if (*++s == '\n')
6444                     s++;
6445             }
6446             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
6447                 *d++ = *s++;
6448                 s++;
6449             }
6450             else
6451                 *d++ = *s++;
6452         }
6453         *d = '\0';
6454         PL_bufend = d;
6455         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6456         s = olds;
6457     }
6458 #endif
6459     d = "\n";
6460     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6461         herewas = newSVpvn(s,PL_bufend-s);
6462     else
6463         s--, herewas = newSVpvn(s,d-s);
6464     s += SvCUR(herewas);
6465
6466     tmpstr = NEWSV(87,79);
6467     sv_upgrade(tmpstr, SVt_PVIV);
6468     if (term == '\'') {
6469         op_type = OP_CONST;
6470         SvIVX(tmpstr) = -1;
6471     }
6472     else if (term == '`') {
6473         op_type = OP_BACKTICK;
6474         SvIVX(tmpstr) = '\\';
6475     }
6476
6477     CLINE;
6478     PL_multi_start = CopLINE(PL_curcop);
6479     PL_multi_open = PL_multi_close = '<';
6480     term = *PL_tokenbuf;
6481     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6482         char *bufptr = PL_sublex_info.super_bufptr;
6483         char *bufend = PL_sublex_info.super_bufend;
6484         char *olds = s - SvCUR(herewas);
6485         s = strchr(bufptr, '\n');
6486         if (!s)
6487             s = bufend;
6488         d = s;
6489         while (s < bufend &&
6490           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6491             if (*s++ == '\n')
6492                 CopLINE_inc(PL_curcop);
6493         }
6494         if (s >= bufend) {
6495             CopLINE_set(PL_curcop, PL_multi_start);
6496             missingterm(PL_tokenbuf);
6497         }
6498         sv_setpvn(herewas,bufptr,d-bufptr+1);
6499         sv_setpvn(tmpstr,d+1,s-d);
6500         s += len - 1;
6501         sv_catpvn(herewas,s,bufend-s);
6502         (void)strcpy(bufptr,SvPVX(herewas));
6503
6504         s = olds;
6505         goto retval;
6506     }
6507     else if (!outer) {
6508         d = s;
6509         while (s < PL_bufend &&
6510           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6511             if (*s++ == '\n')
6512                 CopLINE_inc(PL_curcop);
6513         }
6514         if (s >= PL_bufend) {
6515             CopLINE_set(PL_curcop, PL_multi_start);
6516             missingterm(PL_tokenbuf);
6517         }
6518         sv_setpvn(tmpstr,d+1,s-d);
6519         s += len - 1;
6520         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6521
6522         sv_catpvn(herewas,s,PL_bufend-s);
6523         sv_setsv(PL_linestr,herewas);
6524         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6525         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6526         PL_last_lop = PL_last_uni = Nullch;
6527     }
6528     else
6529         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
6530     while (s >= PL_bufend) {    /* multiple line string? */
6531         if (!outer ||
6532          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6533             CopLINE_set(PL_curcop, PL_multi_start);
6534             missingterm(PL_tokenbuf);
6535         }
6536         CopLINE_inc(PL_curcop);
6537         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6538         PL_last_lop = PL_last_uni = Nullch;
6539 #ifndef PERL_STRICT_CR
6540         if (PL_bufend - PL_linestart >= 2) {
6541             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6542                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6543             {
6544                 PL_bufend[-2] = '\n';
6545                 PL_bufend--;
6546                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6547             }
6548             else if (PL_bufend[-1] == '\r')
6549                 PL_bufend[-1] = '\n';
6550         }
6551         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6552             PL_bufend[-1] = '\n';
6553 #endif
6554         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6555             SV *sv = NEWSV(88,0);
6556
6557             sv_upgrade(sv, SVt_PVMG);
6558             sv_setsv(sv,PL_linestr);
6559             (void)SvIOK_on(sv);
6560             SvIVX(sv) = 0;
6561             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6562         }
6563         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6564             s = PL_bufend - 1;
6565             *s = ' ';
6566             sv_catsv(PL_linestr,herewas);
6567             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6568         }
6569         else {
6570             s = PL_bufend;
6571             sv_catsv(tmpstr,PL_linestr);
6572         }
6573     }
6574     s++;
6575 retval:
6576     PL_multi_end = CopLINE(PL_curcop);
6577     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6578         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6579         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6580     }
6581     SvREFCNT_dec(herewas);
6582     if (UTF && !IN_BYTES && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6583         SvUTF8_on(tmpstr);
6584     PL_lex_stuff = tmpstr;
6585     yylval.ival = op_type;
6586     return s;
6587 }
6588
6589 /* scan_inputsymbol
6590    takes: current position in input buffer
6591    returns: new position in input buffer
6592    side-effects: yylval and lex_op are set.
6593
6594    This code handles:
6595
6596    <>           read from ARGV
6597    <FH>         read from filehandle
6598    <pkg::FH>    read from package qualified filehandle
6599    <pkg'FH>     read from package qualified filehandle
6600    <$fh>        read from filehandle in $fh
6601    <*.h>        filename glob
6602
6603 */
6604
6605 STATIC char *
6606 S_scan_inputsymbol(pTHX_ char *start)
6607 {
6608     register char *s = start;           /* current position in buffer */
6609     register char *d;
6610     register char *e;
6611     char *end;
6612     I32 len;
6613
6614     d = PL_tokenbuf;                    /* start of temp holding space */
6615     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
6616     end = strchr(s, '\n');
6617     if (!end)
6618         end = PL_bufend;
6619     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
6620
6621     /* die if we didn't have space for the contents of the <>,
6622        or if it didn't end, or if we see a newline
6623     */
6624
6625     if (len >= sizeof PL_tokenbuf)
6626         Perl_croak(aTHX_ "Excessively long <> operator");
6627     if (s >= end)
6628         Perl_croak(aTHX_ "Unterminated <> operator");
6629
6630     s++;
6631
6632     /* check for <$fh>
6633        Remember, only scalar variables are interpreted as filehandles by
6634        this code.  Anything more complex (e.g., <$fh{$num}>) will be
6635        treated as a glob() call.
6636        This code makes use of the fact that except for the $ at the front,
6637        a scalar variable and a filehandle look the same.
6638     */
6639     if (*d == '$' && d[1]) d++;
6640
6641     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6642     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6643         d++;
6644
6645     /* If we've tried to read what we allow filehandles to look like, and
6646        there's still text left, then it must be a glob() and not a getline.
6647        Use scan_str to pull out the stuff between the <> and treat it
6648        as nothing more than a string.
6649     */
6650
6651     if (d - PL_tokenbuf != len) {
6652         yylval.ival = OP_GLOB;
6653         set_csh();
6654         s = scan_str(start,FALSE,FALSE);
6655         if (!s)
6656            Perl_croak(aTHX_ "Glob not terminated");
6657         return s;
6658     }
6659     else {
6660         /* we're in a filehandle read situation */
6661         d = PL_tokenbuf;
6662
6663         /* turn <> into <ARGV> */
6664         if (!len)
6665             (void)strcpy(d,"ARGV");
6666
6667         /* if <$fh>, create the ops to turn the variable into a
6668            filehandle
6669         */
6670         if (*d == '$') {
6671             I32 tmp;
6672
6673             /* try to find it in the pad for this block, otherwise find
6674                add symbol table ops
6675             */
6676             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6677                 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
6678                 if (SvFLAGS(namesv) & SVpad_OUR) {
6679                     SV *sym = sv_2mortal(newSVpv(HvNAME(GvSTASH(namesv)),0));
6680                     sv_catpvn(sym, "::", 2);
6681                     sv_catpv(sym, d+1);
6682                     d = SvPVX(sym);
6683                     goto intro_sym;
6684                 }
6685                 else {
6686                     OP *o = newOP(OP_PADSV, 0);
6687                     o->op_targ = tmp;
6688                     PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6689                 }
6690             }
6691             else {
6692                 GV *gv;
6693                 ++d;
6694 intro_sym:
6695                 gv = gv_fetchpv(d,
6696                                 (PL_in_eval
6697                                  ? (GV_ADDMULTI | GV_ADDINEVAL)
6698                                  : GV_ADDMULTI),
6699                                 SVt_PV);
6700                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6701                                             newUNOP(OP_RV2SV, 0,
6702                                                 newGVOP(OP_GV, 0, gv)));
6703             }
6704             PL_lex_op->op_flags |= OPf_SPECIAL;
6705             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6706             yylval.ival = OP_NULL;
6707         }
6708
6709         /* If it's none of the above, it must be a literal filehandle
6710            (<Foo::BAR> or <FOO>) so build a simple readline OP */
6711         else {
6712             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6713             PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6714             yylval.ival = OP_NULL;
6715         }
6716     }
6717
6718     return s;
6719 }
6720
6721
6722 /* scan_str
6723    takes: start position in buffer
6724           keep_quoted preserve \ on the embedded delimiter(s)
6725           keep_delims preserve the delimiters around the string
6726    returns: position to continue reading from buffer
6727    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6728         updates the read buffer.
6729
6730    This subroutine pulls a string out of the input.  It is called for:
6731         q               single quotes           q(literal text)
6732         '               single quotes           'literal text'
6733         qq              double quotes           qq(interpolate $here please)
6734         "               double quotes           "interpolate $here please"
6735         qx              backticks               qx(/bin/ls -l)
6736         `               backticks               `/bin/ls -l`
6737         qw              quote words             @EXPORT_OK = qw( func() $spam )
6738         m//             regexp match            m/this/
6739         s///            regexp substitute       s/this/that/
6740         tr///           string transliterate    tr/this/that/
6741         y///            string transliterate    y/this/that/
6742         ($*@)           sub prototypes          sub foo ($)
6743         (stuff)         sub attr parameters     sub foo : attr(stuff)
6744         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
6745
6746    In most of these cases (all but <>, patterns and transliterate)
6747    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
6748    calls scan_str().  s/// makes yylex() call scan_subst() which calls
6749    scan_str().  tr/// and y/// make yylex() call scan_trans() which
6750    calls scan_str().
6751
6752    It skips whitespace before the string starts, and treats the first
6753    character as the delimiter.  If the delimiter is one of ([{< then
6754    the corresponding "close" character )]}> is used as the closing
6755    delimiter.  It allows quoting of delimiters, and if the string has
6756    balanced delimiters ([{<>}]) it allows nesting.
6757
6758    On success, the SV with the resulting string is put into lex_stuff or,
6759    if that is already non-NULL, into lex_repl. The second case occurs only
6760    when parsing the RHS of the special constructs s/// and tr/// (y///).
6761    For convenience, the terminating delimiter character is stuffed into
6762    SvIVX of the SV.
6763 */
6764
6765 STATIC char *
6766 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6767 {
6768     SV *sv;                             /* scalar value: string */
6769     char *tmps;                         /* temp string, used for delimiter matching */
6770     register char *s = start;           /* current position in the buffer */
6771     register char term;                 /* terminating character */
6772     register char *to;                  /* current position in the sv's data */
6773     I32 brackets = 1;                   /* bracket nesting level */
6774     bool has_utf8 = FALSE;              /* is there any utf8 content? */
6775
6776     /* skip space before the delimiter */
6777     if (isSPACE(*s))
6778         s = skipspace(s);
6779
6780     /* mark where we are, in case we need to report errors */
6781     CLINE;
6782
6783     /* after skipping whitespace, the next character is the terminator */
6784     term = *s;
6785     if (!UTF8_IS_INVARIANT((U8)term) && UTF)
6786         has_utf8 = TRUE;
6787
6788     /* mark where we are */
6789     PL_multi_start = CopLINE(PL_curcop);
6790     PL_multi_open = term;
6791
6792     /* find corresponding closing delimiter */
6793     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6794         term = tmps[5];
6795     PL_multi_close = term;
6796
6797     /* create a new SV to hold the contents.  87 is leak category, I'm
6798        assuming.  79 is the SV's initial length.  What a random number. */
6799     sv = NEWSV(87,79);
6800     sv_upgrade(sv, SVt_PVIV);
6801     SvIVX(sv) = term;
6802     (void)SvPOK_only(sv);               /* validate pointer */
6803
6804     /* move past delimiter and try to read a complete string */
6805     if (keep_delims)
6806         sv_catpvn(sv, s, 1);
6807     s++;
6808     for (;;) {
6809         /* extend sv if need be */
6810         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6811         /* set 'to' to the next character in the sv's string */
6812         to = SvPVX(sv)+SvCUR(sv);
6813
6814         /* if open delimiter is the close delimiter read unbridle */
6815         if (PL_multi_open == PL_multi_close) {
6816             for (; s < PL_bufend; s++,to++) {
6817                 /* embedded newlines increment the current line number */
6818                 if (*s == '\n' && !PL_rsfp)
6819                     CopLINE_inc(PL_curcop);
6820                 /* handle quoted delimiters */
6821                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6822                     if (!keep_quoted && s[1] == term)
6823                         s++;
6824                 /* any other quotes are simply copied straight through */
6825                     else
6826                         *to++ = *s++;
6827                 }
6828                 /* terminate when run out of buffer (the for() condition), or
6829                    have found the terminator */
6830                 else if (*s == term)
6831                     break;
6832                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6833                     has_utf8 = TRUE;
6834                 *to = *s;
6835             }
6836         }
6837
6838         /* if the terminator isn't the same as the start character (e.g.,
6839            matched brackets), we have to allow more in the quoting, and
6840            be prepared for nested brackets.
6841         */
6842         else {
6843             /* read until we run out of string, or we find the terminator */
6844             for (; s < PL_bufend; s++,to++) {
6845                 /* embedded newlines increment the line count */
6846                 if (*s == '\n' && !PL_rsfp)
6847                     CopLINE_inc(PL_curcop);
6848                 /* backslashes can escape the open or closing characters */
6849                 if (*s == '\\' && s+1 < PL_bufend) {
6850                     if (!keep_quoted &&
6851                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6852                         s++;
6853                     else
6854                         *to++ = *s++;
6855                 }
6856                 /* allow nested opens and closes */
6857                 else if (*s == PL_multi_close && --brackets <= 0)
6858                     break;
6859                 else if (*s == PL_multi_open)
6860                     brackets++;
6861                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6862                     has_utf8 = TRUE;
6863                 *to = *s;
6864             }
6865         }
6866         /* terminate the copied string and update the sv's end-of-string */
6867         *to = '\0';
6868         SvCUR_set(sv, to - SvPVX(sv));
6869
6870         /*
6871          * this next chunk reads more into the buffer if we're not done yet
6872          */
6873
6874         if (s < PL_bufend)
6875             break;              /* handle case where we are done yet :-) */
6876
6877 #ifndef PERL_STRICT_CR
6878         if (to - SvPVX(sv) >= 2) {
6879             if ((to[-2] == '\r' && to[-1] == '\n') ||
6880                 (to[-2] == '\n' && to[-1] == '\r'))
6881             {
6882                 to[-2] = '\n';
6883                 to--;
6884                 SvCUR_set(sv, to - SvPVX(sv));
6885             }
6886             else if (to[-1] == '\r')
6887                 to[-1] = '\n';
6888         }
6889         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6890             to[-1] = '\n';
6891 #endif
6892
6893         /* if we're out of file, or a read fails, bail and reset the current
6894            line marker so we can report where the unterminated string began
6895         */
6896         if (!PL_rsfp ||
6897          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6898             sv_free(sv);
6899             CopLINE_set(PL_curcop, PL_multi_start);
6900             return Nullch;
6901         }
6902         /* we read a line, so increment our line counter */
6903         CopLINE_inc(PL_curcop);
6904
6905         /* update debugger info */
6906         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6907             SV *sv = NEWSV(88,0);
6908
6909             sv_upgrade(sv, SVt_PVMG);
6910             sv_setsv(sv,PL_linestr);
6911             (void)SvIOK_on(sv);
6912             SvIVX(sv) = 0;
6913             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6914         }
6915
6916         /* having changed the buffer, we must update PL_bufend */
6917         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6918         PL_last_lop = PL_last_uni = Nullch;
6919     }
6920
6921     /* at this point, we have successfully read the delimited string */
6922
6923     if (keep_delims)
6924         sv_catpvn(sv, s, 1);
6925     if (has_utf8)
6926         SvUTF8_on(sv);
6927     PL_multi_end = CopLINE(PL_curcop);
6928     s++;
6929
6930     /* if we allocated too much space, give some back */
6931     if (SvCUR(sv) + 5 < SvLEN(sv)) {
6932         SvLEN_set(sv, SvCUR(sv) + 1);
6933         Renew(SvPVX(sv), SvLEN(sv), char);
6934     }
6935
6936     /* decide whether this is the first or second quoted string we've read
6937        for this op
6938     */
6939
6940     if (PL_lex_stuff)
6941         PL_lex_repl = sv;
6942     else
6943         PL_lex_stuff = sv;
6944     return s;
6945 }
6946
6947 /*
6948   scan_num
6949   takes: pointer to position in buffer
6950   returns: pointer to new position in buffer
6951   side-effects: builds ops for the constant in yylval.op
6952
6953   Read a number in any of the formats that Perl accepts:
6954
6955   \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)      12 12.34 12.
6956   \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                     .34
6957   0b[01](_?[01])*
6958   0[0-7](_?[0-7])*
6959   0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
6960
6961   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6962   thing it reads.
6963
6964   If it reads a number without a decimal point or an exponent, it will
6965   try converting the number to an integer and see if it can do so
6966   without loss of precision.
6967 */
6968
6969 char *
6970 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
6971 {
6972     register char *s = start;           /* current position in buffer */
6973     register char *d;                   /* destination in temp buffer */
6974     register char *e;                   /* end of temp buffer */
6975     NV nv;                              /* number read, as a double */
6976     SV *sv = Nullsv;                    /* place to put the converted number */
6977     bool floatit;                       /* boolean: int or float? */
6978     char *lastub = 0;                   /* position of last underbar */
6979     static char number_too_long[] = "Number too long";
6980
6981     /* We use the first character to decide what type of number this is */
6982
6983     switch (*s) {
6984     default:
6985       Perl_croak(aTHX_ "panic: scan_num");
6986
6987     /* if it starts with a 0, it could be an octal number, a decimal in
6988        0.13 disguise, or a hexadecimal number, or a binary number. */
6989     case '0':
6990         {
6991           /* variables:
6992              u          holds the "number so far"
6993              shift      the power of 2 of the base
6994                         (hex == 4, octal == 3, binary == 1)
6995              overflowed was the number more than we can hold?
6996
6997              Shift is used when we add a digit.  It also serves as an "are
6998              we in octal/hex/binary?" indicator to disallow hex characters
6999              when in octal mode.
7000            */
7001             NV n = 0.0;
7002             UV u = 0;
7003             I32 shift;
7004             bool overflowed = FALSE;
7005             static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
7006             static char* bases[5] = { "", "binary", "", "octal",
7007                                       "hexadecimal" };
7008             static char* Bases[5] = { "", "Binary", "", "Octal",
7009                                       "Hexadecimal" };
7010             static char *maxima[5] = { "",
7011                                        "0b11111111111111111111111111111111",
7012                                        "",
7013                                        "037777777777",
7014                                        "0xffffffff" };
7015             char *base, *Base, *max;
7016
7017             /* check for hex */
7018             if (s[1] == 'x') {
7019                 shift = 4;
7020                 s += 2;
7021             } else if (s[1] == 'b') {
7022                 shift = 1;
7023                 s += 2;
7024             }
7025             /* check for a decimal in disguise */
7026             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
7027                 goto decimal;
7028             /* so it must be octal */
7029             else {
7030                 shift = 3;
7031                 s++;
7032             }
7033
7034             if (*s == '_') {
7035                if (ckWARN(WARN_SYNTAX))
7036                    Perl_warner(aTHX_ WARN_SYNTAX,
7037                                "Misplaced _ in number");
7038                lastub = s++;
7039             }
7040
7041             base = bases[shift];
7042             Base = Bases[shift];
7043             max  = maxima[shift];
7044
7045             /* read the rest of the number */
7046             for (;;) {
7047                 /* x is used in the overflow test,
7048                    b is the digit we're adding on. */
7049                 UV x, b;
7050
7051                 switch (*s) {
7052
7053                 /* if we don't mention it, we're done */
7054                 default:
7055                     goto out;
7056
7057                 /* _ are ignored -- but warned about if consecutive */
7058                 case '_':
7059                     if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7060                         Perl_warner(aTHX_ WARN_SYNTAX,
7061                                     "Misplaced _ in number");
7062                     lastub = s++;
7063                     break;
7064
7065                 /* 8 and 9 are not octal */
7066                 case '8': case '9':
7067                     if (shift == 3)
7068                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7069                     /* FALL THROUGH */
7070
7071                 /* octal digits */
7072                 case '2': case '3': case '4':
7073                 case '5': case '6': case '7':
7074                     if (shift == 1)
7075                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7076                     /* FALL THROUGH */
7077
7078                 case '0': case '1':
7079                     b = *s++ & 15;              /* ASCII digit -> value of digit */
7080                     goto digit;
7081
7082                 /* hex digits */
7083                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7084                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7085                     /* make sure they said 0x */
7086                     if (shift != 4)
7087                         goto out;
7088                     b = (*s++ & 7) + 9;
7089
7090                     /* Prepare to put the digit we have onto the end
7091                        of the number so far.  We check for overflows.
7092                     */
7093
7094                   digit:
7095                     if (!overflowed) {
7096                         x = u << shift; /* make room for the digit */
7097
7098                         if ((x >> shift) != u
7099                             && !(PL_hints & HINT_NEW_BINARY)) {
7100                             overflowed = TRUE;
7101                             n = (NV) u;
7102                             if (ckWARN_d(WARN_OVERFLOW))
7103                                 Perl_warner(aTHX_ WARN_OVERFLOW,
7104                                             "Integer overflow in %s number",
7105                                             base);
7106                         } else
7107                             u = x | b;          /* add the digit to the end */
7108                     }
7109                     if (overflowed) {
7110                         n *= nvshift[shift];
7111                         /* If an NV has not enough bits in its
7112                          * mantissa to represent an UV this summing of
7113                          * small low-order numbers is a waste of time
7114                          * (because the NV cannot preserve the
7115                          * low-order bits anyway): we could just
7116                          * remember when did we overflow and in the
7117                          * end just multiply n by the right
7118                          * amount. */
7119                         n += (NV) b;
7120                     }
7121                     break;
7122                 }
7123             }
7124
7125           /* if we get here, we had success: make a scalar value from
7126              the number.
7127           */
7128           out:
7129
7130             /* final misplaced underbar check */
7131             if (s[-1] == '_') {
7132                 if (ckWARN(WARN_SYNTAX))
7133                     Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7134             }
7135
7136             sv = NEWSV(92,0);
7137             if (overflowed) {
7138                 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7139                     Perl_warner(aTHX_ WARN_PORTABLE,
7140                                 "%s number > %s non-portable",
7141                                 Base, max);
7142                 sv_setnv(sv, n);
7143             }
7144             else {
7145 #if UVSIZE > 4
7146                 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7147                     Perl_warner(aTHX_ WARN_PORTABLE,
7148                                 "%s number > %s non-portable",
7149                                 Base, max);
7150 #endif
7151                 sv_setuv(sv, u);
7152             }
7153             if (PL_hints & HINT_NEW_BINARY)
7154                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7155         }
7156         break;
7157
7158     /*
7159       handle decimal numbers.
7160       we're also sent here when we read a 0 as the first digit
7161     */
7162     case '1': case '2': case '3': case '4': case '5':
7163     case '6': case '7': case '8': case '9': case '.':
7164       decimal:
7165         d = PL_tokenbuf;
7166         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7167         floatit = FALSE;
7168
7169         /* read next group of digits and _ and copy into d */
7170         while (isDIGIT(*s) || *s == '_') {
7171             /* skip underscores, checking for misplaced ones
7172                if -w is on
7173             */
7174             if (*s == '_') {
7175                 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7176                     Perl_warner(aTHX_ WARN_SYNTAX,
7177                                 "Misplaced _ in number");
7178                 lastub = s++;
7179             }
7180             else {
7181                 /* check for end of fixed-length buffer */
7182                 if (d >= e)
7183                     Perl_croak(aTHX_ number_too_long);
7184                 /* if we're ok, copy the character */
7185                 *d++ = *s++;
7186             }
7187         }
7188
7189         /* final misplaced underbar check */
7190         if (lastub && s == lastub + 1) {
7191             if (ckWARN(WARN_SYNTAX))
7192                 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7193         }
7194
7195         /* read a decimal portion if there is one.  avoid
7196            3..5 being interpreted as the number 3. followed
7197            by .5
7198         */
7199         if (*s == '.' && s[1] != '.') {
7200             floatit = TRUE;
7201             *d++ = *s++;
7202
7203             if (*s == '_') {
7204                 if (ckWARN(WARN_SYNTAX))
7205                     Perl_warner(aTHX_ WARN_SYNTAX,
7206                                 "Misplaced _ in number");
7207                 lastub = s;
7208             }
7209
7210             /* copy, ignoring underbars, until we run out of digits.
7211             */
7212             for (; isDIGIT(*s) || *s == '_'; s++) {
7213                 /* fixed length buffer check */
7214                 if (d >= e)
7215                     Perl_croak(aTHX_ number_too_long);
7216                 if (*s == '_') {
7217                    if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7218                        Perl_warner(aTHX_ WARN_SYNTAX,
7219                                    "Misplaced _ in number");
7220                    lastub = s;
7221                 }
7222                 else
7223                     *d++ = *s;
7224             }
7225             /* fractional part ending in underbar? */
7226             if (s[-1] == '_') {
7227                 if (ckWARN(WARN_SYNTAX))
7228                     Perl_warner(aTHX_ WARN_SYNTAX,
7229                                 "Misplaced _ in number");
7230             }
7231             if (*s == '.' && isDIGIT(s[1])) {
7232                 /* oops, it's really a v-string, but without the "v" */
7233                 s = start;
7234                 goto vstring;
7235             }
7236         }
7237
7238         /* read exponent part, if present */
7239         if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
7240             floatit = TRUE;
7241             s++;
7242
7243             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7244             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
7245
7246             /* stray preinitial _ */
7247             if (*s == '_') {
7248                 if (ckWARN(WARN_SYNTAX))
7249                     Perl_warner(aTHX_ WARN_SYNTAX,
7250                                 "Misplaced _ in number");
7251                 lastub = s++;
7252             }
7253
7254             /* allow positive or negative exponent */
7255             if (*s == '+' || *s == '-')
7256                 *d++ = *s++;
7257
7258             /* stray initial _ */
7259             if (*s == '_') {
7260                 if (ckWARN(WARN_SYNTAX))
7261                     Perl_warner(aTHX_ WARN_SYNTAX,
7262                                 "Misplaced _ in number");
7263                 lastub = s++;
7264             }
7265
7266             /* read digits of exponent */
7267             while (isDIGIT(*s) || *s == '_') {
7268                 if (isDIGIT(*s)) {
7269                     if (d >= e)
7270                         Perl_croak(aTHX_ number_too_long);
7271                     *d++ = *s++;
7272                 }
7273                 else {
7274                    if (ckWARN(WARN_SYNTAX) &&
7275                        ((lastub && s == lastub + 1) ||
7276                         (!isDIGIT(s[1]) && s[1] != '_')))
7277                        Perl_warner(aTHX_ WARN_SYNTAX,
7278                                    "Misplaced _ in number");
7279                    lastub = s++;
7280                 }
7281             }
7282         }
7283
7284
7285         /* make an sv from the string */
7286         sv = NEWSV(92,0);
7287
7288         /*
7289            We try to do an integer conversion first if no characters
7290            indicating "float" have been found.
7291          */
7292
7293         if (!floatit) {
7294             UV uv;
7295             int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7296
7297             if (flags == IS_NUMBER_IN_UV) {
7298               if (uv <= IV_MAX)
7299                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7300               else
7301                 sv_setuv(sv, uv);
7302             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
7303               if (uv <= (UV) IV_MIN)
7304                 sv_setiv(sv, -(IV)uv);
7305               else
7306                 floatit = TRUE;
7307             } else
7308               floatit = TRUE;
7309         }
7310         if (floatit) {
7311             /* terminate the string */
7312             *d = '\0';
7313             nv = Atof(PL_tokenbuf);
7314             sv_setnv(sv, nv);
7315         }
7316
7317         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7318                        (PL_hints & HINT_NEW_INTEGER) )
7319             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7320                               (floatit ? "float" : "integer"),
7321                               sv, Nullsv, NULL);
7322         break;
7323
7324     /* if it starts with a v, it could be a v-string */
7325     case 'v':
7326 vstring:
7327                 sv = NEWSV(92,5); /* preallocate storage space */
7328                 s = new_vstring(s,sv);
7329         break;
7330     }
7331
7332     /* make the op for the constant and return */
7333
7334     if (sv)
7335         lvalp->opval = newSVOP(OP_CONST, 0, sv);
7336     else
7337         lvalp->opval = Nullop;
7338
7339     return s;
7340 }
7341
7342 STATIC char *
7343 S_scan_formline(pTHX_ register char *s)
7344 {
7345     register char *eol;
7346     register char *t;
7347     SV *stuff = newSVpvn("",0);
7348     bool needargs = FALSE;
7349
7350     while (!needargs) {
7351         if (*s == '.' || *s == /*{*/'}') {
7352             /*SUPPRESS 530*/
7353 #ifdef PERL_STRICT_CR
7354             for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7355 #else
7356             for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7357 #endif
7358             if (*t == '\n' || t == PL_bufend)
7359                 break;
7360         }
7361         if (PL_in_eval && !PL_rsfp) {
7362             eol = strchr(s,'\n');
7363             if (!eol++)
7364                 eol = PL_bufend;
7365         }
7366         else
7367             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7368         if (*s != '#') {
7369             for (t = s; t < eol; t++) {
7370                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7371                     needargs = FALSE;
7372                     goto enough;        /* ~~ must be first line in formline */
7373                 }
7374                 if (*t == '@' || *t == '^')
7375                     needargs = TRUE;
7376             }
7377             if (eol > s) {
7378                 sv_catpvn(stuff, s, eol-s);
7379 #ifndef PERL_STRICT_CR
7380                 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7381                     char *end = SvPVX(stuff) + SvCUR(stuff);
7382                     end[-2] = '\n';
7383                     end[-1] = '\0';
7384                     SvCUR(stuff)--;
7385                 }
7386 #endif
7387             }
7388             else
7389               break;
7390         }
7391         s = eol;
7392         if (PL_rsfp) {
7393             s = filter_gets(PL_linestr, PL_rsfp, 0);
7394             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7395             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7396             PL_last_lop = PL_last_uni = Nullch;
7397             if (!s) {
7398                 s = PL_bufptr;
7399                 yyerror("Format not terminated");
7400                 break;
7401             }
7402         }
7403         incline(s);
7404     }
7405   enough:
7406     if (SvCUR(stuff)) {
7407         PL_expect = XTERM;
7408         if (needargs) {
7409             PL_lex_state = LEX_NORMAL;
7410             PL_nextval[PL_nexttoke].ival = 0;
7411             force_next(',');
7412         }
7413         else
7414             PL_lex_state = LEX_FORMLINE;
7415         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7416         force_next(THING);
7417         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7418         force_next(LSTOP);
7419     }
7420     else {
7421         SvREFCNT_dec(stuff);
7422         PL_lex_formbrack = 0;
7423         PL_bufptr = s;
7424     }
7425     return s;
7426 }
7427
7428 STATIC void
7429 S_set_csh(pTHX)
7430 {
7431 #ifdef CSH
7432     if (!PL_cshlen)
7433         PL_cshlen = strlen(PL_cshname);
7434 #endif
7435 }
7436
7437 I32
7438 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7439 {
7440     I32 oldsavestack_ix = PL_savestack_ix;
7441     CV* outsidecv = PL_compcv;
7442     AV* comppadlist;
7443
7444     if (PL_compcv) {
7445         assert(SvTYPE(PL_compcv) == SVt_PVCV);
7446     }
7447     SAVEI32(PL_subline);
7448     save_item(PL_subname);
7449     SAVEI32(PL_padix);
7450     SAVECOMPPAD();
7451     SAVESPTR(PL_comppad_name);
7452     SAVESPTR(PL_compcv);
7453     SAVEI32(PL_comppad_name_fill);
7454     SAVEI32(PL_min_intro_pending);
7455     SAVEI32(PL_max_intro_pending);
7456     SAVEI32(PL_pad_reset_pending);
7457
7458     PL_compcv = (CV*)NEWSV(1104,0);
7459     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7460     CvFLAGS(PL_compcv) |= flags;
7461
7462     PL_comppad = newAV();
7463     av_push(PL_comppad, Nullsv);
7464     PL_curpad = AvARRAY(PL_comppad);
7465     PL_comppad_name = newAV();
7466     PL_comppad_name_fill = 0;
7467     PL_min_intro_pending = 0;
7468     PL_padix = 0;
7469     PL_subline = CopLINE(PL_curcop);
7470 #ifdef USE_5005THREADS
7471     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7472     PL_curpad[0] = (SV*)newAV();
7473     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
7474 #endif /* USE_5005THREADS */
7475
7476     comppadlist = newAV();
7477     AvREAL_off(comppadlist);
7478     av_store(comppadlist, 0, (SV*)PL_comppad_name);
7479     av_store(comppadlist, 1, (SV*)PL_comppad);
7480
7481     CvPADLIST(PL_compcv) = comppadlist;
7482     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7483 #ifdef USE_5005THREADS
7484     CvOWNER(PL_compcv) = 0;
7485     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7486     MUTEX_INIT(CvMUTEXP(PL_compcv));
7487 #endif /* USE_5005THREADS */
7488
7489     return oldsavestack_ix;
7490 }
7491
7492 #ifdef __SC__
7493 #pragma segment Perl_yylex
7494 #endif
7495 int
7496 Perl_yywarn(pTHX_ char *s)
7497 {
7498     PL_in_eval |= EVAL_WARNONLY;
7499     yyerror(s);
7500     PL_in_eval &= ~EVAL_WARNONLY;
7501     return 0;
7502 }
7503
7504 int
7505 Perl_yyerror(pTHX_ char *s)
7506 {
7507     char *where = NULL;
7508     char *context = NULL;
7509     int contlen = -1;
7510     SV *msg;
7511
7512     if (!yychar || (yychar == ';' && !PL_rsfp))
7513         where = "at EOF";
7514     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7515       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7516         while (isSPACE(*PL_oldoldbufptr))
7517             PL_oldoldbufptr++;
7518         context = PL_oldoldbufptr;
7519         contlen = PL_bufptr - PL_oldoldbufptr;
7520     }
7521     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7522       PL_oldbufptr != PL_bufptr) {
7523         while (isSPACE(*PL_oldbufptr))
7524             PL_oldbufptr++;
7525         context = PL_oldbufptr;
7526         contlen = PL_bufptr - PL_oldbufptr;
7527     }
7528     else if (yychar > 255)
7529         where = "next token ???";
7530 #ifdef USE_PURE_BISON
7531 /*  GNU Bison sets the value -2 */
7532     else if (yychar == -2) {
7533 #else
7534     else if ((yychar & 127) == 127) {
7535 #endif
7536         if (PL_lex_state == LEX_NORMAL ||
7537            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7538             where = "at end of line";
7539         else if (PL_lex_inpat)
7540             where = "within pattern";
7541         else
7542             where = "within string";
7543     }
7544     else {
7545         SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7546         if (yychar < 32)
7547             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7548         else if (isPRINT_LC(yychar))
7549             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7550         else
7551             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7552         where = SvPVX(where_sv);
7553     }
7554     msg = sv_2mortal(newSVpv(s, 0));
7555     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7556                    CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7557     if (context)
7558         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7559     else
7560         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7561     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7562         Perl_sv_catpvf(aTHX_ msg,
7563         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7564                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7565         PL_multi_end = 0;
7566     }
7567     if (PL_in_eval & EVAL_WARNONLY)
7568         Perl_warn(aTHX_ "%"SVf, msg);
7569     else
7570         qerror(msg);
7571     if (PL_error_count >= 10) {
7572         if (PL_in_eval && SvCUR(ERRSV))
7573             Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7574                        ERRSV, CopFILE(PL_curcop));
7575         else
7576             Perl_croak(aTHX_ "%s has too many errors.\n",
7577                        CopFILE(PL_curcop));
7578     }
7579     PL_in_my = 0;
7580     PL_in_my_stash = Nullhv;
7581     return 0;
7582 }
7583 #ifdef __SC__
7584 #pragma segment Main
7585 #endif
7586
7587 STATIC char*
7588 S_swallow_bom(pTHX_ U8 *s)
7589 {
7590     STRLEN slen;
7591     slen = SvCUR(PL_linestr);
7592     switch (*s) {
7593     case 0xFF:
7594         if (s[1] == 0xFE) {
7595             /* UTF-16 little-endian */
7596             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
7597                 Perl_croak(aTHX_ "Unsupported script encoding");
7598 #ifndef PERL_NO_UTF16_FILTER
7599             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7600             s += 2;
7601             if (PL_bufend > (char*)s) {
7602                 U8 *news;
7603                 I32 newlen;
7604
7605                 filter_add(utf16rev_textfilter, NULL);
7606                 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7607                 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7608                                                  PL_bufend - (char*)s - 1,
7609                                                  &newlen);
7610                 Copy(news, s, newlen, U8);
7611                 SvCUR_set(PL_linestr, newlen);
7612                 PL_bufend = SvPVX(PL_linestr) + newlen;
7613                 news[newlen++] = '\0';
7614                 Safefree(news);
7615             }
7616 #else
7617             Perl_croak(aTHX_ "Unsupported script encoding");
7618 #endif
7619         }
7620         break;
7621     case 0xFE:
7622         if (s[1] == 0xFF) {   /* UTF-16 big-endian */
7623 #ifndef PERL_NO_UTF16_FILTER
7624             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7625             s += 2;
7626             if (PL_bufend > (char *)s) {
7627                 U8 *news;
7628                 I32 newlen;
7629
7630                 filter_add(utf16_textfilter, NULL);
7631                 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7632                 PL_bufend = (char*)utf16_to_utf8(s, news,
7633                                                  PL_bufend - (char*)s,
7634                                                  &newlen);
7635                 Copy(news, s, newlen, U8);
7636                 SvCUR_set(PL_linestr, newlen);
7637                 PL_bufend = SvPVX(PL_linestr) + newlen;
7638                 news[newlen++] = '\0';
7639                 Safefree(news);
7640             }
7641 #else
7642             Perl_croak(aTHX_ "Unsupported script encoding");
7643 #endif
7644         }
7645         break;
7646     case 0xEF:
7647         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7648             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7649             s += 3;                      /* UTF-8 */
7650         }
7651         break;
7652     case 0:
7653         if (slen > 3 && s[1] == 0 &&  /* UTF-32 big-endian */
7654             s[2] == 0xFE && s[3] == 0xFF)
7655         {
7656             Perl_croak(aTHX_ "Unsupported script encoding");
7657         }
7658     }
7659     return (char*)s;
7660 }
7661
7662 /*
7663  * restore_rsfp
7664  * Restore a source filter.
7665  */
7666
7667 static void
7668 restore_rsfp(pTHX_ void *f)
7669 {
7670     PerlIO *fp = (PerlIO*)f;
7671
7672     if (PL_rsfp == PerlIO_stdin())
7673         PerlIO_clearerr(PL_rsfp);
7674     else if (PL_rsfp && (PL_rsfp != fp))
7675         PerlIO_close(PL_rsfp);
7676     PL_rsfp = fp;
7677 }
7678
7679 #ifndef PERL_NO_UTF16_FILTER
7680 static I32
7681 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7682 {
7683     I32 count = FILTER_READ(idx+1, sv, maxlen);
7684     if (count) {
7685         U8* tmps;
7686         U8* tend;
7687         I32 newlen;
7688         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7689         if (!*SvPV_nolen(sv))
7690         /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7691         return count;
7692
7693         tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7694         sv_usepvn(sv, (char*)tmps, tend - tmps);
7695     }
7696     return count;
7697 }
7698
7699 static I32
7700 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7701 {
7702     I32 count = FILTER_READ(idx+1, sv, maxlen);
7703     if (count) {
7704         U8* tmps;
7705         U8* tend;
7706         I32 newlen;
7707         if (!*SvPV_nolen(sv))
7708         /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7709         return count;
7710
7711         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7712         tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7713         sv_usepvn(sv, (char*)tmps, tend - tmps);
7714     }
7715     return count;
7716 }
7717 #endif
7718