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