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