toke.c

   1 /*    toke.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  *   "It all comes from here, the stench and the peril."  --Frodo
  13  */
  14
  15 /*
  16  * This file is the lexer for Perl.  It's closely linked to the
  17  * parser, perly.y.
  18  *
  19  * The main routine is yylex(), which returns the next token.
  20  */
  21
  22 #include "EXTERN.h"
  23 #define PERL_IN_TOKE_C
  24 #include "perl.h"
  25
  26 #define yychar  (*PL_yycharp)
  27 #define yylval  (*PL_yylvalp)
  28
  29 static const char ident_too_long[] = "Identifier too long";
  30 static const char commaless_variable_list[] = "comma-less variable list";
  31
  32 static void restore_rsfp(pTHX_ void *f);
  33 #ifndef PERL_NO_UTF16_FILTER
  34 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
  35 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
  36 #endif
  37
  38 #ifdef PERL_MAD
  39 #  define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
  40 #  define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
  41 #else
  42 #  define CURMAD(slot,sv)
  43 #  define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
  44 #endif
  45
  46 #define XFAKEBRACK 128
  47 #define XENUMMASK 127
  48
  49 #ifdef USE_UTF8_SCRIPTS
  50 #   define UTF (!IN_BYTES)
  51 #else
  52 #   define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
  53 #endif
  54
  55 /* In variables named $^X, these are the legal values for X.
  56  * 1999-02-27 mjd-perl-patch@plover.com */
  57 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
  58
  59 /* On MacOS, respect nonbreaking spaces */
  60 #ifdef MACOS_TRADITIONAL
  61 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
  62 #else
  63 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
  64 #endif
  65
  66 /* LEX_* are values for PL_lex_state, the state of the lexer.
  67  * They are arranged oddly so that the guard on the switch statement
  68  * can get by with a single comparison (if the compiler is smart enough).
  69  */
  70
  71 /* #define LEX_NOTPARSING               11 is done in perl.h. */
  72
  73 #define LEX_NORMAL              10 /* normal code (ie not within "...")     */
  74 #define LEX_INTERPNORMAL         9 /* code within a string, eg "$foo[$x+1]" */
  75 #define LEX_INTERPCASEMOD        8 /* expecting a \U, \Q or \E etc          */
  76 #define LEX_INTERPPUSH           7 /* starting a new sublex parse level     */
  77 #define LEX_INTERPSTART          6 /* expecting the start of a $var         */
  78
  79                                    /* at end of code, eg "$x" followed by:  */
  80 #define LEX_INTERPEND            5 /* ... eg not one of [, { or ->          */
  81 #define LEX_INTERPENDMAYBE       4 /* ... eg one of [, { or ->              */
  82
  83 #define LEX_INTERPCONCAT         3 /* expecting anything, eg at start of
  84                                         string or after \E, $foo, etc       */
  85 #define LEX_INTERPCONST          2 /* NOT USED */
  86 #define LEX_FORMLINE             1 /* expecting a format line               */
  87 #define LEX_KNOWNEXT             0 /* next token known; just return it      */
  88
  89
  90 #ifdef DEBUGGING
  91 static const char* const lex_state_names[] = {
  92     "KNOWNEXT",
  93     "FORMLINE",
  94     "INTERPCONST",
  95     "INTERPCONCAT",
  96     "INTERPENDMAYBE",
  97     "INTERPEND",
  98     "INTERPSTART",
  99     "INTERPPUSH",
 100     "INTERPCASEMOD",
 101     "INTERPNORMAL",
 102     "NORMAL"
 103 };
 104 #endif
 105
 106 #ifdef ff_next
 107 #undef ff_next
 108 #endif
 109
 110 #include "keywords.h"
 111
 112 /* CLINE is a macro that ensures PL_copline has a sane value */
 113
 114 #ifdef CLINE
 115 #undef CLINE
 116 #endif
 117 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
 118
 119 #ifdef PERL_MAD
 120 #  define SKIPSPACE0(s) skipspace0(s)
 121 #  define SKIPSPACE1(s) skipspace1(s)
 122 #  define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
 123 #  define PEEKSPACE(s) skipspace2(s,0)
 124 #else
 125 #  define SKIPSPACE0(s) skipspace(s)
 126 #  define SKIPSPACE1(s) skipspace(s)
 127 #  define SKIPSPACE2(s,tsv) skipspace(s)
 128 #  define PEEKSPACE(s) skipspace(s)
 129 #endif
 130
 131 /*
 132  * Convenience functions to return different tokens and prime the
 133  * lexer for the next token.  They all take an argument.
 134  *
 135  * TOKEN        : generic token (used for '(', DOLSHARP, etc)
 136  * OPERATOR     : generic operator
 137  * AOPERATOR    : assignment operator
 138  * PREBLOCK     : beginning the block after an if, while, foreach, ...
 139  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
 140  * PREREF       : *EXPR where EXPR is not a simple identifier
 141  * TERM         : expression term
 142  * LOOPX        : loop exiting command (goto, last, dump, etc)
 143  * FTST         : file test operator
 144  * FUN0         : zero-argument function
 145  * FUN1         : not used, except for not, which isn't a UNIOP
 146  * BOop         : bitwise or or xor
 147  * BAop         : bitwise and
 148  * SHop         : shift operator
 149  * PWop         : power operator
 150  * PMop         : pattern-matching operator
 151  * Aop          : addition-level operator
 152  * Mop          : multiplication-level operator
 153  * Eop          : equality-testing operator
 154  * Rop          : relational operator <= != gt
 155  *
 156  * Also see LOP and lop() below.
 157  */
 158
 159 #ifdef DEBUGGING /* Serve -DT. */
 160 #   define REPORT(retval) tokereport((I32)retval)
 161 #else
 162 #   define REPORT(retval) (retval)
 163 #endif
 164
 165 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
 166 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
 167 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
 168 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
 169 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
 170 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
 171 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
 172 #define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
 173 #define FTST(f)  return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
 174 #define FUN0(f)  return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
 175 #define FUN1(f)  return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
 176 #define BOop(f)  return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
 177 #define BAop(f)  return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
 178 #define SHop(f)  return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
 179 #define PWop(f)  return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
 180 #define PMop(f)  return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
 181 #define Aop(f)   return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
 182 #define Mop(f)   return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
 183 #define Eop(f)   return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
 184 #define Rop(f)   return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
 185
 186 /* This bit of chicanery makes a unary function followed by
 187  * a parenthesis into a function with one argument, highest precedence.
 188  * The UNIDOR macro is for unary functions that can be followed by the //
 189  * operator (such as C<shift // 0>).
 190  */
 191 #define UNI2(f,x) { \
 192         yylval.ival = f; \
 193         PL_expect = x; \
 194         PL_bufptr = s; \
 195         PL_last_uni = PL_oldbufptr; \
 196         PL_last_lop_op = f; \
 197         if (*s == '(') \
 198             return REPORT( (int)FUNC1 ); \
 199         s = PEEKSPACE(s); \
 200         return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
 201         }
 202 #define UNI(f)    UNI2(f,XTERM)
 203 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
 204
 205 #define UNIBRACK(f) { \
 206         yylval.ival = f; \
 207         PL_bufptr = s; \
 208         PL_last_uni = PL_oldbufptr; \
 209         if (*s == '(') \
 210             return REPORT( (int)FUNC1 ); \
 211         s = PEEKSPACE(s); \
 212         return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
 213         }
 214
 215 /* grandfather return to old style */
 216 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
 217
 218 #ifdef DEBUGGING
 219
 220 /* how to interpret the yylval associated with the token */
 221 enum token_type {
 222     TOKENTYPE_NONE,
 223     TOKENTYPE_IVAL,
 224     TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */
 225     TOKENTYPE_PVAL,
 226     TOKENTYPE_OPVAL,
 227     TOKENTYPE_GVVAL
 228 };
 229
 230 static struct debug_tokens {
 231     const int token;
 232     enum token_type type;
 233     const char *name;
 234 } const debug_tokens[] =
 235 {
 236     { ADDOP,            TOKENTYPE_OPNUM,        "ADDOP" },
 237     { ANDAND,           TOKENTYPE_NONE,         "ANDAND" },
 238     { ANDOP,            TOKENTYPE_NONE,         "ANDOP" },
 239     { ANONSUB,          TOKENTYPE_IVAL,         "ANONSUB" },
 240     { ARROW,            TOKENTYPE_NONE,         "ARROW" },
 241     { ASSIGNOP,         TOKENTYPE_OPNUM,        "ASSIGNOP" },
 242     { BITANDOP,         TOKENTYPE_OPNUM,        "BITANDOP" },
 243     { BITOROP,          TOKENTYPE_OPNUM,        "BITOROP" },
 244     { COLONATTR,        TOKENTYPE_NONE,         "COLONATTR" },
 245     { CONTINUE,         TOKENTYPE_NONE,         "CONTINUE" },
 246     { DEFAULT,          TOKENTYPE_NONE,         "DEFAULT" },
 247     { DO,               TOKENTYPE_NONE,         "DO" },
 248     { DOLSHARP,         TOKENTYPE_NONE,         "DOLSHARP" },
 249     { DORDOR,           TOKENTYPE_NONE,         "DORDOR" },
 250     { DOROP,            TOKENTYPE_OPNUM,        "DOROP" },
 251     { DOTDOT,           TOKENTYPE_IVAL,         "DOTDOT" },
 252     { ELSE,             TOKENTYPE_NONE,         "ELSE" },
 253     { ELSIF,            TOKENTYPE_IVAL,         "ELSIF" },
 254     { EQOP,             TOKENTYPE_OPNUM,        "EQOP" },
 255     { FOR,              TOKENTYPE_IVAL,         "FOR" },
 256     { FORMAT,           TOKENTYPE_NONE,         "FORMAT" },
 257     { FUNC,             TOKENTYPE_OPNUM,        "FUNC" },
 258     { FUNC0,            TOKENTYPE_OPNUM,        "FUNC0" },
 259     { FUNC0SUB,         TOKENTYPE_OPVAL,        "FUNC0SUB" },
 260     { FUNC1,            TOKENTYPE_OPNUM,        "FUNC1" },
 261     { FUNCMETH,         TOKENTYPE_OPVAL,        "FUNCMETH" },
 262     { GIVEN,            TOKENTYPE_IVAL,         "GIVEN" },
 263     { HASHBRACK,        TOKENTYPE_NONE,         "HASHBRACK" },
 264     { IF,               TOKENTYPE_IVAL,         "IF" },
 265     { LABEL,            TOKENTYPE_PVAL,         "LABEL" },
 266     { LOCAL,            TOKENTYPE_IVAL,         "LOCAL" },
 267     { LOOPEX,           TOKENTYPE_OPNUM,        "LOOPEX" },
 268     { LSTOP,            TOKENTYPE_OPNUM,        "LSTOP" },
 269     { LSTOPSUB,         TOKENTYPE_OPVAL,        "LSTOPSUB" },
 270     { MATCHOP,          TOKENTYPE_OPNUM,        "MATCHOP" },
 271     { METHOD,           TOKENTYPE_OPVAL,        "METHOD" },
 272     { MULOP,            TOKENTYPE_OPNUM,        "MULOP" },
 273     { MY,               TOKENTYPE_IVAL,         "MY" },
 274     { MYSUB,            TOKENTYPE_NONE,         "MYSUB" },
 275     { NOAMP,            TOKENTYPE_NONE,         "NOAMP" },
 276     { NOTOP,            TOKENTYPE_NONE,         "NOTOP" },
 277     { OROP,             TOKENTYPE_IVAL,         "OROP" },
 278     { OROR,             TOKENTYPE_NONE,         "OROR" },
 279     { PACKAGE,          TOKENTYPE_NONE,         "PACKAGE" },
 280     { PMFUNC,           TOKENTYPE_OPVAL,        "PMFUNC" },
 281     { POSTDEC,          TOKENTYPE_NONE,         "POSTDEC" },
 282     { POSTINC,          TOKENTYPE_NONE,         "POSTINC" },
 283     { POWOP,            TOKENTYPE_OPNUM,        "POWOP" },
 284     { PREDEC,           TOKENTYPE_NONE,         "PREDEC" },
 285     { PREINC,           TOKENTYPE_NONE,         "PREINC" },
 286     { PRIVATEREF,       TOKENTYPE_OPVAL,        "PRIVATEREF" },
 287     { REFGEN,           TOKENTYPE_NONE,         "REFGEN" },
 288     { RELOP,            TOKENTYPE_OPNUM,        "RELOP" },
 289     { SHIFTOP,          TOKENTYPE_OPNUM,        "SHIFTOP" },
 290     { SUB,              TOKENTYPE_NONE,         "SUB" },
 291     { THING,            TOKENTYPE_OPVAL,        "THING" },
 292     { UMINUS,           TOKENTYPE_NONE,         "UMINUS" },
 293     { UNIOP,            TOKENTYPE_OPNUM,        "UNIOP" },
 294     { UNIOPSUB,         TOKENTYPE_OPVAL,        "UNIOPSUB" },
 295     { UNLESS,           TOKENTYPE_IVAL,         "UNLESS" },
 296     { UNTIL,            TOKENTYPE_IVAL,         "UNTIL" },
 297     { USE,              TOKENTYPE_IVAL,         "USE" },
 298     { WHEN,             TOKENTYPE_IVAL,         "WHEN" },
 299     { WHILE,            TOKENTYPE_IVAL,         "WHILE" },
 300     { WORD,             TOKENTYPE_OPVAL,        "WORD" },
 301     { 0,                TOKENTYPE_NONE,         0 }
 302 };
 303
 304 /* dump the returned token in rv, plus any optional arg in yylval */
 305
 306 STATIC int
 307 S_tokereport(pTHX_ I32 rv)
 308 {
 309     dVAR;
 310     if (DEBUG_T_TEST) {
 311         const char *name = NULL;
 312         enum token_type type = TOKENTYPE_NONE;
 313         const struct debug_tokens *p;
 314         SV* const report = newSVpvs("<== ");
 315
 316         for (p = debug_tokens; p->token; p++) {
 317             if (p->token == (int)rv) {
 318                 name = p->name;
 319                 type = p->type;
 320                 break;
 321             }
 322         }
 323         if (name)
 324             Perl_sv_catpv(aTHX_ report, name);
 325         else if ((char)rv > ' ' && (char)rv < '~')
 326             Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
 327         else if (!rv)
 328             sv_catpvs(report, "EOF");
 329         else
 330             Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
 331         switch (type) {
 332         case TOKENTYPE_NONE:
 333         case TOKENTYPE_GVVAL: /* doesn't appear to be used */
 334             break;
 335         case TOKENTYPE_IVAL:
 336             Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival);
 337             break;
 338         case TOKENTYPE_OPNUM:
 339             Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
 340                                     PL_op_name[yylval.ival]);
 341             break;
 342         case TOKENTYPE_PVAL:
 343             Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
 344             break;
 345         case TOKENTYPE_OPVAL:
 346             if (yylval.opval) {
 347                 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
 348                                     PL_op_name[yylval.opval->op_type]);
 349                 if (yylval.opval->op_type == OP_CONST) {
 350                     Perl_sv_catpvf(aTHX_ report, " %s",
 351                         SvPEEK(cSVOPx_sv(yylval.opval)));
 352                 }
 353
 354             }
 355             else
 356                 sv_catpvs(report, "(opval=null)");
 357             break;
 358         }
 359         PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
 360     };
 361     return (int)rv;
 362 }
 363
 364
 365 /* print the buffer with suitable escapes */
 366
 367 STATIC void
 368 S_printbuf(pTHX_ const char* fmt, const char* s)
 369 {
 370     SV* const tmp = newSVpvs("");
 371     PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
 372     SvREFCNT_dec(tmp);
 373 }
 374
 375 #endif
 376
 377 /*
 378  * S_ao
 379  *
 380  * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
 381  * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
 382  */
 383
 384 STATIC int
 385 S_ao(pTHX_ int toketype)
 386 {
 387     dVAR;
 388     if (*PL_bufptr == '=') {
 389         PL_bufptr++;
 390         if (toketype == ANDAND)
 391             yylval.ival = OP_ANDASSIGN;
 392         else if (toketype == OROR)
 393             yylval.ival = OP_ORASSIGN;
 394         else if (toketype == DORDOR)
 395             yylval.ival = OP_DORASSIGN;
 396         toketype = ASSIGNOP;
 397     }
 398     return toketype;
 399 }
 400
 401 /*
 402  * S_no_op
 403  * When Perl expects an operator and finds something else, no_op
 404  * prints the warning.  It always prints "<something> found where
 405  * operator expected.  It prints "Missing semicolon on previous line?"
 406  * if the surprise occurs at the start of the line.  "do you need to
 407  * predeclare ..." is printed out for code like "sub bar; foo bar $x"
 408  * where the compiler doesn't know if foo is a method call or a function.
 409  * It prints "Missing operator before end of line" if there's nothing
 410  * after the missing operator, or "... before <...>" if there is something
 411  * after the missing operator.
 412  */
 413
 414 STATIC void
 415 S_no_op(pTHX_ const char *what, char *s)
 416 {
 417     dVAR;
 418     char * const oldbp = PL_bufptr;
 419     const bool is_first = (PL_oldbufptr == PL_linestart);
 420
 421     if (!s)
 422         s = oldbp;
 423     else
 424         PL_bufptr = s;
 425     yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
 426     if (ckWARN_d(WARN_SYNTAX)) {
 427         if (is_first)
 428             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 429                     "\t(Missing semicolon on previous line?)\n");
 430         else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
 431             const char *t;
 432             for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
 433                 /**/;
 434             if (t < PL_bufptr && isSPACE(*t))
 435                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 436                         "\t(Do you need to predeclare %.*s?)\n",
 437                     (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
 438         }
 439         else {
 440             assert(s >= oldbp);
 441             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 442                     "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
 443         }
 444     }
 445     PL_bufptr = oldbp;
 446 }
 447
 448 /*
 449  * S_missingterm
 450  * Complain about missing quote/regexp/heredoc terminator.
 451  * If it's called with NULL then it cauterizes the line buffer.
 452  * If we're in a delimited string and the delimiter is a control
 453  * character, it's reformatted into a two-char sequence like ^C.
 454  * This is fatal.
 455  */
 456
 457 STATIC void
 458 S_missingterm(pTHX_ char *s)
 459 {
 460     dVAR;
 461     char tmpbuf[3];
 462     char q;
 463     if (s) {
 464         char * const nl = strrchr(s,'\n');
 465         if (nl)
 466             *nl = '\0';
 467     }
 468     else if (
 469 #ifdef EBCDIC
 470         iscntrl(PL_multi_close)
 471 #else
 472         PL_multi_close < 32 || PL_multi_close == 127
 473 #endif
 474         ) {
 475         *tmpbuf = '^';
 476         tmpbuf[1] = (char)toCTRL(PL_multi_close);
 477         tmpbuf[2] = '\0';
 478         s = tmpbuf;
 479     }
 480     else {
 481         *tmpbuf = (char)PL_multi_close;
 482         tmpbuf[1] = '\0';
 483         s = tmpbuf;
 484     }
 485     q = strchr(s,'"') ? '\'' : '"';
 486     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
 487 }
 488
 489 #define FEATURE_IS_ENABLED(name)                                        \
 490         ((0 != (PL_hints & HINT_LOCALIZE_HH))                           \
 491             && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
 492 /*
 493  * S_feature_is_enabled
 494  * Check whether the named feature is enabled.
 495  */
 496 STATIC bool
 497 S_feature_is_enabled(pTHX_ const char *name, STRLEN namelen)
 498 {
 499     dVAR;
 500     HV * const hinthv = GvHV(PL_hintgv);
 501     char he_name[32] = "feature_";
 502     (void) strncpy(&he_name[8], name, 24);
 503
 504     return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
 505 }
 506
 507 /*
 508  * Perl_deprecate
 509  */
 510
 511 void
 512 Perl_deprecate(pTHX_ const char *s)
 513 {
 514     if (ckWARN(WARN_DEPRECATED))
 515         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
 516 }
 517
 518 void
 519 Perl_deprecate_old(pTHX_ const char *s)
 520 {
 521     /* This function should NOT be called for any new deprecated warnings */
 522     /* Use Perl_deprecate instead                                         */
 523     /*                                                                    */
 524     /* It is here to maintain backward compatibility with the pre-5.8     */
 525     /* warnings category hierarchy. The "deprecated" category used to     */
 526     /* live under the "syntax" category. It is now a top-level category   */
 527     /* in its own right.                                                  */
 528
 529     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
 530         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 531                         "Use of %s is deprecated", s);
 532 }
 533
 534 /*
 535  * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
 536  * utf16-to-utf8-reversed.
 537  */
 538
 539 #ifdef PERL_CR_FILTER
 540 static void
 541 strip_return(SV *sv)
 542 {
 543     register const char *s = SvPVX_const(sv);
 544     register const char * const e = s + SvCUR(sv);
 545     /* outer loop optimized to do nothing if there are no CR-LFs */
 546     while (s < e) {
 547         if (*s++ == '\r' && *s == '\n') {
 548             /* hit a CR-LF, need to copy the rest */
 549             register char *d = s - 1;
 550             *d++ = *s++;
 551             while (s < e) {
 552                 if (*s == '\r' && s[1] == '\n')
 553                     s++;
 554                 *d++ = *s++;
 555             }
 556             SvCUR(sv) -= s - d;
 557             return;
 558         }
 559     }
 560 }
 561
 562 STATIC I32
 563 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 564 {
 565     const I32 count = FILTER_READ(idx+1, sv, maxlen);
 566     if (count > 0 && !maxlen)
 567         strip_return(sv);
 568     return count;
 569 }
 570 #endif
 571
 572 /*
 573  * Perl_lex_start
 574  * Initialize variables.  Uses the Perl save_stack to save its state (for
 575  * recursive calls to the parser).
 576  */
 577
 578 void
 579 Perl_lex_start(pTHX_ SV *line)
 580 {
 581     dVAR;
 582     const char *s;
 583     STRLEN len;
 584
 585     SAVEI32(PL_lex_dojoin);
 586     SAVEI32(PL_lex_brackets);
 587     SAVEI32(PL_lex_casemods);
 588     SAVEI32(PL_lex_starts);
 589     SAVEI32(PL_lex_state);
 590     SAVEVPTR(PL_lex_inpat);
 591     SAVEI32(PL_lex_inwhat);
 592 #ifdef PERL_MAD
 593     if (PL_lex_state == LEX_KNOWNEXT) {
 594         I32 toke = PL_lasttoke;
 595         while (--toke >= 0) {
 596             SAVEI32(PL_nexttoke[toke].next_type);
 597             SAVEVPTR(PL_nexttoke[toke].next_val);
 598             if (PL_madskills)
 599                 SAVEVPTR(PL_nexttoke[toke].next_mad);
 600         }
 601         SAVEI32(PL_lasttoke);
 602     }
 603     if (PL_madskills) {
 604         SAVESPTR(PL_thistoken);
 605         SAVESPTR(PL_thiswhite);
 606         SAVESPTR(PL_nextwhite);
 607         SAVESPTR(PL_thisopen);
 608         SAVESPTR(PL_thisclose);
 609         SAVESPTR(PL_thisstuff);
 610         SAVEVPTR(PL_thismad);
 611         SAVEI32(PL_realtokenstart);
 612         SAVEI32(PL_faketokens);
 613     }
 614     SAVEI32(PL_curforce);
 615 #else
 616     if (PL_lex_state == LEX_KNOWNEXT) {
 617         I32 toke = PL_nexttoke;
 618         while (--toke >= 0) {
 619             SAVEI32(PL_nexttype[toke]);
 620             SAVEVPTR(PL_nextval[toke]);
 621         }
 622         SAVEI32(PL_nexttoke);
 623     }
 624 #endif
 625     SAVECOPLINE(PL_curcop);
 626     SAVEPPTR(PL_bufptr);
 627     SAVEPPTR(PL_bufend);
 628     SAVEPPTR(PL_oldbufptr);
 629     SAVEPPTR(PL_oldoldbufptr);
 630     SAVEPPTR(PL_last_lop);
 631     SAVEPPTR(PL_last_uni);
 632     SAVEPPTR(PL_linestart);
 633     SAVESPTR(PL_linestr);
 634     SAVEGENERICPV(PL_lex_brackstack);
 635     SAVEGENERICPV(PL_lex_casestack);
 636     SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
 637     SAVESPTR(PL_lex_stuff);
 638     SAVEI32(PL_lex_defer);
 639     SAVEI32(PL_sublex_info.sub_inwhat);
 640     SAVESPTR(PL_lex_repl);
 641     SAVEINT(PL_expect);
 642     SAVEINT(PL_lex_expect);
 643
 644     PL_lex_state = LEX_NORMAL;
 645     PL_lex_defer = 0;
 646     PL_expect = XSTATE;
 647     PL_lex_brackets = 0;
 648     Newx(PL_lex_brackstack, 120, char);
 649     Newx(PL_lex_casestack, 12, char);
 650     PL_lex_casemods = 0;
 651     *PL_lex_casestack = '\0';
 652     PL_lex_dojoin = 0;
 653     PL_lex_starts = 0;
 654     PL_lex_stuff = NULL;
 655     PL_lex_repl = NULL;
 656     PL_lex_inpat = 0;
 657 #ifdef PERL_MAD
 658     PL_lasttoke = 0;
 659 #else
 660     PL_nexttoke = 0;
 661 #endif
 662     PL_lex_inwhat = 0;
 663     PL_sublex_info.sub_inwhat = 0;
 664     PL_linestr = line;
 665     if (SvREADONLY(PL_linestr))
 666         PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 667     s = SvPV_const(PL_linestr, len);
 668     if (!len || s[len-1] != ';') {
 669         if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
 670             PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 671         sv_catpvs(PL_linestr, "\n;");
 672     }
 673     SvTEMP_off(PL_linestr);
 674     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
 675     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
 676     PL_last_lop = PL_last_uni = NULL;
 677     PL_rsfp = 0;
 678 }
 679
 680 /*
 681  * Perl_lex_end
 682  * Finalizer for lexing operations.  Must be called when the parser is
 683  * done with the lexer.
 684  */
 685
 686 void
 687 Perl_lex_end(pTHX)
 688 {
 689     dVAR;
 690     PL_doextract = FALSE;
 691 }
 692
 693 /*
 694  * S_incline
 695  * This subroutine has nothing to do with tilting, whether at windmills
 696  * or pinball tables.  Its name is short for "increment line".  It
 697  * increments the current line number in CopLINE(PL_curcop) and checks
 698  * to see whether the line starts with a comment of the form
 699  *    # line 500 "foo.pm"
 700  * If so, it sets the current line number and file to the values in the comment.
 701  */
 702
 703 STATIC void
 704 S_incline(pTHX_ char *s)
 705 {
 706     dVAR;
 707     char *t;
 708     char *n;
 709     char *e;
 710     char ch;
 711
 712     CopLINE_inc(PL_curcop);
 713     if (*s++ != '#')
 714         return;
 715     while (SPACE_OR_TAB(*s))
 716         s++;
 717     if (strnEQ(s, "line", 4))
 718         s += 4;
 719     else
 720         return;
 721     if (SPACE_OR_TAB(*s))
 722         s++;
 723     else
 724         return;
 725     while (SPACE_OR_TAB(*s))
 726         s++;
 727     if (!isDIGIT(*s))
 728         return;
 729
 730     n = s;
 731     while (isDIGIT(*s))
 732         s++;
 733     while (SPACE_OR_TAB(*s))
 734         s++;
 735     if (*s == '"' && (t = strchr(s+1, '"'))) {
 736         s++;
 737         e = t + 1;
 738     }
 739     else {
 740         for (t = s; !isSPACE(*t); t++) ;
 741         e = t;
 742     }
 743     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
 744         e++;
 745     if (*e != '\n' && *e != '\0')
 746         return;         /* false alarm */
 747
 748     ch = *t;
 749     *t = '\0';
 750     if (t - s > 0) {
 751 #ifndef USE_ITHREADS
 752         const char * const cf = CopFILE(PL_curcop);
 753         STRLEN tmplen = cf ? strlen(cf) : 0;
 754         if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
 755             /* must copy *{"::_<(eval N)[oldfilename:L]"}
 756              * to *{"::_<newfilename"} */
 757             char smallbuf[256], smallbuf2[256];
 758             char *tmpbuf, *tmpbuf2;
 759             GV **gvp, *gv2;
 760             STRLEN tmplen2 = strlen(s);
 761             if (tmplen + 3 < sizeof smallbuf)
 762                 tmpbuf = smallbuf;
 763             else
 764                 Newx(tmpbuf, tmplen + 3, char);
 765             if (tmplen2 + 3 < sizeof smallbuf2)
 766                 tmpbuf2 = smallbuf2;
 767             else
 768                 Newx(tmpbuf2, tmplen2 + 3, char);
 769             tmpbuf[0] = tmpbuf2[0] = '_';
 770             tmpbuf[1] = tmpbuf2[1] = '<';
 771             memcpy(tmpbuf + 2, cf, ++tmplen);
 772             memcpy(tmpbuf2 + 2, s, ++tmplen2);
 773             ++tmplen; ++tmplen2;
 774             gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
 775             if (gvp) {
 776                 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
 777                 if (!isGV(gv2))
 778                     gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
 779                 /* adjust ${"::_<newfilename"} to store the new file name */
 780                 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
 781                 GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
 782                 GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
 783             }
 784             if (tmpbuf != smallbuf) Safefree(tmpbuf);
 785             if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
 786         }
 787 #endif
 788         CopFILE_free(PL_curcop);
 789         CopFILE_set(PL_curcop, s);
 790     }
 791     *t = ch;
 792     CopLINE_set(PL_curcop, atoi(n)-1);
 793 }
 794
 795 #ifdef PERL_MAD
 796 /* skip space before PL_thistoken */
 797
 798 STATIC char *
 799 S_skipspace0(pTHX_ register char *s)
 800 {
 801     s = skipspace(s);
 802     if (!PL_madskills)
 803         return s;
 804     if (PL_skipwhite) {
 805         if (!PL_thiswhite)
 806             PL_thiswhite = newSVpvn("",0);
 807         sv_catsv(PL_thiswhite, PL_skipwhite);
 808         sv_free(PL_skipwhite);
 809         PL_skipwhite = 0;
 810     }
 811     PL_realtokenstart = s - SvPVX(PL_linestr);
 812     return s;
 813 }
 814
 815 /* skip space after PL_thistoken */
 816
 817 STATIC char *
 818 S_skipspace1(pTHX_ register char *s)
 819 {
 820     const char *start = s;
 821     I32 startoff = start - SvPVX(PL_linestr);
 822
 823     s = skipspace(s);
 824     if (!PL_madskills)
 825         return s;
 826     start = SvPVX(PL_linestr) + startoff;
 827     if (!PL_thistoken && PL_realtokenstart >= 0) {
 828         const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
 829         PL_thistoken = newSVpvn(tstart, start - tstart);
 830     }
 831     PL_realtokenstart = -1;
 832     if (PL_skipwhite) {
 833         if (!PL_nextwhite)
 834             PL_nextwhite = newSVpvn("",0);
 835         sv_catsv(PL_nextwhite, PL_skipwhite);
 836         sv_free(PL_skipwhite);
 837         PL_skipwhite = 0;
 838     }
 839     return s;
 840 }
 841
 842 STATIC char *
 843 S_skipspace2(pTHX_ register char *s, SV **svp)
 844 {
 845     char *start = s;
 846     I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
 847     I32 startoff = start - SvPVX(PL_linestr);
 848     s = skipspace(s);
 849     PL_bufptr = SvPVX(PL_linestr) + bufptroff;
 850     if (!PL_madskills || !svp)
 851         return s;
 852     start = SvPVX(PL_linestr) + startoff;
 853     if (!PL_thistoken && PL_realtokenstart >= 0) {
 854         char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
 855         PL_thistoken = newSVpvn(tstart, start - tstart);
 856         PL_realtokenstart = -1;
 857     }
 858     if (PL_skipwhite) {
 859         if (!*svp)
 860             *svp = newSVpvn("",0);
 861         sv_setsv(*svp, PL_skipwhite);
 862         sv_free(PL_skipwhite);
 863         PL_skipwhite = 0;
 864     }
 865
 866     return s;
 867 }
 868 #endif
 869
 870 /*
 871  * S_skipspace
 872  * Called to gobble the appropriate amount and type of whitespace.
 873  * Skips comments as well.
 874  */
 875
 876 STATIC char *
 877 S_skipspace(pTHX_ register char *s)
 878 {
 879     dVAR;
 880 #ifdef PERL_MAD
 881     int curoff;
 882     int startoff = s - SvPVX(PL_linestr);
 883
 884     if (PL_skipwhite) {
 885         sv_free(PL_skipwhite);
 886         PL_skipwhite = 0;
 887     }
 888 #endif
 889
 890     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
 891         while (s < PL_bufend && SPACE_OR_TAB(*s))
 892             s++;
 893 #ifdef PERL_MAD
 894         goto done;
 895 #else
 896         return s;
 897 #endif
 898     }
 899     for (;;) {
 900         STRLEN prevlen;
 901         SSize_t oldprevlen, oldoldprevlen;
 902         SSize_t oldloplen = 0, oldunilen = 0;
 903         while (s < PL_bufend && isSPACE(*s)) {
 904             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
 905                 incline(s);
 906         }
 907
 908         /* comment */
 909         if (s < PL_bufend && *s == '#') {
 910             while (s < PL_bufend && *s != '\n')
 911                 s++;
 912             if (s < PL_bufend) {
 913                 s++;
 914                 if (PL_in_eval && !PL_rsfp) {
 915                     incline(s);
 916                     continue;
 917                 }
 918             }
 919         }
 920
 921         /* only continue to recharge the buffer if we're at the end
 922          * of the buffer, we're not reading from a source filter, and
 923          * we're in normal lexing mode
 924          */
 925         if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
 926                 PL_lex_state == LEX_FORMLINE)
 927 #ifdef PERL_MAD
 928             goto done;
 929 #else
 930             return s;
 931 #endif
 932
 933         /* try to recharge the buffer */
 934 #ifdef PERL_MAD
 935         curoff = s - SvPVX(PL_linestr);
 936 #endif
 937
 938         if ((s = filter_gets(PL_linestr, PL_rsfp,
 939                              (prevlen = SvCUR(PL_linestr)))) == NULL)
 940         {
 941 #ifdef PERL_MAD
 942             if (PL_madskills && curoff != startoff) {
 943                 if (!PL_skipwhite)
 944                     PL_skipwhite = newSVpvn("",0);
 945                 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
 946                                         curoff - startoff);
 947             }
 948
 949             /* mustn't throw out old stuff yet if madpropping */
 950             SvCUR(PL_linestr) = curoff;
 951             s = SvPVX(PL_linestr) + curoff;
 952             *s = 0;
 953             if (curoff && s[-1] == '\n')
 954                 s[-1] = ' ';
 955 #endif
 956
 957             /* end of file.  Add on the -p or -n magic */
 958             /* XXX these shouldn't really be added here, can't set PL_faketokens */
 959             if (PL_minus_p) {
 960 #ifdef PERL_MAD
 961                 sv_catpv(PL_linestr,
 962                          ";}continue{print or die qq(-p destination: $!\\n);}");
 963 #else
 964                 sv_setpv(PL_linestr,
 965                          ";}continue{print or die qq(-p destination: $!\\n);}");
 966 #endif
 967                 PL_minus_n = PL_minus_p = 0;
 968             }
 969             else if (PL_minus_n) {
 970 #ifdef PERL_MAD
 971                 sv_catpvn(PL_linestr, ";}", 2);
 972 #else
 973                 sv_setpvn(PL_linestr, ";}", 2);
 974 #endif
 975                 PL_minus_n = 0;
 976             }
 977             else
 978 #ifdef PERL_MAD
 979                 sv_catpvn(PL_linestr,";", 1);
 980 #else
 981                 sv_setpvn(PL_linestr,";", 1);
 982 #endif
 983
 984             /* reset variables for next time we lex */
 985             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
 986                 = SvPVX(PL_linestr)
 987 #ifdef PERL_MAD
 988                 + curoff
 989 #endif
 990                 ;
 991             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
 992             PL_last_lop = PL_last_uni = NULL;
 993
 994             /* Close the filehandle.  Could be from -P preprocessor,
 995              * STDIN, or a regular file.  If we were reading code from
 996              * STDIN (because the commandline held no -e or filename)
 997              * then we don't close it, we reset it so the code can
 998              * read from STDIN too.
 999              */
1000
1001             if (PL_preprocess && !PL_in_eval)
1002                 (void)PerlProc_pclose(PL_rsfp);
1003             else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1004                 PerlIO_clearerr(PL_rsfp);
1005             else
1006                 (void)PerlIO_close(PL_rsfp);
1007             PL_rsfp = NULL;
1008             return s;
1009         }
1010
1011         /* not at end of file, so we only read another line */
1012         /* make corresponding updates to old pointers, for yyerror() */
1013         oldprevlen = PL_oldbufptr - PL_bufend;
1014         oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1015         if (PL_last_uni)
1016             oldunilen = PL_last_uni - PL_bufend;
1017         if (PL_last_lop)
1018             oldloplen = PL_last_lop - PL_bufend;
1019         PL_linestart = PL_bufptr = s + prevlen;
1020         PL_bufend = s + SvCUR(PL_linestr);
1021         s = PL_bufptr;
1022         PL_oldbufptr = s + oldprevlen;
1023         PL_oldoldbufptr = s + oldoldprevlen;
1024         if (PL_last_uni)
1025             PL_last_uni = s + oldunilen;
1026         if (PL_last_lop)
1027             PL_last_lop = s + oldloplen;
1028         incline(s);
1029
1030         /* debugger active and we're not compiling the debugger code,
1031          * so store the line into the debugger's array of lines
1032          */
1033         if (PERLDB_LINE && PL_curstash != PL_debstash) {
1034             SV * const sv = newSV(0);
1035
1036             sv_upgrade(sv, SVt_PVMG);
1037             sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
1038             (void)SvIOK_on(sv);
1039             SvIV_set(sv, 0);
1040             av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
1041         }
1042     }
1043
1044 #ifdef PERL_MAD
1045   done:
1046     if (PL_madskills) {
1047         if (!PL_skipwhite)
1048             PL_skipwhite = newSVpvn("",0);
1049         curoff = s - SvPVX(PL_linestr);
1050         if (curoff - startoff)
1051             sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1052                                 curoff - startoff);
1053     }
1054     return s;
1055 #endif
1056 }
1057
1058 /*
1059  * S_check_uni
1060  * Check the unary operators to ensure there's no ambiguity in how they're
1061  * used.  An ambiguous piece of code would be:
1062  *     rand + 5
1063  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
1064  * the +5 is its argument.
1065  */
1066
1067 STATIC void
1068 S_check_uni(pTHX)
1069 {
1070     dVAR;
1071     const char *s;
1072     const char *t;
1073
1074     if (PL_oldoldbufptr != PL_last_uni)
1075         return;
1076     while (isSPACE(*PL_last_uni))
1077         PL_last_uni++;
1078     for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++)
1079         /**/;
1080     if ((t = strchr(s, '(')) && t < PL_bufptr)
1081         return;
1082
1083     if (ckWARN_d(WARN_AMBIGUOUS)){
1084         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
1085                    "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1086                    (int)(s - PL_last_uni), PL_last_uni);
1087     }
1088 }
1089
1090 /*
1091  * LOP : macro to build a list operator.  Its behaviour has been replaced
1092  * with a subroutine, S_lop() for which LOP is just another name.
1093  */
1094
1095 #define LOP(f,x) return lop(f,x,s)
1096
1097 /*
1098  * S_lop
1099  * Build a list operator (or something that might be one).  The rules:
1100  *  - if we have a next token, then it's a list operator [why?]
1101  *  - if the next thing is an opening paren, then it's a function
1102  *  - else it's a list operator
1103  */
1104
1105 STATIC I32
1106 S_lop(pTHX_ I32 f, int x, char *s)
1107 {
1108     dVAR;
1109     yylval.ival = f;
1110     CLINE;
1111     PL_expect = x;
1112     PL_bufptr = s;
1113     PL_last_lop = PL_oldbufptr;
1114     PL_last_lop_op = (OPCODE)f;
1115 #ifdef PERL_MAD
1116     if (PL_lasttoke)
1117         return REPORT(LSTOP);
1118 #else
1119     if (PL_nexttoke)
1120         return REPORT(LSTOP);
1121 #endif
1122     if (*s == '(')
1123         return REPORT(FUNC);
1124     s = PEEKSPACE(s);
1125     if (*s == '(')
1126         return REPORT(FUNC);
1127     else
1128         return REPORT(LSTOP);
1129 }
1130
1131 #ifdef PERL_MAD
1132  /*
1133  * S_start_force
1134  * Sets up for an eventual force_next().  start_force(0) basically does
1135  * an unshift, while start_force(-1) does a push.  yylex removes items
1136  * on the "pop" end.
1137  */
1138
1139 STATIC void
1140 S_start_force(pTHX_ int where)
1141 {
1142     int i;
1143
1144     if (where < 0)      /* so people can duplicate start_force(PL_curforce) */
1145         where = PL_lasttoke;
1146     assert(PL_curforce < 0 || PL_curforce == where);
1147     if (PL_curforce != where) {
1148         for (i = PL_lasttoke; i > where; --i) {
1149             PL_nexttoke[i] = PL_nexttoke[i-1];
1150         }
1151         PL_lasttoke++;
1152     }
1153     if (PL_curforce < 0)        /* in case of duplicate start_force() */
1154         Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1155     PL_curforce = where;
1156     if (PL_nextwhite) {
1157         if (PL_madskills)
1158             curmad('^', newSVpvn("",0));
1159         CURMAD('_', PL_nextwhite);
1160     }
1161 }
1162
1163 STATIC void
1164 S_curmad(pTHX_ char slot, SV *sv)
1165 {
1166     MADPROP **where;
1167
1168     if (!sv)
1169         return;
1170     if (PL_curforce < 0)
1171         where = &PL_thismad;
1172     else
1173         where = &PL_nexttoke[PL_curforce].next_mad;
1174
1175     if (PL_faketokens)
1176         sv_setpvn(sv, "", 0);
1177     else {
1178         if (!IN_BYTES) {
1179             if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1180                 SvUTF8_on(sv);
1181             else if (PL_encoding) {
1182                 sv_recode_to_utf8(sv, PL_encoding);
1183             }
1184         }
1185     }
1186
1187     /* keep a slot open for the head of the list? */
1188     if (slot != '_' && *where && (*where)->mad_key == '^') {
1189         (*where)->mad_key = slot;
1190         sv_free((*where)->mad_val);
1191         (*where)->mad_val = (void*)sv;
1192     }
1193     else
1194         addmad(newMADsv(slot, sv), where, 0);
1195 }
1196 #else
1197 #  define start_force(where)    /*EMPTY*/
1198 #  define curmad(slot, sv)      /*EMPTY*/
1199 #endif
1200
1201 /*
1202  * S_force_next
1203  * When the lexer realizes it knows the next token (for instance,
1204  * it is reordering tokens for the parser) then it can call S_force_next
1205  * to know what token to return the next time the lexer is called.  Caller
1206  * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1207  * and possibly PL_expect to ensure the lexer handles the token correctly.
1208  */
1209
1210 STATIC void
1211 S_force_next(pTHX_ I32 type)
1212 {
1213     dVAR;
1214 #ifdef PERL_MAD
1215     if (PL_curforce < 0)
1216         start_force(PL_lasttoke);
1217     PL_nexttoke[PL_curforce].next_type = type;
1218     if (PL_lex_state != LEX_KNOWNEXT)
1219         PL_lex_defer = PL_lex_state;
1220     PL_lex_state = LEX_KNOWNEXT;
1221     PL_lex_expect = PL_expect;
1222     PL_curforce = -1;
1223 #else
1224     PL_nexttype[PL_nexttoke] = type;
1225     PL_nexttoke++;
1226     if (PL_lex_state != LEX_KNOWNEXT) {
1227         PL_lex_defer = PL_lex_state;
1228         PL_lex_expect = PL_expect;
1229         PL_lex_state = LEX_KNOWNEXT;
1230     }
1231 #endif
1232 }
1233
1234 STATIC SV *
1235 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
1236 {
1237     dVAR;
1238     SV * const sv = newSVpvn(start,len);
1239     if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
1240         SvUTF8_on(sv);
1241     return sv;
1242 }
1243
1244 /*
1245  * S_force_word
1246  * When the lexer knows the next thing is a word (for instance, it has
1247  * just seen -> and it knows that the next char is a word char, then
1248  * it calls S_force_word to stick the next word into the PL_next lookahead.
1249  *
1250  * Arguments:
1251  *   char *start : buffer position (must be within PL_linestr)
1252  *   int token   : PL_next will be this type of bare word (e.g., METHOD,WORD)
1253  *   int check_keyword : if true, Perl checks to make sure the word isn't
1254  *       a keyword (do this if the word is a label, e.g. goto FOO)
1255  *   int allow_pack : if true, : characters will also be allowed (require,
1256  *       use, etc. do this)
1257  *   int allow_initial_tick : used by the "sub" lexer only.
1258  */
1259
1260 STATIC char *
1261 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1262 {
1263     dVAR;
1264     register char *s;
1265     STRLEN len;
1266
1267     start = SKIPSPACE1(start);
1268     s = start;
1269     if (isIDFIRST_lazy_if(s,UTF) ||
1270         (allow_pack && *s == ':') ||
1271         (allow_initial_tick && *s == '\'') )
1272     {
1273         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1274         if (check_keyword && keyword(PL_tokenbuf, len))
1275             return start;
1276         start_force(PL_curforce);
1277         if (PL_madskills)
1278             curmad('X', newSVpvn(start,s-start));
1279         if (token == METHOD) {
1280             s = SKIPSPACE1(s);
1281             if (*s == '(')
1282                 PL_expect = XTERM;
1283             else {
1284                 PL_expect = XOPERATOR;
1285             }
1286         }
1287         NEXTVAL_NEXTTOKE.opval
1288             = (OP*)newSVOP(OP_CONST,0,
1289                            S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1290         NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1291         force_next(token);
1292     }
1293     return s;
1294 }
1295
1296 /*
1297  * S_force_ident
1298  * Called when the lexer wants $foo *foo &foo etc, but the program
1299  * text only contains the "foo" portion.  The first argument is a pointer
1300  * to the "foo", and the second argument is the type symbol to prefix.
1301  * Forces the next token to be a "WORD".
1302  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1303  */
1304
1305 STATIC void
1306 S_force_ident(pTHX_ register const char *s, int kind)
1307 {
1308     dVAR;
1309     if (s && *s) {
1310         const STRLEN len = strlen(s);
1311         OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1312         start_force(PL_curforce);
1313         NEXTVAL_NEXTTOKE.opval = o;
1314         force_next(WORD);
1315         if (kind) {
1316             o->op_private = OPpCONST_ENTERED;
1317             /* XXX see note in pp_entereval() for why we forgo typo
1318                warnings if the symbol must be introduced in an eval.
1319                GSAR 96-10-12 */
1320             gv_fetchpvn_flags(s, len,
1321                               PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1322                               : GV_ADD,
1323                               kind == '$' ? SVt_PV :
1324                               kind == '@' ? SVt_PVAV :
1325                               kind == '%' ? SVt_PVHV :
1326                               SVt_PVGV
1327                               );
1328         }
1329     }
1330 }
1331
1332 NV
1333 Perl_str_to_version(pTHX_ SV *sv)
1334 {
1335     NV retval = 0.0;
1336     NV nshift = 1.0;
1337     STRLEN len;
1338     const char *start = SvPV_const(sv,len);
1339     const char * const end = start + len;
1340     const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1341     while (start < end) {
1342         STRLEN skip;
1343         UV n;
1344         if (utf)
1345             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1346         else {
1347             n = *(U8*)start;
1348             skip = 1;
1349         }
1350         retval += ((NV)n)/nshift;
1351         start += skip;
1352         nshift *= 1000;
1353     }
1354     return retval;
1355 }
1356
1357 /*
1358  * S_force_version
1359  * Forces the next token to be a version number.
1360  * If the next token appears to be an invalid version number, (e.g. "v2b"),
1361  * and if "guessing" is TRUE, then no new token is created (and the caller
1362  * must use an alternative parsing method).
1363  */
1364
1365 STATIC char *
1366 S_force_version(pTHX_ char *s, int guessing)
1367 {
1368     dVAR;
1369     OP *version = NULL;
1370     char *d;
1371 #ifdef PERL_MAD
1372     I32 startoff = s - SvPVX(PL_linestr);
1373 #endif
1374
1375     s = SKIPSPACE1(s);
1376
1377     d = s;
1378     if (*d == 'v')
1379         d++;
1380     if (isDIGIT(*d)) {
1381         while (isDIGIT(*d) || *d == '_' || *d == '.')
1382             d++;
1383 #ifdef PERL_MAD
1384         if (PL_madskills) {
1385             start_force(PL_curforce);
1386             curmad('X', newSVpvn(s,d-s));
1387         }
1388 #endif
1389         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1390             SV *ver;
1391             s = scan_num(s, &yylval);
1392             version = yylval.opval;
1393             ver = cSVOPx(version)->op_sv;
1394             if (SvPOK(ver) && !SvNIOK(ver)) {
1395                 SvUPGRADE(ver, SVt_PVNV);
1396                 SvNV_set(ver, str_to_version(ver));
1397                 SvNOK_on(ver);          /* hint that it is a version */
1398             }
1399         }
1400         else if (guessing) {
1401 #ifdef PERL_MAD
1402             if (PL_madskills) {
1403                 sv_free(PL_nextwhite);  /* let next token collect whitespace */
1404                 PL_nextwhite = 0;
1405                 s = SvPVX(PL_linestr) + startoff;
1406             }
1407 #endif
1408             return s;
1409         }
1410     }
1411
1412 #ifdef PERL_MAD
1413     if (PL_madskills && !version) {
1414         sv_free(PL_nextwhite);  /* let next token collect whitespace */
1415         PL_nextwhite = 0;
1416         s = SvPVX(PL_linestr) + startoff;
1417     }
1418 #endif
1419     /* NOTE: The parser sees the package name and the VERSION swapped */
1420     start_force(PL_curforce);
1421     NEXTVAL_NEXTTOKE.opval = version;
1422     force_next(WORD);
1423
1424     return s;
1425 }
1426
1427 /*
1428  * S_tokeq
1429  * Tokenize a quoted string passed in as an SV.  It finds the next
1430  * chunk, up to end of string or a backslash.  It may make a new
1431  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
1432  * turns \\ into \.
1433  */
1434
1435 STATIC SV *
1436 S_tokeq(pTHX_ SV *sv)
1437 {
1438     dVAR;
1439     register char *s;
1440     register char *send;
1441     register char *d;
1442     STRLEN len = 0;
1443     SV *pv = sv;
1444
1445     if (!SvLEN(sv))
1446         goto finish;
1447
1448     s = SvPV_force(sv, len);
1449     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1450         goto finish;
1451     send = s + len;
1452     while (s < send && *s != '\\')
1453         s++;
1454     if (s == send)
1455         goto finish;
1456     d = s;
1457     if ( PL_hints & HINT_NEW_STRING ) {
1458         pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
1459         if (SvUTF8(sv))
1460             SvUTF8_on(pv);
1461     }
1462     while (s < send) {
1463         if (*s == '\\') {
1464             if (s + 1 < send && (s[1] == '\\'))
1465                 s++;            /* all that, just for this */
1466         }
1467         *d++ = *s++;
1468     }
1469     *d = '\0';
1470     SvCUR_set(sv, d - SvPVX_const(sv));
1471   finish:
1472     if ( PL_hints & HINT_NEW_STRING )
1473        return new_constant(NULL, 0, "q", sv, pv, "q");
1474     return sv;
1475 }
1476
1477 /*
1478  * Now come three functions related to double-quote context,
1479  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
1480  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
1481  * interact with PL_lex_state, and create fake ( ... ) argument lists
1482  * to handle functions and concatenation.
1483  * They assume that whoever calls them will be setting up a fake
1484  * join call, because each subthing puts a ',' after it.  This lets
1485  *   "lower \luPpEr"
1486  * become
1487  *  join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1488  *
1489  * (I'm not sure whether the spurious commas at the end of lcfirst's
1490  * arguments and join's arguments are created or not).
1491  */
1492
1493 /*
1494  * S_sublex_start
1495  * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1496  *
1497  * Pattern matching will set PL_lex_op to the pattern-matching op to
1498  * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1499  *
1500  * OP_CONST and OP_READLINE are easy--just make the new op and return.
1501  *
1502  * Everything else becomes a FUNC.
1503  *
1504  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1505  * had an OP_CONST or OP_READLINE).  This just sets us up for a
1506  * call to S_sublex_push().
1507  */
1508
1509 STATIC I32
1510 S_sublex_start(pTHX)
1511 {
1512     dVAR;
1513     register const I32 op_type = yylval.ival;
1514
1515     if (op_type == OP_NULL) {
1516         yylval.opval = PL_lex_op;
1517         PL_lex_op = NULL;
1518         return THING;
1519     }
1520     if (op_type == OP_CONST || op_type == OP_READLINE) {
1521         SV *sv = tokeq(PL_lex_stuff);
1522
1523         if (SvTYPE(sv) == SVt_PVIV) {
1524             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1525             STRLEN len;
1526             const char * const p = SvPV_const(sv, len);
1527             SV * const nsv = newSVpvn(p, len);
1528             if (SvUTF8(sv))
1529                 SvUTF8_on(nsv);
1530             SvREFCNT_dec(sv);
1531             sv = nsv;
1532         }
1533         yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1534         PL_lex_stuff = NULL;
1535         /* Allow <FH> // "foo" */
1536         if (op_type == OP_READLINE)
1537             PL_expect = XTERMORDORDOR;
1538         return THING;
1539     }
1540
1541     PL_sublex_info.super_state = PL_lex_state;
1542     PL_sublex_info.sub_inwhat = op_type;
1543     PL_sublex_info.sub_op = PL_lex_op;
1544     PL_lex_state = LEX_INTERPPUSH;
1545
1546     PL_expect = XTERM;
1547     if (PL_lex_op) {
1548         yylval.opval = PL_lex_op;
1549         PL_lex_op = NULL;
1550         return PMFUNC;
1551     }
1552     else
1553         return FUNC;
1554 }
1555
1556 /*
1557  * S_sublex_push
1558  * Create a new scope to save the lexing state.  The scope will be
1559  * ended in S_sublex_done.  Returns a '(', starting the function arguments
1560  * to the uc, lc, etc. found before.
1561  * Sets PL_lex_state to LEX_INTERPCONCAT.
1562  */
1563
1564 STATIC I32
1565 S_sublex_push(pTHX)
1566 {
1567     dVAR;
1568     ENTER;
1569
1570     PL_lex_state = PL_sublex_info.super_state;
1571     SAVEI32(PL_lex_dojoin);
1572     SAVEI32(PL_lex_brackets);
1573     SAVEI32(PL_lex_casemods);
1574     SAVEI32(PL_lex_starts);
1575     SAVEI32(PL_lex_state);
1576     SAVEVPTR(PL_lex_inpat);
1577     SAVEI32(PL_lex_inwhat);
1578     SAVECOPLINE(PL_curcop);
1579     SAVEPPTR(PL_bufptr);
1580     SAVEPPTR(PL_bufend);
1581     SAVEPPTR(PL_oldbufptr);
1582     SAVEPPTR(PL_oldoldbufptr);
1583     SAVEPPTR(PL_last_lop);
1584     SAVEPPTR(PL_last_uni);
1585     SAVEPPTR(PL_linestart);
1586     SAVESPTR(PL_linestr);
1587     SAVEGENERICPV(PL_lex_brackstack);
1588     SAVEGENERICPV(PL_lex_casestack);
1589
1590     PL_linestr = PL_lex_stuff;
1591     PL_lex_stuff = NULL;
1592
1593     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1594         = SvPVX(PL_linestr);
1595     PL_bufend += SvCUR(PL_linestr);
1596     PL_last_lop = PL_last_uni = NULL;
1597     SAVEFREESV(PL_linestr);
1598
1599     PL_lex_dojoin = FALSE;
1600     PL_lex_brackets = 0;
1601     Newx(PL_lex_brackstack, 120, char);
1602     Newx(PL_lex_casestack, 12, char);
1603     PL_lex_casemods = 0;
1604     *PL_lex_casestack = '\0';
1605     PL_lex_starts = 0;
1606     PL_lex_state = LEX_INTERPCONCAT;
1607     CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1608
1609     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1610     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1611         PL_lex_inpat = PL_sublex_info.sub_op;
1612     else
1613         PL_lex_inpat = NULL;
1614
1615     return '(';
1616 }
1617
1618 /*
1619  * S_sublex_done
1620  * Restores lexer state after a S_sublex_push.
1621  */
1622
1623 STATIC I32
1624 S_sublex_done(pTHX)
1625 {
1626     dVAR;
1627     if (!PL_lex_starts++) {
1628         SV * const sv = newSVpvs("");
1629         if (SvUTF8(PL_linestr))
1630             SvUTF8_on(sv);
1631         PL_expect = XOPERATOR;
1632         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1633         return THING;
1634     }
1635
1636     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
1637         PL_lex_state = LEX_INTERPCASEMOD;
1638         return yylex();
1639     }
1640
1641     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1642     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1643         PL_linestr = PL_lex_repl;
1644         PL_lex_inpat = 0;
1645         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1646         PL_bufend += SvCUR(PL_linestr);
1647         PL_last_lop = PL_last_uni = NULL;
1648         SAVEFREESV(PL_linestr);
1649         PL_lex_dojoin = FALSE;
1650         PL_lex_brackets = 0;
1651         PL_lex_casemods = 0;
1652         *PL_lex_casestack = '\0';
1653         PL_lex_starts = 0;
1654         if (SvEVALED(PL_lex_repl)) {
1655             PL_lex_state = LEX_INTERPNORMAL;
1656             PL_lex_starts++;
1657             /*  we don't clear PL_lex_repl here, so that we can check later
1658                 whether this is an evalled subst; that means we rely on the
1659                 logic to ensure sublex_done() is called again only via the
1660                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1661         }
1662         else {
1663             PL_lex_state = LEX_INTERPCONCAT;
1664             PL_lex_repl = NULL;
1665         }
1666         return ',';
1667     }
1668     else {
1669 #ifdef PERL_MAD
1670         if (PL_madskills) {
1671             if (PL_thiswhite) {
1672                 if (!PL_endwhite)
1673                     PL_endwhite = newSVpvn("",0);
1674                 sv_catsv(PL_endwhite, PL_thiswhite);
1675                 PL_thiswhite = 0;
1676             }
1677             if (PL_thistoken)
1678                 sv_setpvn(PL_thistoken,"",0);
1679             else
1680                 PL_realtokenstart = -1;
1681         }
1682 #endif
1683         LEAVE;
1684         PL_bufend = SvPVX(PL_linestr);
1685         PL_bufend += SvCUR(PL_linestr);
1686         PL_expect = XOPERATOR;
1687         PL_sublex_info.sub_inwhat = 0;
1688         return ')';
1689     }
1690 }
1691
1692 /*
1693   scan_const
1694
1695   Extracts a pattern, double-quoted string, or transliteration.  This
1696   is terrifying code.
1697
1698   It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1699   processing a pattern (PL_lex_inpat is true), a transliteration
1700   (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1701
1702   Returns a pointer to the character scanned up to. Iff this is
1703   advanced from the start pointer supplied (ie if anything was
1704   successfully parsed), will leave an OP for the substring scanned
1705   in yylval. Caller must intuit reason for not parsing further
1706   by looking at the next characters herself.
1707
1708   In patterns:
1709     backslashes:
1710       double-quoted style: \r and \n
1711       regexp special ones: \D \s
1712       constants: \x3
1713       backrefs: \1 (deprecated in substitution replacements)
1714       case and quoting: \U \Q \E
1715     stops on @ and $, but not for $ as tail anchor
1716
1717   In transliterations:
1718     characters are VERY literal, except for - not at the start or end
1719     of the string, which indicates a range.  scan_const expands the
1720     range to the full set of intermediate characters.
1721
1722   In double-quoted strings:
1723     backslashes:
1724       double-quoted style: \r and \n
1725       constants: \x3
1726       backrefs: \1 (deprecated)
1727       case and quoting: \U \Q \E
1728     stops on @ and $
1729
1730   scan_const does *not* construct ops to handle interpolated strings.
1731   It stops processing as soon as it finds an embedded $ or @ variable
1732   and leaves it to the caller to work out what's going on.
1733
1734   @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1735
1736   $ in pattern could be $foo or could be tail anchor.  Assumption:
1737   it's a tail anchor if $ is the last thing in the string, or if it's
1738   followed by one of ")| \n\t"
1739
1740   \1 (backreferences) are turned into $1
1741
1742   The structure of the code is
1743       while (there's a character to process) {
1744           handle transliteration ranges
1745           skip regexp comments
1746           skip # initiated comments in //x patterns
1747           check for embedded @foo
1748           check for embedded scalars
1749           if (backslash) {
1750               leave intact backslashes from leave (below)
1751               deprecate \1 in strings and sub replacements
1752               handle string-changing backslashes \l \U \Q \E, etc.
1753               switch (what was escaped) {
1754                   handle - in a transliteration (becomes a literal -)
1755                   handle \132 octal characters
1756                   handle 0x15 hex characters
1757                   handle \cV (control V)
1758                   handle printf backslashes (\f, \r, \n, etc)
1759               } (end switch)
1760           } (end if backslash)
1761     } (end while character to read)
1762
1763 */
1764
1765 STATIC char *
1766 S_scan_const(pTHX_ char *start)
1767 {
1768     dVAR;
1769     register char *send = PL_bufend;            /* end of the constant */
1770     SV *sv = newSV(send - start);               /* sv for the constant */
1771     register char *s = start;                   /* start of the constant */
1772     register char *d = SvPVX(sv);               /* destination for copies */
1773     bool dorange = FALSE;                       /* are we in a translit range? */
1774     bool didrange = FALSE;                      /* did we just finish a range? */
1775     I32  has_utf8 = FALSE;                      /* Output constant is UTF8 */
1776     I32  this_utf8 = UTF;                       /* The source string is assumed to be UTF8 */
1777     UV uv;
1778 #ifdef EBCDIC
1779     UV literal_endpoint = 0;
1780 #endif
1781
1782     const char * const leaveit = /* set of acceptably-backslashed characters */
1783         PL_lex_inpat
1784             ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
1785             : "";
1786
1787     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1788         /* If we are doing a trans and we know we want UTF8 set expectation */
1789         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1790         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1791     }
1792
1793
1794     while (s < send || dorange) {
1795         /* get transliterations out of the way (they're most literal) */
1796         if (PL_lex_inwhat == OP_TRANS) {
1797             /* expand a range A-Z to the full set of characters.  AIE! */
1798             if (dorange) {
1799                 I32 i;                          /* current expanded character */
1800                 I32 min;                        /* first character in range */
1801                 I32 max;                        /* last character in range */
1802
1803                 if (has_utf8) {
1804                     char * const c = (char*)utf8_hop((U8*)d, -1);
1805                     char *e = d++;
1806                     while (e-- > c)
1807                         *(e + 1) = *e;
1808                     *c = (char)UTF_TO_NATIVE(0xff);
1809                     /* mark the range as done, and continue */
1810                     dorange = FALSE;
1811                     didrange = TRUE;
1812                     continue;
1813                 }
1814
1815                 i = d - SvPVX_const(sv);                /* remember current offset */
1816                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
1817                 d = SvPVX(sv) + i;              /* refresh d after realloc */
1818                 d -= 2;                         /* eat the first char and the - */
1819
1820                 min = (U8)*d;                   /* first char in range */
1821                 max = (U8)d[1];                 /* last char in range  */
1822
1823                 if (min > max) {
1824                     Perl_croak(aTHX_
1825                                "Invalid range \"%c-%c\" in transliteration operator",
1826                                (char)min, (char)max);
1827                 }
1828
1829 #ifdef EBCDIC
1830                 if (literal_endpoint == 2 &&
1831                     ((isLOWER(min) && isLOWER(max)) ||
1832                      (isUPPER(min) && isUPPER(max)))) {
1833                     if (isLOWER(min)) {
1834                         for (i = min; i <= max; i++)
1835                             if (isLOWER(i))
1836                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1837                     } else {
1838                         for (i = min; i <= max; i++)
1839                             if (isUPPER(i))
1840                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1841                     }
1842                 }
1843                 else
1844 #endif
1845                     for (i = min; i <= max; i++)
1846                         *d++ = (char)i;
1847
1848                 /* mark the range as done, and continue */
1849                 dorange = FALSE;
1850                 didrange = TRUE;
1851 #ifdef EBCDIC
1852                 literal_endpoint = 0;
1853 #endif
1854                 continue;
1855             }
1856
1857             /* range begins (ignore - as first or last char) */
1858             else if (*s == '-' && s+1 < send  && s != start) {
1859                 if (didrange) {
1860                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1861                 }
1862                 if (has_utf8) {
1863                     *d++ = (char)UTF_TO_NATIVE(0xff);   /* use illegal utf8 byte--see pmtrans */
1864                     s++;
1865                     continue;
1866                 }
1867                 dorange = TRUE;
1868                 s++;
1869             }
1870             else {
1871                 didrange = FALSE;
1872 #ifdef EBCDIC
1873                 literal_endpoint = 0;
1874 #endif
1875             }
1876         }
1877
1878         /* if we get here, we're not doing a transliteration */
1879
1880         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1881            except for the last char, which will be done separately. */
1882         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1883             if (s[2] == '#') {
1884                 while (s+1 < send && *s != ')')
1885                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1886             }
1887             else if (s[2] == '{' /* This should match regcomp.c */
1888                      || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1889             {
1890                 I32 count = 1;
1891                 char *regparse = s + (s[2] == '{' ? 3 : 4);
1892                 char c;
1893
1894                 while (count && (c = *regparse)) {
1895                     if (c == '\\' && regparse[1])
1896                         regparse++;
1897                     else if (c == '{')
1898                         count++;
1899                     else if (c == '}')
1900                         count--;
1901                     regparse++;
1902                 }
1903                 if (*regparse != ')')
1904                     regparse--;         /* Leave one char for continuation. */
1905                 while (s < regparse)
1906                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1907             }
1908         }
1909
1910         /* likewise skip #-initiated comments in //x patterns */
1911         else if (*s == '#' && PL_lex_inpat &&
1912           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1913             while (s+1 < send && *s != '\n')
1914                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1915         }
1916
1917         /* check for embedded arrays
1918            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1919            */
1920         else if (*s == '@' && s[1]
1921                  && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1922             break;
1923
1924         /* check for embedded scalars.  only stop if we're sure it's a
1925            variable.
1926         */
1927         else if (*s == '$') {
1928             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
1929                 break;
1930             if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1931                 break;          /* in regexp, $ might be tail anchor */
1932         }
1933
1934         /* End of else if chain - OP_TRANS rejoin rest */
1935
1936         /* backslashes */
1937         if (*s == '\\' && s+1 < send) {
1938             s++;
1939
1940             /* some backslashes we leave behind */
1941             if (*leaveit && *s && strchr(leaveit, *s)) {
1942                 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1943                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1944                 continue;
1945             }
1946
1947             /* deprecate \1 in strings and substitution replacements */
1948             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1949                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1950             {
1951                 if (ckWARN(WARN_SYNTAX))
1952                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1953                 *--s = '$';
1954                 break;
1955             }
1956
1957             /* string-change backslash escapes */
1958             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1959                 --s;
1960                 break;
1961             }
1962
1963             /* if we get here, it's either a quoted -, or a digit */
1964             switch (*s) {
1965
1966             /* quoted - in transliterations */
1967             case '-':
1968                 if (PL_lex_inwhat == OP_TRANS) {
1969                     *d++ = *s++;
1970                     continue;
1971                 }
1972                 /* FALL THROUGH */
1973             default:
1974                 {
1975                     if (isALNUM(*s) &&
1976                         *s != '_' &&
1977                         ckWARN(WARN_MISC))
1978                         Perl_warner(aTHX_ packWARN(WARN_MISC),
1979                                "Unrecognized escape \\%c passed through",
1980                                *s);
1981                     /* default action is to copy the quoted character */
1982                     goto default_action;
1983                 }
1984
1985             /* \132 indicates an octal constant */
1986             case '0': case '1': case '2': case '3':
1987             case '4': case '5': case '6': case '7':
1988                 {
1989                     I32 flags = 0;
1990                     STRLEN len = 3;
1991                     uv = grok_oct(s, &len, &flags, NULL);
1992                     s += len;
1993                 }
1994                 goto NUM_ESCAPE_INSERT;
1995
1996             /* \x24 indicates a hex constant */
1997             case 'x':
1998                 ++s;
1999                 if (*s == '{') {
2000                     char* const e = strchr(s, '}');
2001                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2002                       PERL_SCAN_DISALLOW_PREFIX;
2003                     STRLEN len;
2004
2005                     ++s;
2006                     if (!e) {
2007                         yyerror("Missing right brace on \\x{}");
2008                         continue;
2009                     }
2010                     len = e - s;
2011                     uv = grok_hex(s, &len, &flags, NULL);
2012                     s = e + 1;
2013                 }
2014                 else {
2015                     {
2016                         STRLEN len = 2;
2017                         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2018                         uv = grok_hex(s, &len, &flags, NULL);
2019                         s += len;
2020                     }
2021                 }
2022
2023               NUM_ESCAPE_INSERT:
2024                 /* Insert oct or hex escaped character.
2025                  * There will always enough room in sv since such
2026                  * escapes will be longer than any UTF-8 sequence
2027                  * they can end up as. */
2028
2029                 /* We need to map to chars to ASCII before doing the tests
2030                    to cover EBCDIC
2031                 */
2032                 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
2033                     if (!has_utf8 && uv > 255) {
2034                         /* Might need to recode whatever we have
2035                          * accumulated so far if it contains any
2036                          * hibit chars.
2037                          *
2038                          * (Can't we keep track of that and avoid
2039                          *  this rescan? --jhi)
2040                          */
2041                         int hicount = 0;
2042                         U8 *c;
2043                         for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
2044                             if (!NATIVE_IS_INVARIANT(*c)) {
2045                                 hicount++;
2046                             }
2047                         }
2048                         if (hicount) {
2049                             const STRLEN offset = d - SvPVX_const(sv);
2050                             U8 *src, *dst;
2051                             d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
2052                             src = (U8 *)d - 1;
2053                             dst = src+hicount;
2054                             d  += hicount;
2055                             while (src >= (const U8 *)SvPVX_const(sv)) {
2056                                 if (!NATIVE_IS_INVARIANT(*src)) {
2057                                     const U8 ch = NATIVE_TO_ASCII(*src);
2058                                     *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
2059                                     *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
2060                                 }
2061                                 else {
2062                                     *dst-- = *src;
2063                                 }
2064                                 src--;
2065                             }
2066                         }
2067                     }
2068
2069                     if (has_utf8 || uv > 255) {
2070                         d = (char*)uvchr_to_utf8((U8*)d, uv);
2071                         has_utf8 = TRUE;
2072                         if (PL_lex_inwhat == OP_TRANS &&
2073                             PL_sublex_info.sub_op) {
2074                             PL_sublex_info.sub_op->op_private |=
2075                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
2076                                              : OPpTRANS_TO_UTF);
2077                         }
2078                     }
2079                     else {
2080                         *d++ = (char)uv;
2081                     }
2082                 }
2083                 else {
2084                     *d++ = (char) uv;
2085                 }
2086                 continue;
2087
2088             /* \N{LATIN SMALL LETTER A} is a named character */
2089             case 'N':
2090                 ++s;
2091                 if (*s == '{') {
2092                     char* e = strchr(s, '}');
2093                     SV *res;
2094                     STRLEN len;
2095                     const char *str;
2096
2097                     if (!e) {
2098                         yyerror("Missing right brace on \\N{}");
2099                         e = s - 1;
2100                         goto cont_scan;
2101                     }
2102                     if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2103                         /* \N{U+...} */
2104                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2105                           PERL_SCAN_DISALLOW_PREFIX;
2106                         s += 3;
2107                         len = e - s;
2108                         uv = grok_hex(s, &len, &flags, NULL);
2109                         s = e + 1;
2110                         goto NUM_ESCAPE_INSERT;
2111                     }
2112                     res = newSVpvn(s + 1, e - s - 1);
2113                     res = new_constant( NULL, 0, "charnames",
2114                                         res, NULL, "\\N{...}" );
2115                     if (has_utf8)
2116                         sv_utf8_upgrade(res);
2117                     str = SvPV_const(res,len);
2118 #ifdef EBCDIC_NEVER_MIND
2119                     /* charnames uses pack U and that has been
2120                      * recently changed to do the below uni->native
2121                      * mapping, so this would be redundant (and wrong,
2122                      * the code point would be doubly converted).
2123                      * But leave this in just in case the pack U change
2124                      * gets revoked, but the semantics is still
2125                      * desireable for charnames. --jhi */
2126                     {
2127                          UV uv = utf8_to_uvchr((const U8*)str, 0);
2128
2129                          if (uv < 0x100) {
2130                               U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2131
2132                               d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2133                               sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2134                               str = SvPV_const(res, len);
2135                          }
2136                     }
2137 #endif
2138                     if (!has_utf8 && SvUTF8(res)) {
2139                         const char * const ostart = SvPVX_const(sv);
2140                         SvCUR_set(sv, d - ostart);
2141                         SvPOK_on(sv);
2142                         *d = '\0';
2143                         sv_utf8_upgrade(sv);
2144                         /* this just broke our allocation above... */
2145                         SvGROW(sv, (STRLEN)(send - start));
2146                         d = SvPVX(sv) + SvCUR(sv);
2147                         has_utf8 = TRUE;
2148                     }
2149                     if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2150                         const char * const odest = SvPVX_const(sv);
2151
2152                         SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
2153                         d = SvPVX(sv) + (d - odest);
2154                     }
2155                     Copy(str, d, len, char);
2156                     d += len;
2157                     SvREFCNT_dec(res);
2158                   cont_scan:
2159                     s = e + 1;
2160                 }
2161                 else
2162                     yyerror("Missing braces on \\N{}");
2163                 continue;
2164
2165             /* \c is a control character */
2166             case 'c':
2167                 s++;
2168                 if (s < send) {
2169                     U8 c = *s++;
2170 #ifdef EBCDIC
2171                     if (isLOWER(c))
2172                         c = toUPPER(c);
2173 #endif
2174                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2175                 }
2176                 else {
2177                     yyerror("Missing control char name in \\c");
2178                 }
2179                 continue;
2180
2181             /* printf-style backslashes, formfeeds, newlines, etc */
2182             case 'b':
2183                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2184                 break;
2185             case 'n':
2186                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2187                 break;
2188             case 'r':
2189                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2190                 break;
2191             case 'f':
2192                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2193                 break;
2194             case 't':
2195                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2196                 break;
2197             case 'e':
2198                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2199                 break;
2200             case 'a':
2201                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2202                 break;
2203             } /* end switch */
2204
2205             s++;
2206             continue;
2207         } /* end if (backslash) */
2208 #ifdef EBCDIC
2209         else
2210             literal_endpoint++;
2211 #endif
2212
2213     default_action:
2214         /* If we started with encoded form, or already know we want it
2215            and then encode the next character */
2216         if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
2217             STRLEN len  = 1;
2218             const UV nextuv   = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2219             const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2220             s += len;
2221             if (need > len) {
2222                 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
2223                 const STRLEN off = d - SvPVX_const(sv);
2224                 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
2225             }
2226             d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2227             has_utf8 = TRUE;
2228         }
2229         else {
2230             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2231         }
2232     } /* while loop to process each character */
2233
2234     /* terminate the string and set up the sv */
2235     *d = '\0';
2236     SvCUR_set(sv, d - SvPVX_const(sv));
2237     if (SvCUR(sv) >= SvLEN(sv))
2238         Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2239
2240     SvPOK_on(sv);
2241     if (PL_encoding && !has_utf8) {
2242         sv_recode_to_utf8(sv, PL_encoding);
2243         if (SvUTF8(sv))
2244             has_utf8 = TRUE;
2245     }
2246     if (has_utf8) {
2247         SvUTF8_on(sv);
2248         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2249             PL_sublex_info.sub_op->op_private |=
2250                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2251         }
2252     }
2253
2254     /* shrink the sv if we allocated more than we used */
2255     if (SvCUR(sv) + 5 < SvLEN(sv)) {
2256         SvPV_shrink_to_cur(sv);
2257     }
2258
2259     /* return the substring (via yylval) only if we parsed anything */
2260     if (s > PL_bufptr) {
2261         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
2262             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
2263                               sv, NULL,
2264                               ( PL_lex_inwhat == OP_TRANS
2265                                 ? "tr"
2266                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
2267                                     ? "s"
2268                                     : "qq")));
2269         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2270     } else
2271         SvREFCNT_dec(sv);
2272     return s;
2273 }
2274
2275 /* S_intuit_more
2276  * Returns TRUE if there's more to the expression (e.g., a subscript),
2277  * FALSE otherwise.
2278  *
2279  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2280  *
2281  * ->[ and ->{ return TRUE
2282  * { and [ outside a pattern are always subscripts, so return TRUE
2283  * if we're outside a pattern and it's not { or [, then return FALSE
2284  * if we're in a pattern and the first char is a {
2285  *   {4,5} (any digits around the comma) returns FALSE
2286  * if we're in a pattern and the first char is a [
2287  *   [] returns FALSE
2288  *   [SOMETHING] has a funky algorithm to decide whether it's a
2289  *      character class or not.  It has to deal with things like
2290  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2291  * anything else returns TRUE
2292  */
2293
2294 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2295
2296 STATIC int
2297 S_intuit_more(pTHX_ register char *s)
2298 {
2299     dVAR;
2300     if (PL_lex_brackets)
2301         return TRUE;
2302     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2303         return TRUE;
2304     if (*s != '{' && *s != '[')
2305         return FALSE;
2306     if (!PL_lex_inpat)
2307         return TRUE;
2308
2309     /* In a pattern, so maybe we have {n,m}. */
2310     if (*s == '{') {
2311         s++;
2312         if (!isDIGIT(*s))
2313             return TRUE;
2314         while (isDIGIT(*s))
2315             s++;
2316         if (*s == ',')
2317             s++;
2318         while (isDIGIT(*s))
2319             s++;
2320         if (*s == '}')
2321             return FALSE;
2322         return TRUE;
2323
2324     }
2325
2326     /* On the other hand, maybe we have a character class */
2327
2328     s++;
2329     if (*s == ']' || *s == '^')
2330         return FALSE;
2331     else {
2332         /* this is terrifying, and it works */
2333         int weight = 2;         /* let's weigh the evidence */
2334         char seen[256];
2335         unsigned char un_char = 255, last_un_char;
2336         const char * const send = strchr(s,']');
2337         char tmpbuf[sizeof PL_tokenbuf * 4];
2338
2339         if (!send)              /* has to be an expression */
2340             return TRUE;
2341
2342         Zero(seen,256,char);
2343         if (*s == '$')
2344             weight -= 3;
2345         else if (isDIGIT(*s)) {
2346             if (s[1] != ']') {
2347                 if (isDIGIT(s[1]) && s[2] == ']')
2348                     weight -= 10;
2349             }
2350             else
2351                 weight -= 100;
2352         }
2353         for (; s < send; s++) {
2354             last_un_char = un_char;
2355             un_char = (unsigned char)*s;
2356             switch (*s) {
2357             case '@':
2358             case '&':
2359             case '$':
2360                 weight -= seen[un_char] * 10;
2361                 if (isALNUM_lazy_if(s+1,UTF)) {
2362                     int len;
2363                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2364                     len = (int)strlen(tmpbuf);
2365                     if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2366                         weight -= 100;
2367                     else
2368                         weight -= 10;
2369                 }
2370                 else if (*s == '$' && s[1] &&
2371                   strchr("[#!%*<>()-=",s[1])) {
2372                     if (/*{*/ strchr("])} =",s[2]))
2373                         weight -= 10;
2374                     else
2375                         weight -= 1;
2376                 }
2377                 break;
2378             case '\\':
2379                 un_char = 254;
2380                 if (s[1]) {
2381                     if (strchr("wds]",s[1]))
2382                         weight += 100;
2383                     else if (seen['\''] || seen['"'])
2384                         weight += 1;
2385                     else if (strchr("rnftbxcav",s[1]))
2386                         weight += 40;
2387                     else if (isDIGIT(s[1])) {
2388                         weight += 40;
2389                         while (s[1] && isDIGIT(s[1]))
2390                             s++;
2391                     }
2392                 }
2393                 else
2394                     weight += 100;
2395                 break;
2396             case '-':
2397                 if (s[1] == '\\')
2398                     weight += 50;
2399                 if (strchr("aA01! ",last_un_char))
2400                     weight += 30;
2401                 if (strchr("zZ79~",s[1]))
2402                     weight += 30;
2403                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2404                     weight -= 5;        /* cope with negative subscript */
2405                 break;
2406             default:
2407                 if (!isALNUM(last_un_char)
2408                     && !(last_un_char == '$' || last_un_char == '@'
2409                          || last_un_char == '&')
2410                     && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2411                     char *d = tmpbuf;
2412                     while (isALPHA(*s))
2413                         *d++ = *s++;
2414                     *d = '\0';
2415                     if (keyword(tmpbuf, d - tmpbuf))
2416                         weight -= 150;
2417                 }
2418                 if (un_char == last_un_char + 1)
2419                     weight += 5;
2420                 weight -= seen[un_char];
2421                 break;
2422             }
2423             seen[un_char]++;
2424         }
2425         if (weight >= 0)        /* probably a character class */
2426             return FALSE;
2427     }
2428
2429     return TRUE;
2430 }
2431
2432 /*
2433  * S_intuit_method
2434  *
2435  * Does all the checking to disambiguate
2436  *   foo bar
2437  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
2438  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2439  *
2440  * First argument is the stuff after the first token, e.g. "bar".
2441  *
2442  * Not a method if bar is a filehandle.
2443  * Not a method if foo is a subroutine prototyped to take a filehandle.
2444  * Not a method if it's really "Foo $bar"
2445  * Method if it's "foo $bar"
2446  * Not a method if it's really "print foo $bar"
2447  * Method if it's really "foo package::" (interpreted as package->foo)
2448  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2449  * Not a method if bar is a filehandle or package, but is quoted with
2450  *   =>
2451  */
2452
2453 STATIC int
2454 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2455 {
2456     dVAR;
2457     char *s = start + (*start == '$');
2458     char tmpbuf[sizeof PL_tokenbuf];
2459     STRLEN len;
2460     GV* indirgv;
2461 #ifdef PERL_MAD
2462     int soff;
2463 #endif
2464
2465     if (gv) {
2466         if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2467             return 0;
2468         if (cv) {
2469             if (SvPOK(cv)) {
2470                 const char *proto = SvPVX_const(cv);
2471                 if (proto) {
2472                     if (*proto == ';')
2473                         proto++;
2474                     if (*proto == '*')
2475                         return 0;
2476                 }
2477             }
2478         } else
2479             gv = 0;
2480     }
2481     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2482     /* start is the beginning of the possible filehandle/object,
2483      * and s is the end of it
2484      * tmpbuf is a copy of it
2485      */
2486
2487     if (*start == '$') {
2488         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2489             return 0;
2490 #ifdef PERL_MAD
2491         len = start - SvPVX(PL_linestr);
2492 #endif
2493         s = PEEKSPACE(s);
2494 #ifdef PERLMAD
2495         start = SvPVX(PL_linestr) + len;
2496 #endif
2497         PL_bufptr = start;
2498         PL_expect = XREF;
2499         return *s == '(' ? FUNCMETH : METHOD;
2500     }
2501     if (!keyword(tmpbuf, len)) {
2502         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2503             len -= 2;
2504             tmpbuf[len] = '\0';
2505 #ifdef PERL_MAD
2506             soff = s - SvPVX(PL_linestr);
2507 #endif
2508             goto bare_package;
2509         }
2510         indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2511         if (indirgv && GvCVu(indirgv))
2512             return 0;
2513         /* filehandle or package name makes it a method */
2514         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2515 #ifdef PERL_MAD
2516             soff = s - SvPVX(PL_linestr);
2517 #endif
2518             s = PEEKSPACE(s);
2519             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2520                 return 0;       /* no assumptions -- "=>" quotes bearword */
2521       bare_package:
2522             start_force(PL_curforce);
2523             NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2524                                                    newSVpvn(tmpbuf,len));
2525             NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2526             if (PL_madskills)
2527                 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2528             PL_expect = XTERM;
2529             force_next(WORD);
2530             PL_bufptr = s;
2531 #ifdef PERL_MAD
2532             PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2533 #endif
2534             return *s == '(' ? FUNCMETH : METHOD;
2535         }
2536     }
2537     return 0;
2538 }
2539
2540 /*
2541  * S_incl_perldb
2542  * Return a string of Perl code to load the debugger.  If PERL5DB
2543  * is set, it will return the contents of that, otherwise a
2544  * compile-time require of perl5db.pl.
2545  */
2546
2547 STATIC const char*
2548 S_incl_perldb(pTHX)
2549 {
2550     dVAR;
2551     if (PL_perldb) {
2552         const char * const pdb = PerlEnv_getenv("PERL5DB");
2553
2554         if (pdb)
2555             return pdb;
2556         SETERRNO(0,SS_NORMAL);
2557         return "BEGIN { require 'perl5db.pl' }";
2558     }
2559     return "";
2560 }
2561
2562
2563 /* Encoded script support. filter_add() effectively inserts a
2564  * 'pre-processing' function into the current source input stream.
2565  * Note that the filter function only applies to the current source file
2566  * (e.g., it will not affect files 'require'd or 'use'd by this one).
2567  *
2568  * The datasv parameter (which may be NULL) can be used to pass
2569  * private data to this instance of the filter. The filter function
2570  * can recover the SV using the FILTER_DATA macro and use it to
2571  * store private buffers and state information.
2572  *
2573  * The supplied datasv parameter is upgraded to a PVIO type
2574  * and the IoDIRP/IoANY field is used to store the function pointer,
2575  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2576  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2577  * private use must be set using malloc'd pointers.
2578  */
2579
2580 SV *
2581 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2582 {
2583     dVAR;
2584     if (!funcp)
2585         return NULL;
2586
2587     if (!PL_rsfp_filters)
2588         PL_rsfp_filters = newAV();
2589     if (!datasv)
2590         datasv = newSV(0);
2591     SvUPGRADE(datasv, SVt_PVIO);
2592     IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2593     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2594     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2595                           IoANY(datasv), SvPV_nolen(datasv)));
2596     av_unshift(PL_rsfp_filters, 1);
2597     av_store(PL_rsfp_filters, 0, datasv) ;
2598     return(datasv);
2599 }
2600
2601
2602 /* Delete most recently added instance of this filter function. */
2603 void
2604 Perl_filter_del(pTHX_ filter_t funcp)
2605 {
2606     dVAR;
2607     SV *datasv;
2608
2609 #ifdef DEBUGGING
2610     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp)));
2611 #endif
2612     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2613         return;
2614     /* if filter is on top of stack (usual case) just pop it off */
2615     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2616     if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2617         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2618         IoANY(datasv) = (void *)NULL;
2619         sv_free(av_pop(PL_rsfp_filters));
2620
2621         return;
2622     }
2623     /* we need to search for the correct entry and clear it     */
2624     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2625 }
2626
2627
2628 /* Invoke the idxth filter function for the current rsfp.        */
2629 /* maxlen 0 = read one text line */
2630 I32
2631 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2632 {
2633     dVAR;
2634     filter_t funcp;
2635     SV *datasv = NULL;
2636     /* This API is bad. It should have been using unsigned int for maxlen.
2637        Not sure if we want to change the API, but if not we should sanity
2638        check the value here.  */
2639     const unsigned int correct_length = maxlen < 0 ? INT_MAX : maxlen;
2640
2641     if (!PL_rsfp_filters)
2642         return -1;
2643     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
2644         /* Provide a default input filter to make life easy.    */
2645         /* Note that we append to the line. This is handy.      */
2646         DEBUG_P(PerlIO_printf(Perl_debug_log,
2647                               "filter_read %d: from rsfp\n", idx));
2648         if (correct_length) {
2649             /* Want a block */
2650             int len ;
2651             const int old_len = SvCUR(buf_sv);
2652
2653             /* ensure buf_sv is large enough */
2654             SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2655             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2656                                    correct_length)) <= 0) {
2657                 if (PerlIO_error(PL_rsfp))
2658                     return -1;          /* error */
2659                 else
2660                     return 0 ;          /* end of file */
2661             }
2662             SvCUR_set(buf_sv, old_len + len) ;
2663         } else {
2664             /* Want a line */
2665             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2666                 if (PerlIO_error(PL_rsfp))
2667                     return -1;          /* error */
2668                 else
2669                     return 0 ;          /* end of file */
2670             }
2671         }
2672         return SvCUR(buf_sv);
2673     }
2674     /* Skip this filter slot if filter has been deleted */
2675     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2676         DEBUG_P(PerlIO_printf(Perl_debug_log,
2677                               "filter_read %d: skipped (filter deleted)\n",
2678                               idx));
2679         return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2680     }
2681     /* Get function pointer hidden within datasv        */
2682     funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2683     DEBUG_P(PerlIO_printf(Perl_debug_log,
2684                           "filter_read %d: via function %p (%s)\n",
2685                           idx, datasv, SvPV_nolen_const(datasv)));
2686     /* Call function. The function is expected to       */
2687     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2688     /* Return: <0:error, =0:eof, >0:not eof             */
2689     return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2690 }
2691
2692 STATIC char *
2693 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2694 {
2695     dVAR;
2696 #ifdef PERL_CR_FILTER
2697     if (!PL_rsfp_filters) {
2698         filter_add(S_cr_textfilter,NULL);
2699     }
2700 #endif
2701     if (PL_rsfp_filters) {
2702         if (!append)
2703             SvCUR_set(sv, 0);   /* start with empty line        */
2704         if (FILTER_READ(0, sv, 0) > 0)
2705             return ( SvPVX(sv) ) ;
2706         else
2707             return NULL ;
2708     }
2709     else
2710         return (sv_gets(sv, fp, append));
2711 }
2712
2713 STATIC HV *
2714 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2715 {
2716     dVAR;
2717     GV *gv;
2718
2719     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2720         return PL_curstash;
2721
2722     if (len > 2 &&
2723         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2724         (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
2725     {
2726         return GvHV(gv);                        /* Foo:: */
2727     }
2728
2729     /* use constant CLASS => 'MyClass' */
2730     if ((gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV))) {
2731         SV *sv;
2732         if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2733             pkgname = SvPV_nolen_const(sv);
2734         }
2735     }
2736
2737     return gv_stashpv(pkgname, FALSE);
2738 }
2739
2740 #ifdef PERL_MAD
2741  /*
2742  * Perl_madlex
2743  * The intent of this yylex wrapper is to minimize the changes to the
2744  * tokener when we aren't interested in collecting madprops.  It remains
2745  * to be seen how successful this strategy will be...
2746  */
2747
2748 int
2749 Perl_madlex(pTHX)
2750 {
2751     int optype;
2752     char *s = PL_bufptr;
2753
2754     /* make sure PL_thiswhite is initialized */
2755     PL_thiswhite = 0;
2756     PL_thismad = 0;
2757
2758     /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
2759     if (PL_pending_ident)
2760         return S_pending_ident(aTHX);
2761
2762     /* previous token ate up our whitespace? */
2763     if (!PL_lasttoke && PL_nextwhite) {
2764         PL_thiswhite = PL_nextwhite;
2765         PL_nextwhite = 0;
2766     }
2767
2768     /* isolate the token, and figure out where it is without whitespace */
2769     PL_realtokenstart = -1;
2770     PL_thistoken = 0;
2771     optype = yylex();
2772     s = PL_bufptr;
2773     assert(PL_curforce < 0);
2774
2775     if (!PL_thismad || PL_thismad->mad_key == '^') {    /* not forced already? */
2776         if (!PL_thistoken) {
2777             if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
2778                 PL_thistoken = newSVpvn("",0);
2779             else {
2780                 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
2781                 PL_thistoken = newSVpvn(tstart, s - tstart);
2782             }
2783         }
2784         if (PL_thismad) /* install head */
2785             CURMAD('X', PL_thistoken);
2786     }
2787
2788     /* last whitespace of a sublex? */
2789     if (optype == ')' && PL_endwhite) {
2790         CURMAD('X', PL_endwhite);
2791     }
2792
2793     if (!PL_thismad) {
2794
2795         /* if no whitespace and we're at EOF, bail.  Otherwise fake EOF below. */
2796         if (!PL_thiswhite && !PL_endwhite && !optype) {
2797             sv_free(PL_thistoken);
2798             PL_thistoken = 0;
2799             return 0;
2800         }
2801
2802         /* put off final whitespace till peg */
2803         if (optype == ';' && !PL_rsfp) {
2804             PL_nextwhite = PL_thiswhite;
2805             PL_thiswhite = 0;
2806         }
2807         else if (PL_thisopen) {
2808             CURMAD('q', PL_thisopen);
2809             if (PL_thistoken)
2810                 sv_free(PL_thistoken);
2811             PL_thistoken = 0;
2812         }
2813         else {
2814             /* Store actual token text as madprop X */
2815             CURMAD('X', PL_thistoken);
2816         }
2817
2818         if (PL_thiswhite) {
2819             /* add preceding whitespace as madprop _ */
2820             CURMAD('_', PL_thiswhite);
2821         }
2822
2823         if (PL_thisstuff) {
2824             /* add quoted material as madprop = */
2825             CURMAD('=', PL_thisstuff);
2826         }
2827
2828         if (PL_thisclose) {
2829             /* add terminating quote as madprop Q */
2830             CURMAD('Q', PL_thisclose);
2831         }
2832     }
2833
2834     /* special processing based on optype */
2835
2836     switch (optype) {
2837
2838     /* opval doesn't need a TOKEN since it can already store mp */
2839     case WORD:
2840     case METHOD:
2841     case FUNCMETH:
2842     case THING:
2843     case PMFUNC:
2844     case PRIVATEREF:
2845     case FUNC0SUB:
2846     case UNIOPSUB:
2847     case LSTOPSUB:
2848         if (yylval.opval)
2849             append_madprops(PL_thismad, yylval.opval, 0);
2850         PL_thismad = 0;
2851         return optype;
2852
2853     /* fake EOF */
2854     case 0:
2855         optype = PEG;
2856         if (PL_endwhite) {
2857             addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
2858             PL_endwhite = 0;
2859         }
2860         break;
2861
2862     case ']':
2863     case '}':
2864         if (PL_faketokens)
2865             break;
2866         /* remember any fake bracket that lexer is about to discard */
2867         if (PL_lex_brackets == 1 &&
2868             ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
2869         {
2870             s = PL_bufptr;
2871             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2872                 s++;
2873             if (*s == '}') {
2874                 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
2875                 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
2876                 PL_thiswhite = 0;
2877                 PL_bufptr = s - 1;
2878                 break;  /* don't bother looking for trailing comment */
2879             }
2880             else
2881                 s = PL_bufptr;
2882         }
2883         if (optype == ']')
2884             break;
2885         /* FALLTHROUGH */
2886
2887     /* attach a trailing comment to its statement instead of next token */
2888     case ';':
2889         if (PL_faketokens)
2890             break;
2891         if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
2892             s = PL_bufptr;
2893             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2894                 s++;
2895             if (*s == '\n' || *s == '#') {
2896                 while (s < PL_bufend && *s != '\n')
2897                     s++;
2898                 if (s < PL_bufend)
2899                     s++;
2900                 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
2901                 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
2902                 PL_thiswhite = 0;
2903                 PL_bufptr = s;
2904             }
2905         }
2906         break;
2907
2908     /* pval */
2909     case LABEL:
2910         break;
2911
2912     /* ival */
2913     default:
2914         break;
2915
2916     }
2917
2918     /* Create new token struct.  Note: opvals return early above. */
2919     yylval.tkval = newTOKEN(optype, yylval, PL_thismad);
2920     PL_thismad = 0;
2921     return optype;
2922 }
2923 #endif
2924
2925 STATIC char *
2926 S_tokenize_use(pTHX_ int is_use, char *s) {
2927     dVAR;
2928     if (PL_expect != XSTATE)
2929         yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
2930                     is_use ? "use" : "no"));
2931     s = SKIPSPACE1(s);
2932     if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
2933         s = force_version(s, TRUE);
2934         if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
2935             start_force(PL_curforce);
2936             NEXTVAL_NEXTTOKE.opval = NULL;
2937             force_next(WORD);
2938         }
2939         else if (*s == 'v') {
2940             s = force_word(s,WORD,FALSE,TRUE,FALSE);
2941             s = force_version(s, FALSE);
2942         }
2943     }
2944     else {
2945         s = force_word(s,WORD,FALSE,TRUE,FALSE);
2946         s = force_version(s, FALSE);
2947     }
2948     yylval.ival = is_use;
2949     return s;
2950 }
2951 #ifdef DEBUGGING
2952     static const char* const exp_name[] =
2953         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2954           "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2955         };
2956 #endif
2957
2958 /*
2959   yylex
2960
2961   Works out what to call the token just pulled out of the input
2962   stream.  The yacc parser takes care of taking the ops we return and
2963   stitching them into a tree.
2964
2965   Returns:
2966     PRIVATEREF
2967
2968   Structure:
2969       if read an identifier
2970           if we're in a my declaration
2971               croak if they tried to say my($foo::bar)
2972               build the ops for a my() declaration
2973           if it's an access to a my() variable
2974               are we in a sort block?
2975                   croak if my($a); $a <=> $b
2976               build ops for access to a my() variable
2977           if in a dq string, and they've said @foo and we can't find @foo
2978               croak
2979           build ops for a bareword
2980       if we already built the token before, use it.
2981 */
2982
2983
2984 #ifdef __SC__
2985 #pragma segment Perl_yylex
2986 #endif
2987 int
2988 Perl_yylex(pTHX)
2989 {
2990     dVAR;
2991     register char *s = PL_bufptr;
2992     register char *d;
2993     STRLEN len;
2994     bool bof = FALSE;
2995
2996     DEBUG_T( {
2997         SV* tmp = newSVpvs("");
2998         PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
2999             (IV)CopLINE(PL_curcop),
3000             lex_state_names[PL_lex_state],
3001             exp_name[PL_expect],
3002             pv_display(tmp, s, strlen(s), 0, 60));
3003         SvREFCNT_dec(tmp);
3004     } );
3005     /* check if there's an identifier for us to look at */
3006     if (PL_pending_ident)
3007         return REPORT(S_pending_ident(aTHX));
3008
3009     /* no identifier pending identification */
3010
3011     switch (PL_lex_state) {
3012 #ifdef COMMENTARY
3013     case LEX_NORMAL:            /* Some compilers will produce faster */
3014     case LEX_INTERPNORMAL:      /* code if we comment these out. */
3015         break;
3016 #endif
3017
3018     /* when we've already built the next token, just pull it out of the queue */
3019     case LEX_KNOWNEXT:
3020 #ifdef PERL_MAD
3021         PL_lasttoke--;
3022         yylval = PL_nexttoke[PL_lasttoke].next_val;
3023         if (PL_madskills) {
3024             PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3025             PL_nexttoke[PL_lasttoke].next_mad = 0;
3026             if (PL_thismad && PL_thismad->mad_key == '_') {
3027                 PL_thiswhite = (SV*)PL_thismad->mad_val;
3028                 PL_thismad->mad_val = 0;
3029                 mad_free(PL_thismad);
3030                 PL_thismad = 0;
3031             }
3032         }
3033         if (!PL_lasttoke) {
3034             PL_lex_state = PL_lex_defer;
3035             PL_expect = PL_lex_expect;
3036             PL_lex_defer = LEX_NORMAL;
3037             if (!PL_nexttoke[PL_lasttoke].next_type)
3038                 return yylex();
3039         }
3040 #else
3041         PL_nexttoke--;
3042         yylval = PL_nextval[PL_nexttoke];
3043         if (!PL_nexttoke) {
3044             PL_lex_state = PL_lex_defer;
3045             PL_expect = PL_lex_expect;
3046             PL_lex_defer = LEX_NORMAL;
3047         }
3048 #endif
3049 #ifdef PERL_MAD
3050         /* FIXME - can these be merged?  */
3051         return(PL_nexttoke[PL_lasttoke].next_type);
3052 #else
3053         return REPORT(PL_nexttype[PL_nexttoke]);
3054 #endif
3055
3056     /* interpolated case modifiers like \L \U, including \Q and \E.
3057        when we get here, PL_bufptr is at the \
3058     */
3059     case LEX_INTERPCASEMOD:
3060 #ifdef DEBUGGING
3061         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3062             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3063 #endif
3064         /* handle \E or end of string */
3065         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3066             /* if at a \E */
3067             if (PL_lex_casemods) {
3068                 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3069                 PL_lex_casestack[PL_lex_casemods] = '\0';
3070
3071                 if (PL_bufptr != PL_bufend
3072                     && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3073                     PL_bufptr += 2;
3074                     PL_lex_state = LEX_INTERPCONCAT;
3075 #ifdef PERL_MAD
3076                     if (PL_madskills)
3077                         PL_thistoken = newSVpvn("\\E",2);
3078 #endif
3079                 }
3080                 return REPORT(')');
3081             }
3082 #ifdef PERL_MAD
3083             while (PL_bufptr != PL_bufend &&
3084               PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3085                 if (!PL_thiswhite)
3086                     PL_thiswhite = newSVpvn("",0);
3087                 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3088                 PL_bufptr += 2;
3089             }
3090 #else
3091             if (PL_bufptr != PL_bufend)
3092                 PL_bufptr += 2;
3093 #endif
3094             PL_lex_state = LEX_INTERPCONCAT;
3095             return yylex();
3096         }
3097         else {
3098             DEBUG_T({ PerlIO_printf(Perl_debug_log,
3099               "### Saw case modifier\n"); });
3100             s = PL_bufptr + 1;
3101             if (s[1] == '\\' && s[2] == 'E') {
3102 #ifdef PERL_MAD
3103                 if (!PL_thiswhite)
3104                     PL_thiswhite = newSVpvn("",0);
3105                 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3106 #endif
3107                 PL_bufptr = s + 3;
3108                 PL_lex_state = LEX_INTERPCONCAT;
3109                 return yylex();
3110             }
3111             else {
3112                 I32 tmp;
3113                 if (!PL_madskills) /* when just compiling don't need correct */
3114                     if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3115                         tmp = *s, *s = s[2], s[2] = (char)tmp;  /* misordered... */
3116                 if ((*s == 'L' || *s == 'U') &&
3117                     (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3118                     PL_lex_casestack[--PL_lex_casemods] = '\0';
3119                     return REPORT(')');
3120                 }
3121                 if (PL_lex_casemods > 10)
3122                     Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3123                 PL_lex_casestack[PL_lex_casemods++] = *s;
3124                 PL_lex_casestack[PL_lex_casemods] = '\0';
3125                 PL_lex_state = LEX_INTERPCONCAT;
3126                 start_force(PL_curforce);
3127                 NEXTVAL_NEXTTOKE.ival = 0;
3128                 force_next('(');
3129                 start_force(PL_curforce);
3130                 if (*s == 'l')
3131                     NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3132                 else if (*s == 'u')
3133                     NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3134                 else if (*s == 'L')
3135                     NEXTVAL_NEXTTOKE.ival = OP_LC;
3136                 else if (*s == 'U')
3137                     NEXTVAL_NEXTTOKE.ival = OP_UC;
3138                 else if (*s == 'Q')
3139                     NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3140                 else
3141                     Perl_croak(aTHX_ "panic: yylex");
3142                 if (PL_madskills) {
3143                     SV* const tmpsv = newSVpvn("",0);
3144                     Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
3145                     curmad('_', tmpsv);
3146                 }
3147                 PL_bufptr = s + 1;
3148             }
3149             force_next(FUNC);
3150             if (PL_lex_starts) {
3151                 s = PL_bufptr;
3152                 PL_lex_starts = 0;
3153 #ifdef PERL_MAD
3154                 if (PL_madskills) {
3155                     if (PL_thistoken)
3156                         sv_free(PL_thistoken);
3157                     PL_thistoken = newSVpvn("",0);
3158                 }
3159 #endif
3160                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3161                 if (PL_lex_casemods == 1 && PL_lex_inpat)
3162                     OPERATOR(',');
3163                 else
3164                     Aop(OP_CONCAT);
3165             }
3166             else
3167                 return yylex();
3168         }
3169
3170     case LEX_INTERPPUSH:
3171         return REPORT(sublex_push());
3172
3173     case LEX_INTERPSTART:
3174         if (PL_bufptr == PL_bufend)
3175             return REPORT(sublex_done());
3176         DEBUG_T({ PerlIO_printf(Perl_debug_log,
3177               "### Interpolated variable\n"); });
3178         PL_expect = XTERM;
3179         PL_lex_dojoin = (*PL_bufptr == '@');
3180         PL_lex_state = LEX_INTERPNORMAL;
3181         if (PL_lex_dojoin) {
3182             start_force(PL_curforce);
3183             NEXTVAL_NEXTTOKE.ival = 0;
3184             force_next(',');
3185             start_force(PL_curforce);
3186             force_ident("\"", '$');
3187             start_force(PL_curforce);
3188             NEXTVAL_NEXTTOKE.ival = 0;
3189             force_next('$');
3190             start_force(PL_curforce);
3191             NEXTVAL_NEXTTOKE.ival = 0;
3192             force_next('(');
3193             start_force(PL_curforce);
3194             NEXTVAL_NEXTTOKE.ival = OP_JOIN;    /* emulate join($", ...) */
3195             force_next(FUNC);
3196         }
3197         if (PL_lex_starts++) {
3198             s = PL_bufptr;
3199 #ifdef PERL_MAD
3200             if (PL_madskills) {
3201                 if (PL_thistoken)
3202                     sv_free(PL_thistoken);
3203                 PL_thistoken = newSVpvn("",0);
3204             }
3205 #endif
3206             /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3207             if (!PL_lex_casemods && PL_lex_inpat)
3208                 OPERATOR(',');
3209             else
3210                 Aop(OP_CONCAT);
3211         }
3212         return yylex();
3213
3214     case LEX_INTERPENDMAYBE:
3215         if (intuit_more(PL_bufptr)) {
3216             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
3217             break;
3218         }
3219         /* FALL THROUGH */
3220
3221     case LEX_INTERPEND:
3222         if (PL_lex_dojoin) {
3223             PL_lex_dojoin = FALSE;
3224             PL_lex_state = LEX_INTERPCONCAT;
3225 #ifdef PERL_MAD
3226             if (PL_madskills) {
3227                 if (PL_thistoken)
3228                     sv_free(PL_thistoken);
3229                 PL_thistoken = newSVpvn("",0);
3230             }
3231 #endif
3232             return REPORT(')');
3233         }
3234         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3235             && SvEVALED(PL_lex_repl))
3236         {
3237             if (PL_bufptr != PL_bufend)
3238                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3239             PL_lex_repl = NULL;
3240         }
3241         /* FALLTHROUGH */
3242     case LEX_INTERPCONCAT:
3243 #ifdef DEBUGGING
3244         if (PL_lex_brackets)
3245             Perl_croak(aTHX_ "panic: INTERPCONCAT");
3246 #endif
3247         if (PL_bufptr == PL_bufend)
3248             return REPORT(sublex_done());
3249
3250         if (SvIVX(PL_linestr) == '\'') {
3251             SV *sv = newSVsv(PL_linestr);
3252             if (!PL_lex_inpat)
3253                 sv = tokeq(sv);
3254             else if ( PL_hints & HINT_NEW_RE )
3255                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
3256             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3257             s = PL_bufend;
3258         }
3259         else {
3260             s = scan_const(PL_bufptr);
3261             if (*s == '\\')
3262                 PL_lex_state = LEX_INTERPCASEMOD;
3263             else
3264                 PL_lex_state = LEX_INTERPSTART;
3265         }
3266
3267         if (s != PL_bufptr) {
3268             start_force(PL_curforce);
3269             if (PL_madskills) {
3270                 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3271             }
3272             NEXTVAL_NEXTTOKE = yylval;
3273             PL_expect = XTERM;
3274             force_next(THING);
3275             if (PL_lex_starts++) {
3276 #ifdef PERL_MAD
3277                 if (PL_madskills) {
3278                     if (PL_thistoken)
3279                         sv_free(PL_thistoken);
3280                     PL_thistoken = newSVpvn("",0);
3281                 }
3282 #endif
3283                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3284                 if (!PL_lex_casemods && PL_lex_inpat)
3285                     OPERATOR(',');
3286                 else
3287                     Aop(OP_CONCAT);
3288             }
3289             else {
3290                 PL_bufptr = s;
3291                 return yylex();
3292             }
3293         }
3294
3295         return yylex();
3296     case LEX_FORMLINE:
3297         PL_lex_state = LEX_NORMAL;
3298         s = scan_formline(PL_bufptr);
3299         if (!PL_lex_formbrack)
3300             goto rightbracket;
3301         OPERATOR(';');
3302     }
3303
3304     s = PL_bufptr;
3305     PL_oldoldbufptr = PL_oldbufptr;
3306     PL_oldbufptr = s;
3307
3308   retry:
3309 #ifdef PERL_MAD
3310     if (PL_thistoken) {
3311         sv_free(PL_thistoken);
3312         PL_thistoken = 0;
3313     }
3314     PL_realtokenstart = s - SvPVX(PL_linestr);  /* assume but undo on ws */
3315 #endif
3316     switch (*s) {
3317     default:
3318         if (isIDFIRST_lazy_if(s,UTF))
3319             goto keylookup;
3320         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
3321     case 4:
3322     case 26:
3323         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
3324     case 0:
3325 #ifdef PERL_MAD
3326         if (PL_madskills)
3327             PL_faketokens = 0;
3328 #endif
3329         if (!PL_rsfp) {
3330             PL_last_uni = 0;
3331             PL_last_lop = 0;
3332             if (PL_lex_brackets) {
3333                 yyerror(PL_lex_formbrack
3334                     ? "Format not terminated"
3335                     : "Missing right curly or square bracket");
3336             }
3337             DEBUG_T( { PerlIO_printf(Perl_debug_log,
3338                         "### Tokener got EOF\n");
3339             } );
3340             TOKEN(0);
3341         }
3342         if (s++ < PL_bufend)
3343             goto retry;                 /* ignore stray nulls */
3344         PL_last_uni = 0;
3345         PL_last_lop = 0;
3346         if (!PL_in_eval && !PL_preambled) {
3347             PL_preambled = TRUE;
3348 #ifdef PERL_MAD
3349             if (PL_madskills)
3350                 PL_faketokens = 1;
3351 #endif
3352             sv_setpv(PL_linestr,incl_perldb());
3353             if (SvCUR(PL_linestr))
3354                 sv_catpvs(PL_linestr,";");
3355             if (PL_preambleav){
3356                 while(AvFILLp(PL_preambleav) >= 0) {
3357                     SV *tmpsv = av_shift(PL_preambleav);
3358                     sv_catsv(PL_linestr, tmpsv);
3359                     sv_catpvs(PL_linestr, ";");
3360                     sv_free(tmpsv);
3361                 }
3362                 sv_free((SV*)PL_preambleav);
3363                 PL_preambleav = NULL;
3364             }
3365             if (PL_minus_n || PL_minus_p) {
3366                 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3367                 if (PL_minus_l)
3368                     sv_catpvs(PL_linestr,"chomp;");
3369                 if (PL_minus_a) {
3370                     if (PL_minus_F) {
3371                         if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3372                              || *PL_splitstr == '"')
3373                               && strchr(PL_splitstr + 1, *PL_splitstr))
3374                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3375                         else {
3376                             /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3377                                bytes can be used as quoting characters.  :-) */
3378                             const char *splits = PL_splitstr;
3379                             sv_catpvs(PL_linestr, "our @F=split(q\0");
3380                             do {
3381                                 /* Need to \ \s  */
3382                                 if (*splits == '\\')
3383                                     sv_catpvn(PL_linestr, splits, 1);
3384                                 sv_catpvn(PL_linestr, splits, 1);
3385                             } while (*splits++);
3386                             /* This loop will embed the trailing NUL of
3387                                PL_linestr as the last thing it does before
3388                                terminating.  */
3389                             sv_catpvs(PL_linestr, ");");
3390                         }
3391                     }
3392                     else
3393                         sv_catpvs(PL_linestr,"our @F=split(' ');");
3394                 }
3395             }
3396             if (PL_minus_E)
3397                 sv_catpvs(PL_linestr,"use feature ':5.10';");
3398             sv_catpvs(PL_linestr, "\n");
3399             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3400             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3401             PL_last_lop = PL_last_uni = NULL;
3402             if (PERLDB_LINE && PL_curstash != PL_debstash) {
3403                 SV * const sv = newSV(0);
3404
3405                 sv_upgrade(sv, SVt_PVMG);
3406                 sv_setsv(sv,PL_linestr);
3407                 (void)SvIOK_on(sv);
3408                 SvIV_set(sv, 0);
3409                 av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
3410             }
3411             goto retry;
3412         }
3413         do {
3414             bof = PL_rsfp ? TRUE : FALSE;
3415             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3416               fake_eof:
3417 #ifdef PERL_MAD
3418                 PL_realtokenstart = -1;
3419 #endif
3420                 if (PL_rsfp) {
3421                     if (PL_preprocess && !PL_in_eval)
3422                         (void)PerlProc_pclose(PL_rsfp);
3423                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3424                         PerlIO_clearerr(PL_rsfp);
3425                     else
3426                         (void)PerlIO_close(PL_rsfp);
3427                     PL_rsfp = NULL;
3428                     PL_doextract = FALSE;
3429                 }
3430                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3431 #ifdef PERL_MAD
3432                     if (PL_madskills)
3433                         PL_faketokens = 1;
3434 #endif
3435                     sv_setpv(PL_linestr,PL_minus_p
3436                              ? ";}continue{print;}" : ";}");
3437                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3438                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3439                     PL_last_lop = PL_last_uni = NULL;
3440                     PL_minus_n = PL_minus_p = 0;
3441                     goto retry;
3442                 }
3443                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3444                 PL_last_lop = PL_last_uni = NULL;
3445                 sv_setpvn(PL_linestr,"",0);
3446                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
3447             }
3448             /* If it looks like the start of a BOM or raw UTF-16,
3449              * check if it in fact is. */
3450             else if (bof &&
3451                      (*s == 0 ||
3452                       *(U8*)s == 0xEF ||
3453                       *(U8*)s >= 0xFE ||
3454                       s[1] == 0)) {
3455 #ifdef PERLIO_IS_STDIO
3456 #  ifdef __GNU_LIBRARY__
3457 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3458 #      define FTELL_FOR_PIPE_IS_BROKEN
3459 #    endif
3460 #  else
3461 #    ifdef __GLIBC__
3462 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3463 #        define FTELL_FOR_PIPE_IS_BROKEN
3464 #      endif
3465 #    endif
3466 #  endif
3467 #endif
3468 #ifdef FTELL_FOR_PIPE_IS_BROKEN
3469                 /* This loses the possibility to detect the bof
3470                  * situation on perl -P when the libc5 is being used.
3471                  * Workaround?  Maybe attach some extra state to PL_rsfp?
3472                  */
3473                 if (!PL_preprocess)
3474                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
3475 #else
3476                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3477 #endif
3478                 if (bof) {
3479                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3480                     s = swallow_bom((U8*)s);
3481                 }
3482             }
3483             if (PL_doextract) {
3484                 /* Incest with pod. */
3485 #ifdef PERL_MAD
3486                 if (PL_madskills)
3487                     sv_catsv(PL_thiswhite, PL_linestr);
3488 #endif
3489                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
3490                     sv_setpvn(PL_linestr, "", 0);
3491                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3492                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3493                     PL_last_lop = PL_last_uni = NULL;
3494                     PL_doextract = FALSE;
3495                 }
3496             }
3497             incline(s);
3498         } while (PL_doextract);
3499         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3500         if (PERLDB_LINE && PL_curstash != PL_debstash) {
3501             SV * const sv = newSV(0);
3502
3503             sv_upgrade(sv, SVt_PVMG);
3504             sv_setsv(sv,PL_linestr);
3505             (void)SvIOK_on(sv);
3506             SvIV_set(sv, 0);
3507             av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
3508         }
3509         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3510         PL_last_lop = PL_last_uni = NULL;
3511         if (CopLINE(PL_curcop) == 1) {
3512             while (s < PL_bufend && isSPACE(*s))
3513                 s++;
3514             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3515                 s++;
3516 #ifdef PERL_MAD
3517             if (PL_madskills)
3518                 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3519 #endif
3520             d = NULL;
3521             if (!PL_in_eval) {
3522                 if (*s == '#' && *(s+1) == '!')
3523                     d = s + 2;
3524 #ifdef ALTERNATE_SHEBANG
3525                 else {
3526                     static char const as[] = ALTERNATE_SHEBANG;
3527                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3528                         d = s + (sizeof(as) - 1);
3529                 }
3530 #endif /* ALTERNATE_SHEBANG */
3531             }
3532             if (d) {
3533                 char *ipath;
3534                 char *ipathend;
3535
3536                 while (isSPACE(*d))
3537                     d++;
3538                 ipath = d;
3539                 while (*d && !isSPACE(*d))
3540                     d++;
3541                 ipathend = d;
3542
3543 #ifdef ARG_ZERO_IS_SCRIPT
3544                 if (ipathend > ipath) {
3545                     /*
3546                      * HP-UX (at least) sets argv[0] to the script name,
3547                      * which makes $^X incorrect.  And Digital UNIX and Linux,
3548                      * at least, set argv[0] to the basename of the Perl
3549                      * interpreter. So, having found "#!", we'll set it right.
3550                      */
3551                     SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3552                                                     SVt_PV)); /* $^X */
3553                     assert(SvPOK(x) || SvGMAGICAL(x));
3554                     if (sv_eq(x, CopFILESV(PL_curcop))) {
3555                         sv_setpvn(x, ipath, ipathend - ipath);
3556                         SvSETMAGIC(x);
3557                     }
3558                     else {
3559                         STRLEN blen;
3560                         STRLEN llen;
3561                         const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3562                         const char * const lstart = SvPV_const(x,llen);
3563                         if (llen < blen) {
3564                             bstart += blen - llen;
3565                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3566                                 sv_setpvn(x, ipath, ipathend - ipath);
3567                                 SvSETMAGIC(x);
3568                             }
3569                         }
3570                     }
3571                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
3572                 }
3573 #endif /* ARG_ZERO_IS_SCRIPT */
3574
3575                 /*
3576                  * Look for options.
3577                  */
3578                 d = instr(s,"perl -");
3579                 if (!d) {
3580                     d = instr(s,"perl");
3581 #if defined(DOSISH)
3582                     /* avoid getting into infinite loops when shebang
3583                      * line contains "Perl" rather than "perl" */
3584                     if (!d) {
3585                         for (d = ipathend-4; d >= ipath; --d) {
3586                             if ((*d == 'p' || *d == 'P')
3587                                 && !ibcmp(d, "perl", 4))
3588                             {
3589                                 break;
3590                             }
3591                         }
3592                         if (d < ipath)
3593                             d = NULL;
3594                     }
3595 #endif
3596                 }
3597 #ifdef ALTERNATE_SHEBANG
3598                 /*
3599                  * If the ALTERNATE_SHEBANG on this system starts with a
3600                  * character that can be part of a Perl expression, then if
3601                  * we see it but not "perl", we're probably looking at the
3602                  * start of Perl code, not a request to hand off to some
3603                  * other interpreter.  Similarly, if "perl" is there, but
3604                  * not in the first 'word' of the line, we assume the line
3605                  * contains the start of the Perl program.
3606                  */
3607                 if (d && *s != '#') {
3608                     const char *c = ipath;
3609                     while (*c && !strchr("; \t\r\n\f\v#", *c))
3610                         c++;
3611                     if (c < d)
3612                         d = NULL;       /* "perl" not in first word; ignore */
3613                     else
3614                         *s = '#';       /* Don't try to parse shebang line */
3615                 }
3616 #endif /* ALTERNATE_SHEBANG */
3617 #ifndef MACOS_TRADITIONAL
3618                 if (!d &&
3619                     *s == '#' &&
3620                     ipathend > ipath &&
3621                     !PL_minus_c &&
3622                     !instr(s,"indir") &&
3623                     instr(PL_origargv[0],"perl"))
3624                 {
3625                     dVAR;
3626                     char **newargv;
3627
3628                     *ipathend = '\0';
3629                     s = ipathend + 1;
3630                     while (s < PL_bufend && isSPACE(*s))
3631                         s++;
3632                     if (s < PL_bufend) {
3633                         Newxz(newargv,PL_origargc+3,char*);
3634                         newargv[1] = s;
3635                         while (s < PL_bufend && !isSPACE(*s))
3636                             s++;
3637                         *s = '\0';
3638                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3639                     }
3640                     else
3641                         newargv = PL_origargv;
3642                     newargv[0] = ipath;
3643                     PERL_FPU_PRE_EXEC
3644                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3645                     PERL_FPU_POST_EXEC
3646                     Perl_croak(aTHX_ "Can't exec %s", ipath);
3647                 }
3648 #endif
3649                 if (d) {
3650                     while (*d && !isSPACE(*d)) d++;
3651                     while (SPACE_OR_TAB(*d)) d++;
3652
3653                     if (*d++ == '-') {
3654                         const bool switches_done = PL_doswitches;
3655                         const U32 oldpdb = PL_perldb;
3656                         const bool oldn = PL_minus_n;
3657                         const bool oldp = PL_minus_p;
3658
3659                         do {
3660                             if (*d == 'M' || *d == 'm' || *d == 'C') {
3661                                 const char * const m = d;
3662                                 while (*d && !isSPACE(*d))
3663                                     d++;
3664                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3665                                       (int)(d - m), m);
3666                             }
3667                             d = moreswitches(d);
3668                         } while (d);
3669                         if (PL_doswitches && !switches_done) {
3670                             int argc = PL_origargc;
3671                             char **argv = PL_origargv;
3672                             do {
3673                                 argc--,argv++;
3674                             } while (argc && argv[0][0] == '-' && argv[0][1]);
3675                             init_argv_symbols(argc,argv);
3676                         }
3677                         if ((PERLDB_LINE && !oldpdb) ||
3678                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
3679                               /* if we have already added "LINE: while (<>) {",
3680                                  we must not do it again */
3681                         {
3682                             sv_setpvn(PL_linestr, "", 0);
3683                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3684                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3685                             PL_last_lop = PL_last_uni = NULL;
3686                             PL_preambled = FALSE;
3687                             if (PERLDB_LINE)
3688                                 (void)gv_fetchfile(PL_origfilename);
3689                             goto retry;
3690                         }
3691                     }
3692                 }
3693             }
3694         }
3695         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3696             PL_bufptr = s;
3697             PL_lex_state = LEX_FORMLINE;
3698             return yylex();
3699         }
3700         goto retry;
3701     case '\r':
3702 #ifdef PERL_STRICT_CR
3703         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3704         Perl_croak(aTHX_
3705       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3706 #endif
3707     case ' ': case '\t': case '\f': case 013:
3708 #ifdef MACOS_TRADITIONAL
3709     case '\312':
3710 #endif
3711 #ifdef PERL_MAD
3712         PL_realtokenstart = -1;
3713         s = SKIPSPACE0(s);
3714 #else
3715         s++;
3716 #endif
3717         goto retry;
3718     case '#':
3719     case '\n':
3720 #ifdef PERL_MAD
3721         PL_realtokenstart = -1;
3722         if (PL_madskills)
3723             PL_faketokens = 0;
3724 #endif
3725         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3726             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3727                 /* handle eval qq[#line 1 "foo"\n ...] */
3728                 CopLINE_dec(PL_curcop);
3729                 incline(s);
3730             }
3731             if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
3732                 s = SKIPSPACE0(s);
3733                 if (!PL_in_eval || PL_rsfp)
3734                     incline(s);
3735             }
3736             else {
3737                 d = s;
3738                 while (d < PL_bufend && *d != '\n')
3739                     d++;
3740                 if (d < PL_bufend)
3741                     d++;
3742                 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3743                   Perl_croak(aTHX_ "panic: input overflow");
3744 #ifdef PERL_MAD
3745                 if (PL_madskills)
3746                     PL_thiswhite = newSVpvn(s, d - s);
3747 #endif
3748                 s = d;
3749                 incline(s);
3750             }
3751             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3752                 PL_bufptr = s;
3753                 PL_lex_state = LEX_FORMLINE;
3754                 return yylex();
3755             }
3756         }
3757         else {
3758 #ifdef PERL_MAD
3759             if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
3760                 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
3761                     PL_faketokens = 0;
3762                     s = SKIPSPACE0(s);
3763                     TOKEN(PEG); /* make sure any #! line is accessible */
3764                 }
3765                 s = SKIPSPACE0(s);
3766             }
3767             else {
3768 /*              if (PL_madskills && PL_lex_formbrack) { */
3769                     d = s;
3770                     while (d < PL_bufend && *d != '\n')
3771                         d++;
3772                     if (d < PL_bufend)
3773                         d++;
3774                     else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3775                       Perl_croak(aTHX_ "panic: input overflow");
3776                     if (PL_madskills && CopLINE(PL_curcop) >= 1) {
3777                         if (!PL_thiswhite)
3778                             PL_thiswhite = newSVpvn("",0);
3779                         if (CopLINE(PL_curcop) == 1) {
3780                             sv_setpvn(PL_thiswhite, "", 0);
3781                             PL_faketokens = 0;
3782                         }
3783                         sv_catpvn(PL_thiswhite, s, d - s);
3784                     }
3785                     s = d;
3786 /*              }
3787                 *s = '\0';
3788                 PL_bufend = s; */
3789             }
3790 #else
3791             *s = '\0';
3792             PL_bufend = s;
3793 #endif
3794         }
3795         goto retry;
3796     case '-':
3797         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
3798             I32 ftst = 0;
3799             char tmp;
3800
3801             s++;
3802             PL_bufptr = s;
3803             tmp = *s++;
3804
3805             while (s < PL_bufend && SPACE_OR_TAB(*s))
3806                 s++;
3807
3808             if (strnEQ(s,"=>",2)) {
3809                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
3810                 DEBUG_T( { S_printbuf(aTHX_
3811                         "### Saw unary minus before =>, forcing word %s\n", s);
3812                 } );
3813                 OPERATOR('-');          /* unary minus */
3814             }
3815             PL_last_uni = PL_oldbufptr;
3816             switch (tmp) {
3817             case 'r': ftst = OP_FTEREAD;        break;
3818             case 'w': ftst = OP_FTEWRITE;       break;
3819             case 'x': ftst = OP_FTEEXEC;        break;
3820             case 'o': ftst = OP_FTEOWNED;       break;
3821             case 'R': ftst = OP_FTRREAD;        break;
3822             case 'W': ftst = OP_FTRWRITE;       break;
3823             case 'X': ftst = OP_FTREXEC;        break;
3824             case 'O': ftst = OP_FTROWNED;       break;
3825             case 'e': ftst = OP_FTIS;           break;
3826             case 'z': ftst = OP_FTZERO;         break;
3827             case 's': ftst = OP_FTSIZE;         break;
3828             case 'f': ftst = OP_FTFILE;         break;
3829             case 'd': ftst = OP_FTDIR;          break;
3830             case 'l': ftst = OP_FTLINK;         break;
3831             case 'p': ftst = OP_FTPIPE;         break;
3832             case 'S': ftst = OP_FTSOCK;         break;
3833             case 'u': ftst = OP_FTSUID;         break;
3834             case 'g': ftst = OP_FTSGID;         break;
3835             case 'k': ftst = OP_FTSVTX;         break;
3836             case 'b': ftst = OP_FTBLK;          break;
3837             case 'c': ftst = OP_FTCHR;          break;
3838             case 't': ftst = OP_FTTTY;          break;
3839             case 'T': ftst = OP_FTTEXT;         break;
3840             case 'B': ftst = OP_FTBINARY;       break;
3841             case 'M': case 'A': case 'C':
3842                 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
3843                 switch (tmp) {
3844                 case 'M': ftst = OP_FTMTIME;    break;
3845                 case 'A': ftst = OP_FTATIME;    break;
3846                 case 'C': ftst = OP_FTCTIME;    break;
3847                 default:                        break;
3848                 }
3849                 break;
3850             default:
3851                 break;
3852             }
3853             if (ftst) {
3854                 PL_last_lop_op = (OPCODE)ftst;
3855                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3856                         "### Saw file test %c\n", (int)tmp);
3857                 } );
3858                 FTST(ftst);
3859             }
3860             else {
3861                 /* Assume it was a minus followed by a one-letter named
3862                  * subroutine call (or a -bareword), then. */
3863                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3864                         "### '-%c' looked like a file test but was not\n",
3865                         (int) tmp);
3866                 } );
3867                 s = --PL_bufptr;
3868             }
3869         }
3870         {
3871             const char tmp = *s++;
3872             if (*s == tmp) {
3873                 s++;
3874                 if (PL_expect == XOPERATOR)
3875                     TERM(POSTDEC);
3876                 else
3877                     OPERATOR(PREDEC);
3878             }
3879             else if (*s == '>') {
3880                 s++;
3881                 s = SKIPSPACE1(s);
3882                 if (isIDFIRST_lazy_if(s,UTF)) {
3883                     s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3884                     TOKEN(ARROW);
3885                 }
3886                 else if (*s == '$')
3887                     OPERATOR(ARROW);
3888                 else
3889                     TERM(ARROW);
3890             }
3891             if (PL_expect == XOPERATOR)
3892                 Aop(OP_SUBTRACT);
3893             else {
3894                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3895                     check_uni();
3896                 OPERATOR('-');          /* unary minus */
3897             }
3898         }
3899
3900     case '+':
3901         {
3902             const char tmp = *s++;
3903             if (*s == tmp) {
3904                 s++;
3905                 if (PL_expect == XOPERATOR)
3906                     TERM(POSTINC);
3907                 else
3908                     OPERATOR(PREINC);
3909             }
3910             if (PL_expect == XOPERATOR)
3911                 Aop(OP_ADD);
3912             else {
3913                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3914                     check_uni();
3915                 OPERATOR('+');
3916             }
3917         }
3918
3919     case '*':
3920         if (PL_expect != XOPERATOR) {
3921             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3922             PL_expect = XOPERATOR;
3923             force_ident(PL_tokenbuf, '*');
3924             if (!*PL_tokenbuf)
3925                 PREREF('*');
3926             TERM('*');
3927         }
3928         s++;
3929         if (*s == '*') {
3930             s++;
3931             PWop(OP_POW);
3932         }
3933         Mop(OP_MULTIPLY);
3934
3935     case '%':
3936         if (PL_expect == XOPERATOR) {
3937             ++s;
3938             Mop(OP_MODULO);
3939         }
3940         PL_tokenbuf[0] = '%';
3941         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3942         if (!PL_tokenbuf[1]) {
3943             PREREF('%');
3944         }
3945         PL_pending_ident = '%';
3946         TERM('%');
3947
3948     case '^':
3949         s++;
3950         BOop(OP_BIT_XOR);
3951     case '[':
3952         PL_lex_brackets++;
3953         /* FALL THROUGH */
3954     case '~':
3955         if (s[1] == '~'
3956         && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)
3957         && FEATURE_IS_ENABLED("~~"))
3958         {
3959             s += 2;
3960             Eop(OP_SMARTMATCH);
3961         }
3962     case ',':
3963         {
3964             const char tmp = *s++;
3965             OPERATOR(tmp);
3966         }
3967     case ':':
3968         if (s[1] == ':') {
3969             len = 0;
3970             goto just_a_word_zero_gv;
3971         }
3972         s++;
3973         switch (PL_expect) {
3974             OP *attrs;
3975 #ifdef PERL_MAD
3976             I32 stuffstart;
3977 #endif
3978         case XOPERATOR:
3979             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3980                 break;
3981             PL_bufptr = s;      /* update in case we back off */
3982             goto grabattrs;
3983         case XATTRBLOCK:
3984             PL_expect = XBLOCK;
3985             goto grabattrs;
3986         case XATTRTERM:
3987             PL_expect = XTERMBLOCK;
3988          grabattrs:
3989 #ifdef PERL_MAD
3990             stuffstart = s - SvPVX(PL_linestr) - 1;
3991 #endif
3992             s = PEEKSPACE(s);
3993             attrs = NULL;
3994             while (isIDFIRST_lazy_if(s,UTF)) {
3995                 I32 tmp;
3996                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3997                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3998                     if (tmp < 0) tmp = -tmp;
3999                     switch (tmp) {
4000                     case KEY_or:
4001                     case KEY_and:
4002                     case KEY_err:
4003                     case KEY_for:
4004                     case KEY_unless:
4005                     case KEY_if:
4006                     case KEY_while:
4007                     case KEY_until:
4008                         goto got_attrs;
4009                     default:
4010                         break;
4011                     }
4012                 }
4013                 if (*d == '(') {
4014                     d = scan_str(d,TRUE,TRUE);
4015                     if (!d) {
4016                         /* MUST advance bufptr here to avoid bogus
4017                            "at end of line" context messages from yyerror().
4018                          */
4019                         PL_bufptr = s + len;
4020                         yyerror("Unterminated attribute parameter in attribute list");
4021                         if (attrs)
4022                             op_free(attrs);
4023                         return REPORT(0);       /* EOF indicator */
4024                     }
4025                 }
4026                 if (PL_lex_stuff) {
4027                     SV *sv = newSVpvn(s, len);
4028                     sv_catsv(sv, PL_lex_stuff);
4029                     attrs = append_elem(OP_LIST, attrs,
4030                                         newSVOP(OP_CONST, 0, sv));
4031                     SvREFCNT_dec(PL_lex_stuff);
4032                     PL_lex_stuff = NULL;
4033                 }
4034                 else {
4035                     if (len == 6 && strnEQ(s, "unique", len)) {
4036                         if (PL_in_my == KEY_our) {
4037 #ifdef USE_ITHREADS
4038                             GvUNIQUE_on(cGVOPx_gv(yylval.opval));
4039 #else
4040                             /* skip to avoid loading attributes.pm */
4041 #endif
4042                             deprecate(":unique");
4043                         }
4044                         else
4045                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4046                     }
4047
4048                     /* NOTE: any CV attrs applied here need to be part of
4049                        the CVf_BUILTIN_ATTRS define in cv.h! */
4050                     else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
4051                         CvLVALUE_on(PL_compcv);
4052                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
4053                         CvLOCKED_on(PL_compcv);
4054                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
4055                         CvMETHOD_on(PL_compcv);
4056                     else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
4057                         CvASSERTION_on(PL_compcv);
4058                     /* After we've set the flags, it could be argued that
4059                        we don't need to do the attributes.pm-based setting
4060                        process, and shouldn't bother appending recognized
4061                        flags.  To experiment with that, uncomment the
4062                        following "else".  (Note that's already been
4063                        uncommented.  That keeps the above-applied built-in
4064                        attributes from being intercepted (and possibly
4065                        rejected) by a package's attribute routines, but is
4066                        justified by the performance win for the common case
4067                        of applying only built-in attributes.) */
4068                     else
4069                         attrs = append_elem(OP_LIST, attrs,
4070                                             newSVOP(OP_CONST, 0,
4071                                                     newSVpvn(s, len)));
4072                 }
4073                 s = PEEKSPACE(d);
4074                 if (*s == ':' && s[1] != ':')
4075                     s = PEEKSPACE(s+1);
4076                 else if (s == d)
4077                     break;      /* require real whitespace or :'s */
4078                 /* XXX losing whitespace on sequential attributes here */
4079             }
4080             {
4081                 const char tmp
4082                     = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4083                 if (*s != ';' && *s != '}' && *s != tmp
4084                     && (tmp != '=' || *s != ')')) {
4085                     const char q = ((*s == '\'') ? '"' : '\'');
4086                     /* If here for an expression, and parsed no attrs, back
4087                        off. */
4088                     if (tmp == '=' && !attrs) {
4089                         s = PL_bufptr;
4090                         break;
4091                     }
4092                     /* MUST advance bufptr here to avoid bogus "at end of line"
4093                        context messages from yyerror().
4094                     */
4095                     PL_bufptr = s;
4096                     yyerror( *s
4097                              ? Perl_form(aTHX_ "Invalid separator character "
4098                                          "%c%c%c in attribute list", q, *s, q)
4099                              : "Unterminated attribute list" );
4100                     if (attrs)
4101                         op_free(attrs);
4102                     OPERATOR(':');
4103                 }
4104             }
4105         got_attrs:
4106             if (attrs) {
4107                 start_force(PL_curforce);
4108                 NEXTVAL_NEXTTOKE.opval = attrs;
4109                 CURMAD('_', PL_nextwhite);
4110                 force_next(THING);
4111             }
4112 #ifdef PERL_MAD
4113             if (PL_madskills) {
4114                 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4115                                      (s - SvPVX(PL_linestr)) - stuffstart);
4116             }
4117 #endif
4118             TOKEN(COLONATTR);
4119         }
4120         OPERATOR(':');
4121     case '(':
4122         s++;
4123         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4124             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
4125         else
4126             PL_expect = XTERM;
4127         s = SKIPSPACE1(s);
4128         TOKEN('(');
4129     case ';':
4130         CLINE;
4131         {
4132             const char tmp = *s++;
4133             OPERATOR(tmp);
4134         }
4135     case ')':
4136         {
4137             const char tmp = *s++;
4138             s = SKIPSPACE1(s);
4139             if (*s == '{')
4140                 PREBLOCK(tmp);
4141             TERM(tmp);
4142         }
4143     case ']':
4144         s++;
4145         if (PL_lex_brackets <= 0)
4146             yyerror("Unmatched right square bracket");
4147         else
4148             --PL_lex_brackets;
4149         if (PL_lex_state == LEX_INTERPNORMAL) {
4150             if (PL_lex_brackets == 0) {
4151                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
4152                     PL_lex_state = LEX_INTERPEND;
4153             }
4154         }
4155         TERM(']');
4156     case '{':
4157       leftbracket:
4158         s++;
4159         if (PL_lex_brackets > 100) {
4160             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4161         }
4162         switch (PL_expect) {
4163         case XTERM:
4164             if (PL_lex_formbrack) {
4165                 s--;
4166                 PRETERMBLOCK(DO);
4167             }
4168             if (PL_oldoldbufptr == PL_last_lop)
4169                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4170             else
4171                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4172             OPERATOR(HASHBRACK);
4173         case XOPERATOR:
4174             while (s < PL_bufend && SPACE_OR_TAB(*s))
4175                 s++;
4176             d = s;
4177             PL_tokenbuf[0] = '\0';
4178             if (d < PL_bufend && *d == '-') {
4179                 PL_tokenbuf[0] = '-';
4180                 d++;
4181                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4182                     d++;
4183             }
4184             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4185                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4186                               FALSE, &len);
4187                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4188                     d++;
4189                 if (*d == '}') {
4190                     const char minus = (PL_tokenbuf[0] == '-');
4191                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4192                     if (minus)
4193                         force_next('-');
4194                 }
4195             }
4196             /* FALL THROUGH */
4197         case XATTRBLOCK:
4198         case XBLOCK:
4199             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4200             PL_expect = XSTATE;
4201             break;
4202         case XATTRTERM:
4203         case XTERMBLOCK:
4204             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4205             PL_expect = XSTATE;
4206             break;
4207         default: {
4208                 const char *t;
4209                 if (PL_oldoldbufptr == PL_last_lop)
4210                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4211                 else
4212                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4213                 s = SKIPSPACE1(s);
4214                 if (*s == '}') {
4215                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4216                         PL_expect = XTERM;
4217                         /* This hack is to get the ${} in the message. */
4218                         PL_bufptr = s+1;
4219                         yyerror("syntax error");
4220                         break;
4221                     }
4222                     OPERATOR(HASHBRACK);
4223                 }
4224                 /* This hack serves to disambiguate a pair of curlies
4225                  * as being a block or an anon hash.  Normally, expectation
4226                  * determines that, but in cases where we're not in a
4227                  * position to expect anything in particular (like inside
4228                  * eval"") we have to resolve the ambiguity.  This code
4229                  * covers the case where the first term in the curlies is a
4230                  * quoted string.  Most other cases need to be explicitly
4231                  * disambiguated by prepending a "+" before the opening
4232                  * curly in order to force resolution as an anon hash.
4233                  *
4234                  * XXX should probably propagate the outer expectation
4235                  * into eval"" to rely less on this hack, but that could
4236                  * potentially break current behavior of eval"".
4237                  * GSAR 97-07-21
4238                  */
4239                 t = s;
4240                 if (*s == '\'' || *s == '"' || *s == '`') {
4241                     /* common case: get past first string, handling escapes */
4242                     for (t++; t < PL_bufend && *t != *s;)
4243                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
4244                             t++;
4245                     t++;
4246                 }
4247                 else if (*s == 'q') {
4248                     if (++t < PL_bufend
4249                         && (!isALNUM(*t)
4250                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4251                                 && !isALNUM(*t))))
4252                     {
4253                         /* skip q//-like construct */
4254                         const char *tmps;
4255                         char open, close, term;
4256                         I32 brackets = 1;
4257
4258                         while (t < PL_bufend && isSPACE(*t))
4259                             t++;
4260                         /* check for q => */
4261                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4262                             OPERATOR(HASHBRACK);
4263                         }
4264                         term = *t;
4265                         open = term;
4266                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4267                             term = tmps[5];
4268                         close = term;
4269                         if (open == close)
4270                             for (t++; t < PL_bufend; t++) {
4271                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4272                                     t++;
4273                                 else if (*t == open)
4274                                     break;
4275                             }
4276                         else {
4277                             for (t++; t < PL_bufend; t++) {
4278                                 if (*t == '\\' && t+1 < PL_bufend)
4279                                     t++;
4280                                 else if (*t == close && --brackets <= 0)
4281                                     break;
4282                                 else if (*t == open)
4283                                     brackets++;
4284                             }
4285                         }
4286                         t++;
4287                     }
4288                     else
4289                         /* skip plain q word */
4290                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4291                              t += UTF8SKIP(t);
4292                 }
4293                 else if (isALNUM_lazy_if(t,UTF)) {
4294                     t += UTF8SKIP(t);
4295                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4296                          t += UTF8SKIP(t);
4297                 }
4298                 while (t < PL_bufend && isSPACE(*t))
4299                     t++;
4300                 /* if comma follows first term, call it an anon hash */
4301                 /* XXX it could be a comma expression with loop modifiers */
4302                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4303                                    || (*t == '=' && t[1] == '>')))
4304                     OPERATOR(HASHBRACK);
4305                 if (PL_expect == XREF)
4306                     PL_expect = XTERM;
4307                 else {
4308                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4309                     PL_expect = XSTATE;
4310                 }
4311             }
4312             break;
4313         }
4314         yylval.ival = CopLINE(PL_curcop);
4315         if (isSPACE(*s) || *s == '#')
4316             PL_copline = NOLINE;   /* invalidate current command line number */
4317         TOKEN('{');
4318     case '}':
4319       rightbracket:
4320         s++;
4321         if (PL_lex_brackets <= 0)
4322             yyerror("Unmatched right curly bracket");
4323         else
4324             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4325         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4326             PL_lex_formbrack = 0;
4327         if (PL_lex_state == LEX_INTERPNORMAL) {
4328             if (PL_lex_brackets == 0) {
4329                 if (PL_expect & XFAKEBRACK) {
4330                     PL_expect &= XENUMMASK;
4331                     PL_lex_state = LEX_INTERPEND;
4332                     PL_bufptr = s;
4333 #if 0
4334                     if (PL_madskills) {
4335                         if (!PL_thiswhite)
4336                             PL_thiswhite = newSVpvn("",0);
4337                         sv_catpvn(PL_thiswhite,"}",1);
4338                     }
4339 #endif
4340                     return yylex();     /* ignore fake brackets */
4341                 }
4342                 if (*s == '-' && s[1] == '>')
4343                     PL_lex_state = LEX_INTERPENDMAYBE;
4344                 else if (*s != '[' && *s != '{')
4345                     PL_lex_state = LEX_INTERPEND;
4346             }
4347         }
4348         if (PL_expect & XFAKEBRACK) {
4349             PL_expect &= XENUMMASK;
4350             PL_bufptr = s;
4351             return yylex();             /* ignore fake brackets */
4352         }
4353         start_force(PL_curforce);
4354         if (PL_madskills) {
4355             curmad('X', newSVpvn(s-1,1));
4356             CURMAD('_', PL_thiswhite);
4357         }
4358         force_next('}');
4359 #ifdef PERL_MAD
4360         if (!PL_thistoken)
4361             PL_thistoken = newSVpvn("",0);
4362 #endif
4363         TOKEN(';');
4364     case '&':
4365         s++;
4366         if (*s++ == '&')
4367             AOPERATOR(ANDAND);
4368         s--;
4369         if (PL_expect == XOPERATOR) {
4370             if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4371                 && isIDFIRST_lazy_if(s,UTF))
4372             {
4373                 CopLINE_dec(PL_curcop);
4374                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4375                 CopLINE_inc(PL_curcop);
4376             }
4377             BAop(OP_BIT_AND);
4378         }
4379
4380         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4381         if (*PL_tokenbuf) {
4382             PL_expect = XOPERATOR;
4383             force_ident(PL_tokenbuf, '&');
4384         }
4385         else
4386             PREREF('&');
4387         yylval.ival = (OPpENTERSUB_AMPER<<8);
4388         TERM('&');
4389
4390     case '|':
4391         s++;
4392         if (*s++ == '|')
4393             AOPERATOR(OROR);
4394         s--;
4395         BOop(OP_BIT_OR);
4396     case '=':
4397         s++;
4398         {
4399             const char tmp = *s++;
4400             if (tmp == '=')
4401                 Eop(OP_EQ);
4402             if (tmp == '>')
4403                 OPERATOR(',');
4404             if (tmp == '~')
4405                 PMop(OP_MATCH);
4406             if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4407                 && strchr("+-*/%.^&|<",tmp))
4408                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4409                             "Reversed %c= operator",(int)tmp);
4410             s--;
4411             if (PL_expect == XSTATE && isALPHA(tmp) &&
4412                 (s == PL_linestart+1 || s[-2] == '\n') )
4413                 {
4414                     if (PL_in_eval && !PL_rsfp) {
4415                         d = PL_bufend;
4416                         while (s < d) {
4417                             if (*s++ == '\n') {
4418                                 incline(s);
4419                                 if (strnEQ(s,"=cut",4)) {
4420                                     s = strchr(s,'\n');
4421                                     if (s)
4422                                         s++;
4423                                     else
4424                                         s = d;
4425                                     incline(s);
4426                                     goto retry;
4427                                 }
4428                             }
4429                         }
4430                         goto retry;
4431                     }
4432 #ifdef PERL_MAD
4433                     if (PL_madskills) {
4434                         if (!PL_thiswhite)
4435                             PL_thiswhite = newSVpvn("",0);
4436                         sv_catpvn(PL_thiswhite, PL_linestart,
4437                                   PL_bufend - PL_linestart);
4438                     }
4439 #endif
4440                     s = PL_bufend;
4441                     PL_doextract = TRUE;
4442                     goto retry;
4443                 }
4444         }
4445         if (PL_lex_brackets < PL_lex_formbrack) {
4446             const char *t;
4447 #ifdef PERL_STRICT_CR
4448             for (t = s; SPACE_OR_TAB(*t); t++) ;
4449 #else
4450             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
4451 #endif
4452             if (*t == '\n' || *t == '#') {
4453                 s--;
4454                 PL_expect = XBLOCK;
4455                 goto leftbracket;
4456             }
4457         }
4458         yylval.ival = 0;
4459         OPERATOR(ASSIGNOP);
4460     case '!':
4461         s++;
4462         {
4463             const char tmp = *s++;
4464             if (tmp == '=') {
4465                 /* was this !=~ where !~ was meant?
4466                  * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4467
4468                 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4469                     const char *t = s+1;
4470
4471                     while (t < PL_bufend && isSPACE(*t))
4472                         ++t;
4473
4474                     if (*t == '/' || *t == '?' ||
4475                         ((*t == 'm' || *t == 's' || *t == 'y')
4476                          && !isALNUM(t[1])) ||
4477                         (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4478                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4479                                     "!=~ should be !~");
4480                 }
4481                 Eop(OP_NE);
4482             }
4483             if (tmp == '~')
4484                 PMop(OP_NOT);
4485         }
4486         s--;
4487         OPERATOR('!');
4488     case '<':
4489         if (PL_expect != XOPERATOR) {
4490             if (s[1] != '<' && !strchr(s,'>'))
4491                 check_uni();
4492             if (s[1] == '<')
4493                 s = scan_heredoc(s);
4494             else
4495                 s = scan_inputsymbol(s);
4496             TERM(sublex_start());
4497         }
4498         s++;
4499         {
4500             char tmp = *s++;
4501             if (tmp == '<')
4502                 SHop(OP_LEFT_SHIFT);
4503             if (tmp == '=') {
4504                 tmp = *s++;
4505                 if (tmp == '>')
4506                     Eop(OP_NCMP);
4507                 s--;
4508                 Rop(OP_LE);
4509             }
4510         }
4511         s--;
4512         Rop(OP_LT);
4513     case '>':
4514         s++;
4515         {
4516             const char tmp = *s++;
4517             if (tmp == '>')
4518                 SHop(OP_RIGHT_SHIFT);
4519             else if (tmp == '=')
4520                 Rop(OP_GE);
4521         }
4522         s--;
4523         Rop(OP_GT);
4524
4525     case '$':
4526         CLINE;
4527
4528         if (PL_expect == XOPERATOR) {
4529             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4530                 PL_expect = XTERM;
4531                 deprecate_old(commaless_variable_list);
4532                 return REPORT(','); /* grandfather non-comma-format format */
4533             }
4534         }
4535
4536         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4537             PL_tokenbuf[0] = '@';
4538             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4539                            sizeof PL_tokenbuf - 1, FALSE);
4540             if (PL_expect == XOPERATOR)
4541                 no_op("Array length", s);
4542             if (!PL_tokenbuf[1])
4543                 PREREF(DOLSHARP);
4544             PL_expect = XOPERATOR;
4545             PL_pending_ident = '#';
4546             TOKEN(DOLSHARP);
4547         }
4548
4549         PL_tokenbuf[0] = '$';
4550         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4551                        sizeof PL_tokenbuf - 1, FALSE);
4552         if (PL_expect == XOPERATOR)
4553             no_op("Scalar", s);
4554         if (!PL_tokenbuf[1]) {
4555             if (s == PL_bufend)
4556                 yyerror("Final $ should be \\$ or $name");
4557             PREREF('$');
4558         }
4559
4560         /* This kludge not intended to be bulletproof. */
4561         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4562             yylval.opval = newSVOP(OP_CONST, 0,
4563                                    newSViv(CopARYBASE_get(&PL_compiling)));
4564             yylval.opval->op_private = OPpCONST_ARYBASE;
4565             TERM(THING);
4566         }
4567
4568         d = s;
4569         {
4570             const char tmp = *s;
4571             if (PL_lex_state == LEX_NORMAL)
4572                 s = SKIPSPACE1(s);
4573
4574             if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4575                 && intuit_more(s)) {
4576                 if (*s == '[') {
4577                     PL_tokenbuf[0] = '@';
4578                     if (ckWARN(WARN_SYNTAX)) {
4579                         char *t;
4580                         for(t = s + 1;
4581                             isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
4582                             t++) ;
4583                         if (*t++ == ',') {
4584                             PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4585                             while (t < PL_bufend && *t != ']')
4586                                 t++;
4587                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4588                                         "Multidimensional syntax %.*s not supported",
4589                                     (int)((t - PL_bufptr) + 1), PL_bufptr);
4590                         }
4591                     }
4592                 }
4593                 else if (*s == '{') {
4594                     char *t;
4595                     PL_tokenbuf[0] = '%';
4596                     if (strEQ(PL_tokenbuf+1, "SIG")  && ckWARN(WARN_SYNTAX)
4597                         && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4598                         {
4599                             char tmpbuf[sizeof PL_tokenbuf];
4600                             for (t++; isSPACE(*t); t++) ;
4601                             if (isIDFIRST_lazy_if(t,UTF)) {
4602                                 STRLEN dummylen;
4603                                 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4604                                               &dummylen);
4605                                 for (; isSPACE(*t); t++) ;
4606                                 if (*t == ';' && get_cv(tmpbuf, FALSE))
4607                                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4608                                                 "You need to quote \"%s\"",
4609                                                 tmpbuf);
4610                             }
4611                         }
4612                 }
4613             }
4614
4615             PL_expect = XOPERATOR;
4616             if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4617                 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4618                 if (!islop || PL_last_lop_op == OP_GREPSTART)
4619                     PL_expect = XOPERATOR;
4620                 else if (strchr("$@\"'`q", *s))
4621                     PL_expect = XTERM;          /* e.g. print $fh "foo" */
4622                 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4623                     PL_expect = XTERM;          /* e.g. print $fh &sub */
4624                 else if (isIDFIRST_lazy_if(s,UTF)) {
4625                     char tmpbuf[sizeof PL_tokenbuf];
4626                     int t2;
4627                     scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4628                     if ((t2 = keyword(tmpbuf, len))) {
4629                         /* binary operators exclude handle interpretations */
4630                         switch (t2) {
4631                         case -KEY_x:
4632                         case -KEY_eq:
4633                         case -KEY_ne:
4634                         case -KEY_gt:
4635                         case -KEY_lt:
4636                         case -KEY_ge:
4637                         case -KEY_le:
4638                         case -KEY_cmp:
4639                             break;
4640                         default:
4641                             PL_expect = XTERM;  /* e.g. print $fh length() */
4642                             break;
4643                         }
4644                     }
4645                     else {
4646                         PL_expect = XTERM;      /* e.g. print $fh subr() */
4647                     }
4648                 }
4649                 else if (isDIGIT(*s))
4650                     PL_expect = XTERM;          /* e.g. print $fh 3 */
4651                 else if (*s == '.' && isDIGIT(s[1]))
4652                     PL_expect = XTERM;          /* e.g. print $fh .3 */
4653                 else if ((*s == '?' || *s == '-' || *s == '+')
4654                          && !isSPACE(s[1]) && s[1] != '=')
4655                     PL_expect = XTERM;          /* e.g. print $fh -1 */
4656                 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
4657                          && s[1] != '/')
4658                     PL_expect = XTERM;          /* e.g. print $fh /.../
4659                                                    XXX except DORDOR operator
4660                                                 */
4661                 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
4662                          && s[2] != '=')
4663                     PL_expect = XTERM;          /* print $fh <<"EOF" */
4664             }
4665         }
4666         PL_pending_ident = '$';
4667         TOKEN('$');
4668
4669     case '@':
4670         if (PL_expect == XOPERATOR)
4671             no_op("Array", s);
4672         PL_tokenbuf[0] = '@';
4673         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
4674         if (!PL_tokenbuf[1]) {
4675             PREREF('@');
4676         }
4677         if (PL_lex_state == LEX_NORMAL)
4678             s = SKIPSPACE1(s);
4679         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
4680             if (*s == '{')
4681                 PL_tokenbuf[0] = '%';
4682
4683             /* Warn about @ where they meant $. */
4684             if (*s == '[' || *s == '{') {
4685                 if (ckWARN(WARN_SYNTAX)) {
4686                     const char *t = s + 1;
4687                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
4688                         t++;
4689                     if (*t == '}' || *t == ']') {
4690                         t++;
4691                         PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4692                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4693                             "Scalar value %.*s better written as $%.*s",
4694                             (int)(t-PL_bufptr), PL_bufptr,
4695                             (int)(t-PL_bufptr-1), PL_bufptr+1);
4696                     }
4697                 }
4698             }
4699         }
4700         PL_pending_ident = '@';
4701         TERM('@');
4702
4703      case '/':                  /* may be division, defined-or, or pattern */
4704         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
4705             s += 2;
4706             AOPERATOR(DORDOR);
4707         }
4708      case '?':                  /* may either be conditional or pattern */
4709          if(PL_expect == XOPERATOR) {
4710              char tmp = *s++;
4711              if(tmp == '?') {
4712                   OPERATOR('?');
4713              }
4714              else {
4715                  tmp = *s++;
4716                  if(tmp == '/') {
4717                      /* A // operator. */
4718                     AOPERATOR(DORDOR);
4719                  }
4720                  else {
4721                      s--;
4722                      Mop(OP_DIVIDE);
4723                  }
4724              }
4725          }
4726          else {
4727              /* Disable warning on "study /blah/" */
4728              if (PL_oldoldbufptr == PL_last_uni
4729               && (*PL_last_uni != 's' || s - PL_last_uni < 5
4730                   || memNE(PL_last_uni, "study", 5)
4731                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
4732               ))
4733                  check_uni();
4734              s = scan_pat(s,OP_MATCH);
4735              TERM(sublex_start());
4736          }
4737
4738     case '.':
4739         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
4740 #ifdef PERL_STRICT_CR
4741             && s[1] == '\n'
4742 #else
4743             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
4744 #endif
4745             && (s == PL_linestart || s[-1] == '\n') )
4746         {
4747             PL_lex_formbrack = 0;
4748             PL_expect = XSTATE;
4749             goto rightbracket;
4750         }
4751         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
4752             char tmp = *s++;
4753             if (*s == tmp) {
4754                 s++;
4755                 if (*s == tmp) {
4756                     s++;
4757                     yylval.ival = OPf_SPECIAL;
4758                 }
4759                 else
4760                     yylval.ival = 0;
4761                 OPERATOR(DOTDOT);
4762             }
4763             if (PL_expect != XOPERATOR)
4764                 check_uni();
4765             Aop(OP_CONCAT);
4766         }
4767         /* FALL THROUGH */
4768     case '0': case '1': case '2': case '3': case '4':
4769     case '5': case '6': case '7': case '8': case '9':
4770         s = scan_num(s, &yylval);
4771         DEBUG_T( { S_printbuf(aTHX_ "### Saw number in %s\n", s); } );
4772         if (PL_expect == XOPERATOR)
4773             no_op("Number",s);
4774         TERM(THING);
4775
4776     case '\'':
4777         s = scan_str(s,!!PL_madskills,FALSE);
4778         DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
4779         if (PL_expect == XOPERATOR) {
4780             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4781                 PL_expect = XTERM;
4782                 deprecate_old(commaless_variable_list);
4783                 return REPORT(','); /* grandfather non-comma-format format */
4784             }
4785             else
4786                 no_op("String",s);
4787         }
4788         if (!s)
4789             missingterm(NULL);
4790         yylval.ival = OP_CONST;
4791         TERM(sublex_start());
4792
4793     case '"':
4794         s = scan_str(s,!!PL_madskills,FALSE);
4795         DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
4796         if (PL_expect == XOPERATOR) {
4797             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4798                 PL_expect = XTERM;
4799                 deprecate_old(commaless_variable_list);
4800                 return REPORT(','); /* grandfather non-comma-format format */
4801             }
4802             else
4803                 no_op("String",s);
4804         }
4805         if (!s)
4806             missingterm(NULL);
4807         yylval.ival = OP_CONST;
4808         /* FIXME. I think that this can be const if char *d is replaced by
4809            more localised variables.  */
4810         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
4811             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
4812                 yylval.ival = OP_STRINGIFY;
4813                 break;
4814             }
4815         }
4816         TERM(sublex_start());
4817
4818     case '`':
4819         s = scan_str(s,!!PL_madskills,FALSE);
4820         DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } );
4821         if (PL_expect == XOPERATOR)
4822             no_op("Backticks",s);
4823         if (!s)
4824             missingterm(NULL);
4825         yylval.ival = OP_BACKTICK;
4826         set_csh();
4827         TERM(sublex_start());
4828
4829     case '\\':
4830         s++;
4831         if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
4832             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
4833                         *s, *s);
4834         if (PL_expect == XOPERATOR)
4835             no_op("Backslash",s);
4836         OPERATOR(REFGEN);
4837
4838     case 'v':
4839         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
4840             char *start = s + 2;
4841             while (isDIGIT(*start) || *start == '_')
4842                 start++;
4843             if (*start == '.' && isDIGIT(start[1])) {
4844                 s = scan_num(s, &yylval);
4845                 TERM(THING);
4846             }
4847             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
4848             else if (!isALPHA(*start) && (PL_expect == XTERM
4849                         || PL_expect == XREF || PL_expect == XSTATE
4850                         || PL_expect == XTERMORDORDOR)) {
4851                 /* XXX Use gv_fetchpvn rather than stomping on a const string */
4852                 const char c = *start;
4853                 GV *gv;
4854                 *start = '\0';
4855                 gv = gv_fetchpv(s, 0, SVt_PVCV);
4856                 *start = c;
4857                 if (!gv) {
4858                     s = scan_num(s, &yylval);
4859                     TERM(THING);
4860                 }
4861             }
4862         }
4863         goto keylookup;
4864     case 'x':
4865         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
4866             s++;
4867             Mop(OP_REPEAT);
4868         }
4869         goto keylookup;
4870
4871     case '_':
4872     case 'a': case 'A':
4873     case 'b': case 'B':
4874     case 'c': case 'C':
4875     case 'd': case 'D':
4876     case 'e': case 'E':
4877     case 'f': case 'F':
4878     case 'g': case 'G':
4879     case 'h': case 'H':
4880     case 'i': case 'I':
4881     case 'j': case 'J':
4882     case 'k': case 'K':
4883     case 'l': case 'L':
4884     case 'm': case 'M':
4885     case 'n': case 'N':
4886     case 'o': case 'O':
4887     case 'p': case 'P':
4888     case 'q': case 'Q':
4889     case 'r': case 'R':
4890     case 's': case 'S':
4891     case 't': case 'T':
4892     case 'u': case 'U':
4893               case 'V':
4894     case 'w': case 'W':
4895               case 'X':
4896     case 'y': case 'Y':
4897     case 'z': case 'Z':
4898
4899       keylookup: {
4900         I32 tmp;
4901         I32 orig_keyword = 0;
4902         GV *gv = NULL;
4903         GV **gvp = NULL;
4904
4905         PL_bufptr = s;
4906         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4907
4908         /* Some keywords can be followed by any delimiter, including ':' */
4909         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
4910                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
4911                              (PL_tokenbuf[0] == 'q' &&
4912                               strchr("qwxr", PL_tokenbuf[1])))));
4913
4914         /* x::* is just a word, unless x is "CORE" */
4915         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4916             goto just_a_word;
4917
4918         d = s;
4919         while (d < PL_bufend && isSPACE(*d))
4920                 d++;    /* no comments skipped here, or s### is misparsed */
4921
4922         /* Is this a label? */
4923         if (!tmp && PL_expect == XSTATE
4924               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4925             s = d + 1;
4926             yylval.pval = savepv(PL_tokenbuf);
4927             CLINE;
4928             TOKEN(LABEL);
4929         }
4930
4931         /* Check for keywords */
4932         tmp = keyword(PL_tokenbuf, len);
4933
4934         /* Is this a word before a => operator? */
4935         if (*d == '=' && d[1] == '>') {
4936             CLINE;
4937             yylval.opval
4938                 = (OP*)newSVOP(OP_CONST, 0,
4939                                S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
4940             yylval.opval->op_private = OPpCONST_BARE;
4941             TERM(WORD);
4942         }
4943
4944         if (tmp < 0) {                  /* second-class keyword? */
4945             GV *ogv = NULL;     /* override (winner) */
4946             GV *hgv = NULL;     /* hidden (loser) */
4947             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4948                 CV *cv;
4949                 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
4950                     (cv = GvCVu(gv)))
4951                 {
4952                     if (GvIMPORTED_CV(gv))
4953                         ogv = gv;
4954                     else if (! CvMETHOD(cv))
4955                         hgv = gv;
4956                 }
4957                 if (!ogv &&
4958                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4959                     (gv = *gvp) != (GV*)&PL_sv_undef &&
4960                     GvCVu(gv) && GvIMPORTED_CV(gv))
4961                 {
4962                     ogv = gv;
4963                 }
4964             }
4965             if (ogv) {
4966                 orig_keyword = tmp;
4967                 tmp = 0;                /* overridden by import or by GLOBAL */
4968             }
4969             else if (gv && !gvp
4970                      && -tmp==KEY_lock  /* XXX generalizable kludge */
4971                      && GvCVu(gv)
4972                      && !hv_fetchs(GvHVn(PL_incgv), "Thread.pm", FALSE))
4973             {
4974                 tmp = 0;                /* any sub overrides "weak" keyword */
4975             }
4976             else {                      /* no override */
4977                 tmp = -tmp;
4978                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4979                     Perl_warner(aTHX_ packWARN(WARN_MISC),
4980                             "dump() better written as CORE::dump()");
4981                 }
4982                 gv = NULL;
4983                 gvp = 0;
4984                 if (hgv && tmp != KEY_x && tmp != KEY_CORE
4985                         && ckWARN(WARN_AMBIGUOUS))      /* never ambiguous */
4986                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4987                         "Ambiguous call resolved as CORE::%s(), %s",
4988                          GvENAME(hgv), "qualify as such or use &");
4989             }
4990         }
4991
4992       reserved_word:
4993         switch (tmp) {
4994
4995         default:                        /* not a keyword */
4996             /* Trade off - by using this evil construction we can pull the
4997                variable gv into the block labelled keylookup. If not, then
4998                we have to give it function scope so that the goto from the
4999                earlier ':' case doesn't bypass the initialisation.  */
5000             if (0) {
5001             just_a_word_zero_gv:
5002                 gv = NULL;
5003                 gvp = NULL;
5004                 orig_keyword = 0;
5005             }
5006           just_a_word: {
5007                 SV *sv;
5008                 int pkgname = 0;
5009                 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5010                 CV *cv;
5011 #ifdef PERL_MAD
5012                 SV *nextPL_nextwhite = 0;
5013 #endif
5014
5015
5016                 /* Get the rest if it looks like a package qualifier */
5017
5018                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5019                     STRLEN morelen;
5020                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5021                                   TRUE, &morelen);
5022                     if (!morelen)
5023                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5024                                 *s == '\'' ? "'" : "::");
5025                     len += morelen;
5026                     pkgname = 1;
5027                 }
5028
5029                 if (PL_expect == XOPERATOR) {
5030                     if (PL_bufptr == PL_linestart) {
5031                         CopLINE_dec(PL_curcop);
5032                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
5033                         CopLINE_inc(PL_curcop);
5034                     }
5035                     else
5036                         no_op("Bareword",s);
5037                 }
5038
5039                 /* Look for a subroutine with this name in current package,
5040                    unless name is "Foo::", in which case Foo is a bearword
5041                    (and a package name). */
5042
5043                 if (len > 2 && !PL_madskills &&
5044                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5045                 {
5046                     if (ckWARN(WARN_BAREWORD)
5047                         && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5048                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5049                             "Bareword \"%s\" refers to nonexistent package",
5050                              PL_tokenbuf);
5051                     len -= 2;
5052                     PL_tokenbuf[len] = '\0';
5053                     gv = NULL;
5054                     gvp = 0;
5055                 }
5056                 else {
5057                     if (!gv) {
5058                         /* Mustn't actually add anything to a symbol table.
5059                            But also don't want to "initialise" any placeholder
5060                            constants that might already be there into full
5061                            blown PVGVs with attached PVCV.  */
5062                         gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5063                                                GV_NOADD_NOINIT, SVt_PVCV);
5064                     }
5065                     len = 0;
5066                 }
5067
5068                 /* if we saw a global override before, get the right name */
5069
5070                 if (gvp) {
5071                     sv = newSVpvs("CORE::GLOBAL::");
5072                     sv_catpv(sv,PL_tokenbuf);
5073                 }
5074                 else {
5075                     /* If len is 0, newSVpv does strlen(), which is correct.
5076                        If len is non-zero, then it will be the true length,
5077                        and so the scalar will be created correctly.  */
5078                     sv = newSVpv(PL_tokenbuf,len);
5079                 }
5080 #ifdef PERL_MAD
5081                 if (PL_madskills && !PL_thistoken) {
5082                     char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5083                     PL_thistoken = newSVpv(start,s - start);
5084                     PL_realtokenstart = s - SvPVX(PL_linestr);
5085                 }
5086 #endif
5087
5088                 /* Presume this is going to be a bareword of some sort. */
5089
5090                 CLINE;
5091                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5092                 yylval.opval->op_private = OPpCONST_BARE;
5093                 /* UTF-8 package name? */
5094                 if (UTF && !IN_BYTES &&
5095                     is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5096                     SvUTF8_on(sv);
5097
5098                 /* And if "Foo::", then that's what it certainly is. */
5099
5100                 if (len)
5101                     goto safe_bareword;
5102
5103                 /* Do the explicit type check so that we don't need to force
5104                    the initialisation of the symbol table to have a real GV.
5105                    Beware - gv may not really be a PVGV, cv may not really be
5106                    a PVCV, (because of the space optimisations that gv_init
5107                    understands) But they're true if for this symbol there is
5108                    respectively a typeglob and a subroutine.
5109                 */
5110                 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5111                     /* Real typeglob, so get the real subroutine: */
5112                            ? GvCVu(gv)
5113                     /* A proxy for a subroutine in this package? */
5114                            : SvOK(gv) ? (CV *) gv : NULL)
5115                     : NULL;
5116
5117                 /* See if it's the indirect object for a list operator. */
5118
5119                 if (PL_oldoldbufptr &&
5120                     PL_oldoldbufptr < PL_bufptr &&
5121                     (PL_oldoldbufptr == PL_last_lop
5122                      || PL_oldoldbufptr == PL_last_uni) &&
5123                     /* NO SKIPSPACE BEFORE HERE! */
5124                     (PL_expect == XREF ||
5125                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5126                 {
5127                     bool immediate_paren = *s == '(';
5128
5129                     /* (Now we can afford to cross potential line boundary.) */
5130                     s = SKIPSPACE2(s,nextPL_nextwhite);
5131 #ifdef PERL_MAD
5132                     PL_nextwhite = nextPL_nextwhite;    /* assume no & deception */
5133 #endif
5134
5135                     /* Two barewords in a row may indicate method call. */
5136
5137                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5138                         (tmp = intuit_method(s, gv, cv)))
5139                         return REPORT(tmp);
5140
5141                     /* If not a declared subroutine, it's an indirect object. */
5142                     /* (But it's an indir obj regardless for sort.) */
5143                     /* Also, if "_" follows a filetest operator, it's a bareword */
5144
5145                     if (
5146                         ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5147                          ((!gv || !cv) &&
5148                         (PL_last_lop_op != OP_MAPSTART &&
5149                          PL_last_lop_op != OP_GREPSTART))))
5150                        || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5151                             && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5152                        )
5153                     {
5154                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5155                         goto bareword;
5156                     }
5157                 }
5158
5159                 PL_expect = XOPERATOR;
5160 #ifdef PERL_MAD
5161                 if (isSPACE(*s))
5162                     s = SKIPSPACE2(s,nextPL_nextwhite);
5163                 PL_nextwhite = nextPL_nextwhite;
5164 #else
5165                 s = skipspace(s);
5166 #endif
5167
5168                 /* Is this a word before a => operator? */
5169                 if (*s == '=' && s[1] == '>' && !pkgname) {
5170                     CLINE;
5171                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
5172                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5173                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
5174                     TERM(WORD);
5175                 }
5176
5177                 /* If followed by a paren, it's certainly a subroutine. */
5178                 if (*s == '(') {
5179                     CLINE;
5180                     if (cv) {
5181                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
5182                         if (*d == ')' && (sv = gv_const_sv(gv))) {
5183                             s = d + 1;
5184 #ifdef PERL_MAD
5185                             if (PL_madskills) {
5186                                 char *par = SvPVX(PL_linestr) + PL_realtokenstart;
5187                                 sv_catpvn(PL_thistoken, par, s - par);
5188                                 if (PL_nextwhite) {
5189                                     sv_free(PL_nextwhite);
5190                                     PL_nextwhite = 0;
5191                                 }
5192                             }
5193 #endif
5194                             goto its_constant;
5195                         }
5196                     }
5197 #ifdef PERL_MAD
5198                     if (PL_madskills) {
5199                         PL_nextwhite = PL_thiswhite;
5200                         PL_thiswhite = 0;
5201                     }
5202                     start_force(PL_curforce);
5203 #endif
5204                     NEXTVAL_NEXTTOKE.opval = yylval.opval;
5205                     PL_expect = XOPERATOR;
5206 #ifdef PERL_MAD
5207                     if (PL_madskills) {
5208                         PL_nextwhite = nextPL_nextwhite;
5209                         curmad('X', PL_thistoken);
5210                         PL_thistoken = newSVpvn("",0);
5211                     }
5212 #endif
5213                     force_next(WORD);
5214                     yylval.ival = 0;
5215                     TOKEN('&');
5216                 }
5217
5218                 /* If followed by var or block, call it a method (unless sub) */
5219
5220                 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5221                     PL_last_lop = PL_oldbufptr;
5222                     PL_last_lop_op = OP_METHOD;
5223                     PREBLOCK(METHOD);
5224                 }
5225
5226                 /* If followed by a bareword, see if it looks like indir obj. */
5227
5228                 if (!orig_keyword
5229                         && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5230                         && (tmp = intuit_method(s, gv, cv)))
5231                     return REPORT(tmp);
5232
5233                 /* Not a method, so call it a subroutine (if defined) */
5234
5235                 if (cv) {
5236                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
5237                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5238                                 "Ambiguous use of -%s resolved as -&%s()",
5239                                 PL_tokenbuf, PL_tokenbuf);
5240                     /* Check for a constant sub */
5241                     if ((sv = gv_const_sv(gv))) {
5242                   its_constant:
5243                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
5244                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5245                         yylval.opval->op_private = 0;
5246                         TOKEN(WORD);
5247                     }
5248
5249                     /* Resolve to GV now. */
5250                     if (SvTYPE(gv) != SVt_PVGV) {
5251                         gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5252                         assert (SvTYPE(gv) == SVt_PVGV);
5253                         /* cv must have been some sort of placeholder, so
5254                            now needs replacing with a real code reference.  */
5255                         cv = GvCV(gv);
5256                     }
5257
5258                     op_free(yylval.opval);
5259                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5260                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5261                     PL_last_lop = PL_oldbufptr;
5262                     PL_last_lop_op = OP_ENTERSUB;
5263                     /* Is there a prototype? */
5264                     if (
5265 #ifdef PERL_MAD
5266                         cv &&
5267 #endif
5268                         SvPOK(cv)) {
5269                         STRLEN protolen;
5270                         const char *proto = SvPV_const((SV*)cv, protolen);
5271                         if (!protolen)
5272                             TERM(FUNC0SUB);
5273                         if (*proto == '$' && proto[1] == '\0')
5274                             OPERATOR(UNIOPSUB);
5275                         while (*proto == ';')
5276                             proto++;
5277                         if (*proto == '&' && *s == '{') {
5278                             sv_setpv(PL_subname, PL_curstash ?
5279                                         "__ANON__" : "__ANON__::__ANON__");
5280                             PREBLOCK(LSTOPSUB);
5281                         }
5282                     }
5283 #ifdef PERL_MAD
5284                     {
5285                         if (PL_madskills) {
5286                             PL_nextwhite = PL_thiswhite;
5287                             PL_thiswhite = 0;
5288                         }
5289                         start_force(PL_curforce);
5290                         NEXTVAL_NEXTTOKE.opval = yylval.opval;
5291                         PL_expect = XTERM;
5292                         if (PL_madskills) {
5293                             PL_nextwhite = nextPL_nextwhite;
5294                             curmad('X', PL_thistoken);
5295                             PL_thistoken = newSVpvn("",0);
5296                         }
5297                         force_next(WORD);
5298                         TOKEN(NOAMP);
5299                     }
5300                 }
5301
5302                 /* Guess harder when madskills require "best effort". */
5303                 if (PL_madskills && (!gv || !GvCVu(gv))) {
5304                     int probable_sub = 0;
5305                     if (strchr("\"'`$@%0123456789!*+{[<", *s))
5306                         probable_sub = 1;
5307                     else if (isALPHA(*s)) {
5308                         char tmpbuf[1024];
5309                         STRLEN tmplen;
5310                         d = s;
5311                         d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5312                         if (!keyword(tmpbuf,tmplen))
5313                             probable_sub = 1;
5314                         else {
5315                             while (d < PL_bufend && isSPACE(*d))
5316                                 d++;
5317                             if (*d == '=' && d[1] == '>')
5318                                 probable_sub = 1;
5319                         }
5320                     }
5321                     if (probable_sub) {
5322                         gv = gv_fetchpv(PL_tokenbuf, TRUE, SVt_PVCV);
5323                         op_free(yylval.opval);
5324                         yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5325                         yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5326                         PL_last_lop = PL_oldbufptr;
5327                         PL_last_lop_op = OP_ENTERSUB;
5328                         PL_nextwhite = PL_thiswhite;
5329                         PL_thiswhite = 0;
5330                         start_force(PL_curforce);
5331                         NEXTVAL_NEXTTOKE.opval = yylval.opval;
5332                         PL_expect = XTERM;
5333                         PL_nextwhite = nextPL_nextwhite;
5334                         curmad('X', PL_thistoken);
5335                         PL_thistoken = newSVpvn("",0);
5336                         force_next(WORD);
5337                         TOKEN(NOAMP);
5338                     }
5339 #else
5340                     NEXTVAL_NEXTTOKE.opval = yylval.opval;
5341                     PL_expect = XTERM;
5342                     force_next(WORD);
5343                     TOKEN(NOAMP);
5344 #endif
5345                 }
5346
5347                 /* Call it a bare word */
5348
5349                 if (PL_hints & HINT_STRICT_SUBS)
5350                     yylval.opval->op_private |= OPpCONST_STRICT;
5351                 else {
5352                 bareword:
5353                     if (lastchar != '-') {
5354                         if (ckWARN(WARN_RESERVED)) {
5355                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
5356                             if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
5357                                 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5358                                        PL_tokenbuf);
5359                         }
5360                     }
5361                 }
5362
5363             safe_bareword:
5364                 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
5365                     && ckWARN_d(WARN_AMBIGUOUS)) {
5366                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5367                         "Operator or semicolon missing before %c%s",
5368                         lastchar, PL_tokenbuf);
5369                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5370                         "Ambiguous use of %c resolved as operator %c",
5371                         lastchar, lastchar);
5372                 }
5373                 TOKEN(WORD);
5374             }
5375
5376         case KEY___FILE__:
5377             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5378                                         newSVpv(CopFILE(PL_curcop),0));
5379             TERM(THING);
5380
5381         case KEY___LINE__:
5382             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5383                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5384             TERM(THING);
5385
5386         case KEY___PACKAGE__:
5387             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5388                                         (PL_curstash
5389                                          ? newSVhek(HvNAME_HEK(PL_curstash))
5390                                          : &PL_sv_undef));
5391             TERM(THING);
5392
5393         case KEY___DATA__:
5394         case KEY___END__: {
5395             GV *gv;
5396             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5397                 const char *pname = "main";
5398                 if (PL_tokenbuf[2] == 'D')
5399                     pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5400                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5401                                 SVt_PVIO);
5402                 GvMULTI_on(gv);
5403                 if (!GvIO(gv))
5404                     GvIOp(gv) = newIO();
5405                 IoIFP(GvIOp(gv)) = PL_rsfp;
5406 #if defined(HAS_FCNTL) && defined(F_SETFD)
5407                 {
5408                     const int fd = PerlIO_fileno(PL_rsfp);
5409                     fcntl(fd,F_SETFD,fd >= 3);
5410                 }
5411 #endif
5412                 /* Mark this internal pseudo-handle as clean */
5413                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5414                 if (PL_preprocess)
5415                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
5416                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5417                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5418                 else
5419                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5420 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5421                 /* if the script was opened in binmode, we need to revert
5422                  * it to text mode for compatibility; but only iff it has CRs
5423                  * XXX this is a questionable hack at best. */
5424                 if (PL_bufend-PL_bufptr > 2
5425                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5426                 {
5427                     Off_t loc = 0;
5428                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5429                         loc = PerlIO_tell(PL_rsfp);
5430                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
5431                     }
5432 #ifdef NETWARE
5433                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5434 #else
5435                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5436 #endif  /* NETWARE */
5437 #ifdef PERLIO_IS_STDIO /* really? */
5438 #  if defined(__BORLANDC__)
5439                         /* XXX see note in do_binmode() */
5440                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5441 #  endif
5442 #endif
5443                         if (loc > 0)
5444                             PerlIO_seek(PL_rsfp, loc, 0);
5445                     }
5446                 }
5447 #endif
5448 #ifdef PERLIO_LAYERS
5449                 if (!IN_BYTES) {
5450                     if (UTF)
5451                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5452                     else if (PL_encoding) {
5453                         SV *name;
5454                         dSP;
5455                         ENTER;
5456                         SAVETMPS;
5457                         PUSHMARK(sp);
5458                         EXTEND(SP, 1);
5459                         XPUSHs(PL_encoding);
5460                         PUTBACK;
5461                         call_method("name", G_SCALAR);
5462                         SPAGAIN;
5463                         name = POPs;
5464                         PUTBACK;
5465                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5466                                             Perl_form(aTHX_ ":encoding(%"SVf")",
5467                                                       name));
5468                         FREETMPS;
5469                         LEAVE;
5470                     }
5471                 }
5472 #endif
5473 #ifdef PERL_MAD
5474                 if (PL_madskills) {
5475                     if (PL_realtokenstart >= 0) {
5476                         char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5477                         if (!PL_endwhite)
5478                             PL_endwhite = newSVpvn("",0);
5479                         sv_catsv(PL_endwhite, PL_thiswhite);
5480                         PL_thiswhite = 0;
5481                         sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5482                         PL_realtokenstart = -1;
5483                     }
5484                     while ((s = filter_gets(PL_endwhite, PL_rsfp,
5485                                  SvCUR(PL_endwhite))) != Nullch) ;
5486                 }
5487 #endif
5488                 PL_rsfp = NULL;
5489             }
5490             goto fake_eof;
5491         }
5492
5493         case KEY_AUTOLOAD:
5494         case KEY_DESTROY:
5495         case KEY_BEGIN:
5496         case KEY_CHECK:
5497         case KEY_INIT:
5498         case KEY_END:
5499             if (PL_expect == XSTATE) {
5500                 s = PL_bufptr;
5501                 goto really_sub;
5502             }
5503             goto just_a_word;
5504
5505         case KEY_CORE:
5506             if (*s == ':' && s[1] == ':') {
5507                 s += 2;
5508                 d = s;
5509                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5510                 if (!(tmp = keyword(PL_tokenbuf, len)))
5511                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5512                 if (tmp < 0)
5513                     tmp = -tmp;
5514                 else if (tmp == KEY_require || tmp == KEY_do)
5515                     /* that's a way to remember we saw "CORE::" */
5516                     orig_keyword = tmp;
5517                 goto reserved_word;
5518             }
5519             goto just_a_word;
5520
5521         case KEY_abs:
5522             UNI(OP_ABS);
5523
5524         case KEY_alarm:
5525             UNI(OP_ALARM);
5526
5527         case KEY_accept:
5528             LOP(OP_ACCEPT,XTERM);
5529
5530         case KEY_and:
5531             OPERATOR(ANDOP);
5532
5533         case KEY_atan2:
5534             LOP(OP_ATAN2,XTERM);
5535
5536         case KEY_bind:
5537             LOP(OP_BIND,XTERM);
5538
5539         case KEY_binmode:
5540             LOP(OP_BINMODE,XTERM);
5541
5542         case KEY_bless:
5543             LOP(OP_BLESS,XTERM);
5544
5545         case KEY_break:
5546             FUN0(OP_BREAK);
5547
5548         case KEY_chop:
5549             UNI(OP_CHOP);
5550
5551         case KEY_continue:
5552             /* When 'use switch' is in effect, continue has a dual
5553                life as a control operator. */
5554             {
5555                 if (!FEATURE_IS_ENABLED("switch"))
5556                     PREBLOCK(CONTINUE);
5557                 else {
5558                     /* We have to disambiguate the two senses of
5559                       "continue". If the next token is a '{' then
5560                       treat it as the start of a continue block;
5561                       otherwise treat it as a control operator.
5562                      */
5563                     s = skipspace(s);
5564                     if (*s == '{')
5565             PREBLOCK(CONTINUE);
5566                     else
5567                         FUN0(OP_CONTINUE);
5568                 }
5569             }
5570
5571         case KEY_chdir:
5572             /* may use HOME */
5573             (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5574             UNI(OP_CHDIR);
5575
5576         case KEY_close:
5577             UNI(OP_CLOSE);
5578
5579         case KEY_closedir:
5580             UNI(OP_CLOSEDIR);
5581
5582         case KEY_cmp:
5583             Eop(OP_SCMP);
5584
5585         case KEY_caller:
5586             UNI(OP_CALLER);
5587
5588         case KEY_crypt:
5589 #ifdef FCRYPT
5590             if (!PL_cryptseen) {
5591                 PL_cryptseen = TRUE;
5592                 init_des();
5593             }
5594 #endif
5595             LOP(OP_CRYPT,XTERM);
5596
5597         case KEY_chmod:
5598             LOP(OP_CHMOD,XTERM);
5599
5600         case KEY_chown:
5601             LOP(OP_CHOWN,XTERM);
5602
5603         case KEY_connect:
5604             LOP(OP_CONNECT,XTERM);
5605
5606         case KEY_chr:
5607             UNI(OP_CHR);
5608
5609         case KEY_cos:
5610             UNI(OP_COS);
5611
5612         case KEY_chroot:
5613             UNI(OP_CHROOT);
5614
5615         case KEY_default:
5616             PREBLOCK(DEFAULT);
5617
5618         case KEY_do:
5619             s = SKIPSPACE1(s);
5620             if (*s == '{')
5621                 PRETERMBLOCK(DO);
5622             if (*s != '\'')
5623                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5624             if (orig_keyword == KEY_do) {
5625                 orig_keyword = 0;
5626                 yylval.ival = 1;
5627             }
5628             else
5629                 yylval.ival = 0;
5630             OPERATOR(DO);
5631
5632         case KEY_die:
5633             PL_hints |= HINT_BLOCK_SCOPE;
5634             LOP(OP_DIE,XTERM);
5635
5636         case KEY_defined:
5637             UNI(OP_DEFINED);
5638
5639         case KEY_delete:
5640             UNI(OP_DELETE);
5641
5642         case KEY_dbmopen:
5643             gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
5644             LOP(OP_DBMOPEN,XTERM);
5645
5646         case KEY_dbmclose:
5647             UNI(OP_DBMCLOSE);
5648
5649         case KEY_dump:
5650             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5651             LOOPX(OP_DUMP);
5652
5653         case KEY_else:
5654             PREBLOCK(ELSE);
5655
5656         case KEY_elsif:
5657             yylval.ival = CopLINE(PL_curcop);
5658             OPERATOR(ELSIF);
5659
5660         case KEY_eq:
5661             Eop(OP_SEQ);
5662
5663         case KEY_exists:
5664             UNI(OP_EXISTS);
5665
5666         case KEY_exit:
5667             if (PL_madskills)
5668                 UNI(OP_INT);
5669             UNI(OP_EXIT);
5670
5671         case KEY_eval:
5672             s = SKIPSPACE1(s);
5673             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
5674             UNIBRACK(OP_ENTEREVAL);
5675
5676         case KEY_eof:
5677             UNI(OP_EOF);
5678
5679         case KEY_err:
5680             OPERATOR(DOROP);
5681
5682         case KEY_exp:
5683             UNI(OP_EXP);
5684
5685         case KEY_each:
5686             UNI(OP_EACH);
5687
5688         case KEY_exec:
5689             set_csh();
5690             LOP(OP_EXEC,XREF);
5691
5692         case KEY_endhostent:
5693             FUN0(OP_EHOSTENT);
5694
5695         case KEY_endnetent:
5696             FUN0(OP_ENETENT);
5697
5698         case KEY_endservent:
5699             FUN0(OP_ESERVENT);
5700
5701         case KEY_endprotoent:
5702             FUN0(OP_EPROTOENT);
5703
5704         case KEY_endpwent:
5705             FUN0(OP_EPWENT);
5706
5707         case KEY_endgrent:
5708             FUN0(OP_EGRENT);
5709
5710         case KEY_for:
5711         case KEY_foreach:
5712             yylval.ival = CopLINE(PL_curcop);
5713             s = SKIPSPACE1(s);
5714             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
5715                 char *p = s;
5716 #ifdef PERL_MAD
5717                 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
5718 #endif
5719
5720                 if ((PL_bufend - p) >= 3 &&
5721                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
5722                     p += 2;
5723                 else if ((PL_bufend - p) >= 4 &&
5724                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
5725                     p += 3;
5726                 p = PEEKSPACE(p);
5727                 if (isIDFIRST_lazy_if(p,UTF)) {
5728                     p = scan_ident(p, PL_bufend,
5729                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5730                     p = PEEKSPACE(p);
5731                 }
5732                 if (*p != '$')
5733                     Perl_croak(aTHX_ "Missing $ on loop variable");
5734 #ifdef PERL_MAD
5735                 s = SvPVX(PL_linestr) + soff;
5736 #endif
5737             }
5738             OPERATOR(FOR);
5739
5740         case KEY_formline:
5741             LOP(OP_FORMLINE,XTERM);
5742
5743         case KEY_fork:
5744             FUN0(OP_FORK);
5745
5746         case KEY_fcntl:
5747             LOP(OP_FCNTL,XTERM);
5748
5749         case KEY_fileno:
5750             UNI(OP_FILENO);
5751
5752         case KEY_flock:
5753             LOP(OP_FLOCK,XTERM);
5754
5755         case KEY_gt:
5756             Rop(OP_SGT);
5757
5758         case KEY_ge:
5759             Rop(OP_SGE);
5760
5761         case KEY_grep:
5762             LOP(OP_GREPSTART, XREF);
5763
5764         case KEY_goto:
5765             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5766             LOOPX(OP_GOTO);
5767
5768         case KEY_gmtime:
5769             UNI(OP_GMTIME);
5770
5771         case KEY_getc:
5772             UNIDOR(OP_GETC);
5773
5774         case KEY_getppid:
5775             FUN0(OP_GETPPID);
5776
5777         case KEY_getpgrp:
5778             UNI(OP_GETPGRP);
5779
5780         case KEY_getpriority:
5781             LOP(OP_GETPRIORITY,XTERM);
5782
5783         case KEY_getprotobyname:
5784             UNI(OP_GPBYNAME);
5785
5786         case KEY_getprotobynumber:
5787             LOP(OP_GPBYNUMBER,XTERM);
5788
5789         case KEY_getprotoent:
5790             FUN0(OP_GPROTOENT);
5791
5792         case KEY_getpwent:
5793             FUN0(OP_GPWENT);
5794
5795         case KEY_getpwnam:
5796             UNI(OP_GPWNAM);
5797
5798         case KEY_getpwuid:
5799             UNI(OP_GPWUID);
5800
5801         case KEY_getpeername:
5802             UNI(OP_GETPEERNAME);
5803
5804         case KEY_gethostbyname:
5805             UNI(OP_GHBYNAME);
5806
5807         case KEY_gethostbyaddr:
5808             LOP(OP_GHBYADDR,XTERM);
5809
5810         case KEY_gethostent:
5811             FUN0(OP_GHOSTENT);
5812
5813         case KEY_getnetbyname:
5814             UNI(OP_GNBYNAME);
5815
5816         case KEY_getnetbyaddr:
5817             LOP(OP_GNBYADDR,XTERM);
5818
5819         case KEY_getnetent:
5820             FUN0(OP_GNETENT);
5821
5822         case KEY_getservbyname:
5823             LOP(OP_GSBYNAME,XTERM);
5824
5825         case KEY_getservbyport:
5826             LOP(OP_GSBYPORT,XTERM);
5827
5828         case KEY_getservent:
5829             FUN0(OP_GSERVENT);
5830
5831         case KEY_getsockname:
5832             UNI(OP_GETSOCKNAME);
5833
5834         case KEY_getsockopt:
5835             LOP(OP_GSOCKOPT,XTERM);
5836
5837         case KEY_getgrent:
5838             FUN0(OP_GGRENT);
5839
5840         case KEY_getgrnam:
5841             UNI(OP_GGRNAM);
5842
5843         case KEY_getgrgid:
5844             UNI(OP_GGRGID);
5845
5846         case KEY_getlogin:
5847             FUN0(OP_GETLOGIN);
5848
5849         case KEY_given:
5850             yylval.ival = CopLINE(PL_curcop);
5851             OPERATOR(GIVEN);
5852
5853         case KEY_glob:
5854             set_csh();
5855             LOP(OP_GLOB,XTERM);
5856
5857         case KEY_hex:
5858             UNI(OP_HEX);
5859
5860         case KEY_if:
5861             yylval.ival = CopLINE(PL_curcop);
5862             OPERATOR(IF);
5863
5864         case KEY_index:
5865             LOP(OP_INDEX,XTERM);
5866
5867         case KEY_int:
5868             UNI(OP_INT);
5869
5870         case KEY_ioctl:
5871             LOP(OP_IOCTL,XTERM);
5872
5873         case KEY_join:
5874             LOP(OP_JOIN,XTERM);
5875
5876         case KEY_keys:
5877             UNI(OP_KEYS);
5878
5879         case KEY_kill:
5880             LOP(OP_KILL,XTERM);
5881
5882         case KEY_last:
5883             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5884             LOOPX(OP_LAST);
5885
5886         case KEY_lc:
5887             UNI(OP_LC);
5888
5889         case KEY_lcfirst:
5890             UNI(OP_LCFIRST);
5891
5892         case KEY_local:
5893             yylval.ival = 0;
5894             OPERATOR(LOCAL);
5895
5896         case KEY_length:
5897             UNI(OP_LENGTH);
5898
5899         case KEY_lt:
5900             Rop(OP_SLT);
5901
5902         case KEY_le:
5903             Rop(OP_SLE);
5904
5905         case KEY_localtime:
5906             UNI(OP_LOCALTIME);
5907
5908         case KEY_log:
5909             UNI(OP_LOG);
5910
5911         case KEY_link:
5912             LOP(OP_LINK,XTERM);
5913
5914         case KEY_listen:
5915             LOP(OP_LISTEN,XTERM);
5916
5917         case KEY_lock:
5918             UNI(OP_LOCK);
5919
5920         case KEY_lstat:
5921             UNI(OP_LSTAT);
5922
5923         case KEY_m:
5924             s = scan_pat(s,OP_MATCH);
5925             TERM(sublex_start());
5926
5927         case KEY_map:
5928             LOP(OP_MAPSTART, XREF);
5929
5930         case KEY_mkdir:
5931             LOP(OP_MKDIR,XTERM);
5932
5933         case KEY_msgctl:
5934             LOP(OP_MSGCTL,XTERM);
5935
5936         case KEY_msgget:
5937             LOP(OP_MSGGET,XTERM);
5938
5939         case KEY_msgrcv:
5940             LOP(OP_MSGRCV,XTERM);
5941
5942         case KEY_msgsnd:
5943             LOP(OP_MSGSND,XTERM);
5944
5945         case KEY_our:
5946         case KEY_my:
5947             PL_in_my = tmp;
5948             s = SKIPSPACE1(s);
5949             if (isIDFIRST_lazy_if(s,UTF)) {
5950 #ifdef PERL_MAD
5951                 char* start = s;
5952 #endif
5953                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
5954                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
5955                     goto really_sub;
5956                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
5957                 if (!PL_in_my_stash) {
5958                     char tmpbuf[1024];
5959                     PL_bufptr = s;
5960                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
5961                     yyerror(tmpbuf);
5962                 }
5963 #ifdef PERL_MAD
5964                 if (PL_madskills) {     /* just add type to declarator token */
5965                     sv_catsv(PL_thistoken, PL_nextwhite);
5966                     PL_nextwhite = 0;
5967                     sv_catpvn(PL_thistoken, start, s - start);
5968                 }
5969 #endif
5970             }
5971             yylval.ival = 1;
5972             OPERATOR(MY);
5973
5974         case KEY_next:
5975             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5976             LOOPX(OP_NEXT);
5977
5978         case KEY_ne:
5979             Eop(OP_SNE);
5980
5981         case KEY_no:
5982             s = tokenize_use(0, s);
5983             OPERATOR(USE);
5984
5985         case KEY_not:
5986             if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
5987                 FUN1(OP_NOT);
5988             else
5989                 OPERATOR(NOTOP);
5990
5991         case KEY_open:
5992             s = SKIPSPACE1(s);
5993             if (isIDFIRST_lazy_if(s,UTF)) {
5994                 const char *t;
5995                 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
5996                 for (t=d; *t && isSPACE(*t); t++) ;
5997                 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
5998                     /* [perl #16184] */
5999                     && !(t[0] == '=' && t[1] == '>')
6000                 ) {
6001                     int parms_len = (int)(d-s);
6002                     Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6003                            "Precedence problem: open %.*s should be open(%.*s)",
6004                             parms_len, s, parms_len, s);
6005                 }
6006             }
6007             LOP(OP_OPEN,XTERM);
6008
6009         case KEY_or:
6010             yylval.ival = OP_OR;
6011             OPERATOR(OROP);
6012
6013         case KEY_ord:
6014             UNI(OP_ORD);
6015
6016         case KEY_oct:
6017             UNI(OP_OCT);
6018
6019         case KEY_opendir:
6020             LOP(OP_OPEN_DIR,XTERM);
6021
6022         case KEY_print:
6023             checkcomma(s,PL_tokenbuf,"filehandle");
6024             LOP(OP_PRINT,XREF);
6025
6026         case KEY_printf:
6027             checkcomma(s,PL_tokenbuf,"filehandle");
6028             LOP(OP_PRTF,XREF);
6029
6030         case KEY_prototype:
6031             UNI(OP_PROTOTYPE);
6032
6033         case KEY_push:
6034             LOP(OP_PUSH,XTERM);
6035
6036         case KEY_pop:
6037             UNIDOR(OP_POP);
6038
6039         case KEY_pos:
6040             UNIDOR(OP_POS);
6041
6042         case KEY_pack:
6043             LOP(OP_PACK,XTERM);
6044
6045         case KEY_package:
6046             s = force_word(s,WORD,FALSE,TRUE,FALSE);
6047             OPERATOR(PACKAGE);
6048
6049         case KEY_pipe:
6050             LOP(OP_PIPE_OP,XTERM);
6051
6052         case KEY_q:
6053             s = scan_str(s,!!PL_madskills,FALSE);
6054             if (!s)
6055                 missingterm(NULL);
6056             yylval.ival = OP_CONST;
6057             TERM(sublex_start());
6058
6059         case KEY_quotemeta:
6060             UNI(OP_QUOTEMETA);
6061
6062         case KEY_qw:
6063             s = scan_str(s,!!PL_madskills,FALSE);
6064             if (!s)
6065                 missingterm(NULL);
6066             PL_expect = XOPERATOR;
6067             force_next(')');
6068             if (SvCUR(PL_lex_stuff)) {
6069                 OP *words = NULL;
6070                 int warned = 0;
6071                 d = SvPV_force(PL_lex_stuff, len);
6072                 while (len) {
6073                     for (; isSPACE(*d) && len; --len, ++d)
6074                         /**/;
6075                     if (len) {
6076                         SV *sv;
6077                         const char *b = d;
6078                         if (!warned && ckWARN(WARN_QW)) {
6079                             for (; !isSPACE(*d) && len; --len, ++d) {
6080                                 if (*d == ',') {
6081                                     Perl_warner(aTHX_ packWARN(WARN_QW),
6082                                         "Possible attempt to separate words with commas");
6083                                     ++warned;
6084                                 }
6085                                 else if (*d == '#') {
6086                                     Perl_warner(aTHX_ packWARN(WARN_QW),
6087                                         "Possible attempt to put comments in qw() list");
6088                                     ++warned;
6089                                 }
6090                             }
6091                         }
6092                         else {
6093                             for (; !isSPACE(*d) && len; --len, ++d)
6094                                 /**/;
6095                         }
6096                         sv = newSVpvn(b, d-b);
6097                         if (DO_UTF8(PL_lex_stuff))
6098                             SvUTF8_on(sv);
6099                         words = append_elem(OP_LIST, words,
6100                                             newSVOP(OP_CONST, 0, tokeq(sv)));
6101                     }
6102                 }
6103                 if (words) {
6104                     start_force(PL_curforce);
6105                     NEXTVAL_NEXTTOKE.opval = words;
6106                     force_next(THING);
6107                 }
6108             }
6109             if (PL_lex_stuff) {
6110                 SvREFCNT_dec(PL_lex_stuff);
6111                 PL_lex_stuff = NULL;
6112             }
6113             PL_expect = XTERM;
6114             TOKEN('(');
6115
6116         case KEY_qq:
6117             s = scan_str(s,!!PL_madskills,FALSE);
6118             if (!s)
6119                 missingterm(NULL);
6120             yylval.ival = OP_STRINGIFY;
6121             if (SvIVX(PL_lex_stuff) == '\'')
6122                 SvIV_set(PL_lex_stuff, 0);      /* qq'$foo' should intepolate */
6123             TERM(sublex_start());
6124
6125         case KEY_qr:
6126             s = scan_pat(s,OP_QR);
6127             TERM(sublex_start());
6128
6129         case KEY_qx:
6130             s = scan_str(s,!!PL_madskills,FALSE);
6131             if (!s)
6132                 missingterm(NULL);
6133             yylval.ival = OP_BACKTICK;
6134             set_csh();
6135             TERM(sublex_start());
6136
6137         case KEY_return:
6138             OLDLOP(OP_RETURN);
6139
6140         case KEY_require:
6141             s = SKIPSPACE1(s);
6142             if (isDIGIT(*s)) {
6143                 s = force_version(s, FALSE);
6144             }
6145             else if (*s != 'v' || !isDIGIT(s[1])
6146                     || (s = force_version(s, TRUE), *s == 'v'))
6147             {
6148                 *PL_tokenbuf = '\0';
6149                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6150                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6151                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
6152                 else if (*s == '<')
6153                     yyerror("<> should be quotes");
6154             }
6155             if (orig_keyword == KEY_require) {
6156                 orig_keyword = 0;
6157                 yylval.ival = 1;
6158             }
6159             else
6160                 yylval.ival = 0;
6161             PL_expect = XTERM;
6162             PL_bufptr = s;
6163             PL_last_uni = PL_oldbufptr;
6164             PL_last_lop_op = OP_REQUIRE;
6165             s = skipspace(s);
6166             return REPORT( (int)REQUIRE );
6167
6168         case KEY_reset:
6169             UNI(OP_RESET);
6170
6171         case KEY_redo:
6172             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6173             LOOPX(OP_REDO);
6174
6175         case KEY_rename:
6176             LOP(OP_RENAME,XTERM);
6177
6178         case KEY_rand:
6179             UNI(OP_RAND);
6180
6181         case KEY_rmdir:
6182             UNI(OP_RMDIR);
6183
6184         case KEY_rindex:
6185             LOP(OP_RINDEX,XTERM);
6186
6187         case KEY_read:
6188             LOP(OP_READ,XTERM);
6189
6190         case KEY_readdir:
6191             UNI(OP_READDIR);
6192
6193         case KEY_readline:
6194             set_csh();
6195             UNIDOR(OP_READLINE);
6196
6197         case KEY_readpipe:
6198             set_csh();
6199             UNI(OP_BACKTICK);
6200
6201         case KEY_rewinddir:
6202             UNI(OP_REWINDDIR);
6203
6204         case KEY_recv:
6205             LOP(OP_RECV,XTERM);
6206
6207         case KEY_reverse:
6208             LOP(OP_REVERSE,XTERM);
6209
6210         case KEY_readlink:
6211             UNIDOR(OP_READLINK);
6212
6213         case KEY_ref:
6214             UNI(OP_REF);
6215
6216         case KEY_s:
6217             s = scan_subst(s);
6218             if (yylval.opval)
6219                 TERM(sublex_start());
6220             else
6221                 TOKEN(1);       /* force error */
6222
6223         case KEY_say:
6224             checkcomma(s,PL_tokenbuf,"filehandle");
6225             LOP(OP_SAY,XREF);
6226
6227         case KEY_chomp:
6228             UNI(OP_CHOMP);
6229
6230         case KEY_scalar:
6231             UNI(OP_SCALAR);
6232
6233         case KEY_select:
6234             LOP(OP_SELECT,XTERM);
6235
6236         case KEY_seek:
6237             LOP(OP_SEEK,XTERM);
6238
6239         case KEY_semctl:
6240             LOP(OP_SEMCTL,XTERM);
6241
6242         case KEY_semget:
6243             LOP(OP_SEMGET,XTERM);
6244
6245         case KEY_semop:
6246             LOP(OP_SEMOP,XTERM);
6247
6248         case KEY_send:
6249             LOP(OP_SEND,XTERM);
6250
6251         case KEY_setpgrp:
6252             LOP(OP_SETPGRP,XTERM);
6253
6254         case KEY_setpriority:
6255             LOP(OP_SETPRIORITY,XTERM);
6256
6257         case KEY_sethostent:
6258             UNI(OP_SHOSTENT);
6259
6260         case KEY_setnetent:
6261             UNI(OP_SNETENT);
6262
6263         case KEY_setservent:
6264             UNI(OP_SSERVENT);
6265
6266         case KEY_setprotoent:
6267             UNI(OP_SPROTOENT);
6268
6269         case KEY_setpwent:
6270             FUN0(OP_SPWENT);
6271
6272         case KEY_setgrent:
6273             FUN0(OP_SGRENT);
6274
6275         case KEY_seekdir:
6276             LOP(OP_SEEKDIR,XTERM);
6277
6278         case KEY_setsockopt:
6279             LOP(OP_SSOCKOPT,XTERM);
6280
6281         case KEY_shift:
6282             UNIDOR(OP_SHIFT);
6283
6284         case KEY_shmctl:
6285             LOP(OP_SHMCTL,XTERM);
6286
6287         case KEY_shmget:
6288             LOP(OP_SHMGET,XTERM);
6289
6290         case KEY_shmread:
6291             LOP(OP_SHMREAD,XTERM);
6292
6293         case KEY_shmwrite:
6294             LOP(OP_SHMWRITE,XTERM);
6295
6296         case KEY_shutdown:
6297             LOP(OP_SHUTDOWN,XTERM);
6298
6299         case KEY_sin:
6300             UNI(OP_SIN);
6301
6302         case KEY_sleep:
6303             UNI(OP_SLEEP);
6304
6305         case KEY_socket:
6306             LOP(OP_SOCKET,XTERM);
6307
6308         case KEY_socketpair:
6309             LOP(OP_SOCKPAIR,XTERM);
6310
6311         case KEY_sort:
6312             checkcomma(s,PL_tokenbuf,"subroutine name");
6313             s = SKIPSPACE1(s);
6314             if (*s == ';' || *s == ')')         /* probably a close */
6315                 Perl_croak(aTHX_ "sort is now a reserved word");
6316             PL_expect = XTERM;
6317             s = force_word(s,WORD,TRUE,TRUE,FALSE);
6318             LOP(OP_SORT,XREF);
6319
6320         case KEY_split:
6321             LOP(OP_SPLIT,XTERM);
6322
6323         case KEY_sprintf:
6324             LOP(OP_SPRINTF,XTERM);
6325
6326         case KEY_splice:
6327             LOP(OP_SPLICE,XTERM);
6328
6329         case KEY_sqrt:
6330             UNI(OP_SQRT);
6331
6332         case KEY_srand:
6333             UNI(OP_SRAND);
6334
6335         case KEY_stat:
6336             UNI(OP_STAT);
6337
6338         case KEY_study:
6339             UNI(OP_STUDY);
6340
6341         case KEY_substr:
6342             LOP(OP_SUBSTR,XTERM);
6343
6344         case KEY_format:
6345         case KEY_sub:
6346           really_sub:
6347             {
6348                 char tmpbuf[sizeof PL_tokenbuf];
6349                 SSize_t tboffset = 0;
6350                 expectation attrful;
6351                 bool have_name, have_proto, bad_proto;
6352                 const int key = tmp;
6353
6354 #ifdef PERL_MAD
6355                 SV *tmpwhite = 0;
6356
6357                 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6358                 SV *subtoken = newSVpvn(tstart, s - tstart);
6359                 PL_thistoken = 0;
6360
6361                 d = s;
6362                 s = SKIPSPACE2(s,tmpwhite);
6363 #else
6364                 s = skipspace(s);
6365 #endif
6366
6367                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6368                     (*s == ':' && s[1] == ':'))
6369                 {
6370 #ifdef PERL_MAD
6371                     SV *nametoke;
6372 #endif
6373
6374                     PL_expect = XBLOCK;
6375                     attrful = XATTRBLOCK;
6376                     /* remember buffer pos'n for later force_word */
6377                     tboffset = s - PL_oldbufptr;
6378                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6379 #ifdef PERL_MAD
6380                     if (PL_madskills)
6381                         nametoke = newSVpvn(s, d - s);
6382 #endif
6383                     if (strchr(tmpbuf, ':'))
6384                         sv_setpv(PL_subname, tmpbuf);
6385                     else {
6386                         sv_setsv(PL_subname,PL_curstname);
6387                         sv_catpvs(PL_subname,"::");
6388                         sv_catpvn(PL_subname,tmpbuf,len);
6389                     }
6390                     have_name = TRUE;
6391
6392 #ifdef PERL_MAD
6393
6394                     start_force(0);
6395                     CURMAD('X', nametoke);
6396                     CURMAD('_', tmpwhite);
6397                     (void) force_word(PL_oldbufptr + tboffset, WORD,
6398                                       FALSE, TRUE, TRUE);
6399
6400                     s = SKIPSPACE2(d,tmpwhite);
6401 #else
6402                     s = skipspace(d);
6403 #endif
6404                 }
6405                 else {
6406                     if (key == KEY_my)
6407                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
6408                     PL_expect = XTERMBLOCK;
6409                     attrful = XATTRTERM;
6410                     sv_setpvn(PL_subname,"?",1);
6411                     have_name = FALSE;
6412                 }
6413
6414                 if (key == KEY_format) {
6415                     if (*s == '=')
6416                         PL_lex_formbrack = PL_lex_brackets + 1;
6417 #ifdef PERL_MAD
6418                     PL_thistoken = subtoken;
6419                     s = d;
6420 #else
6421                     if (have_name)
6422                         (void) force_word(PL_oldbufptr + tboffset, WORD,
6423                                           FALSE, TRUE, TRUE);
6424 #endif
6425                     OPERATOR(FORMAT);
6426                 }
6427
6428                 /* Look for a prototype */
6429                 if (*s == '(') {
6430                     char *p;
6431
6432                     s = scan_str(s,!!PL_madskills,FALSE);
6433                     if (!s)
6434                         Perl_croak(aTHX_ "Prototype not terminated");
6435                     /* strip spaces and check for bad characters */
6436                     d = SvPVX(PL_lex_stuff);
6437                     tmp = 0;
6438                     bad_proto = FALSE;
6439                     for (p = d; *p; ++p) {
6440                         if (!isSPACE(*p)) {
6441                             d[tmp++] = *p;
6442                             if (!strchr("$@%*;[]&\\", *p))
6443                                 bad_proto = TRUE;
6444                         }
6445                     }
6446                     d[tmp] = '\0';
6447                     if (bad_proto && ckWARN(WARN_SYNTAX))
6448                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6449                                     "Illegal character in prototype for %"SVf" : %s",
6450                                     PL_subname, d);
6451                     SvCUR_set(PL_lex_stuff, tmp);
6452                     have_proto = TRUE;
6453
6454 #ifdef PERL_MAD
6455                     start_force(0);
6456                     CURMAD('q', PL_thisopen);
6457                     CURMAD('_', tmpwhite);
6458                     CURMAD('=', PL_thisstuff);
6459                     CURMAD('Q', PL_thisclose);
6460                     NEXTVAL_NEXTTOKE.opval =
6461                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6462                     PL_lex_stuff = Nullsv;
6463                     force_next(THING);
6464
6465                     s = SKIPSPACE2(s,tmpwhite);
6466 #else
6467                     s = skipspace(s);
6468 #endif
6469                 }
6470                 else
6471                     have_proto = FALSE;
6472
6473                 if (*s == ':' && s[1] != ':')
6474                     PL_expect = attrful;
6475                 else if (*s != '{' && key == KEY_sub) {
6476                     if (!have_name)
6477                         Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6478                     else if (*s != ';')
6479                         Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
6480                 }
6481
6482 #ifdef PERL_MAD
6483                 start_force(0);
6484                 if (tmpwhite) {
6485                     if (PL_madskills)
6486                         curmad('^', newSVpvn("",0));
6487                     CURMAD('_', tmpwhite);
6488                 }
6489                 force_next(0);
6490
6491                 PL_thistoken = subtoken;
6492 #else
6493                 if (have_proto) {
6494                     NEXTVAL_NEXTTOKE.opval =
6495                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6496                     PL_lex_stuff = NULL;
6497                     force_next(THING);
6498                 }
6499 #endif
6500                 if (!have_name) {
6501                     sv_setpv(PL_subname,
6502                         PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
6503                     TOKEN(ANONSUB);
6504                 }
6505 #ifndef PERL_MAD
6506                 (void) force_word(PL_oldbufptr + tboffset, WORD,
6507                                   FALSE, TRUE, TRUE);
6508 #endif
6509                 if (key == KEY_my)
6510                     TOKEN(MYSUB);
6511                 TOKEN(SUB);
6512             }
6513
6514         case KEY_system:
6515             set_csh();
6516             LOP(OP_SYSTEM,XREF);
6517
6518         case KEY_symlink:
6519             LOP(OP_SYMLINK,XTERM);
6520
6521         case KEY_syscall:
6522             LOP(OP_SYSCALL,XTERM);
6523
6524         case KEY_sysopen:
6525             LOP(OP_SYSOPEN,XTERM);
6526
6527         case KEY_sysseek:
6528             LOP(OP_SYSSEEK,XTERM);
6529
6530         case KEY_sysread:
6531             LOP(OP_SYSREAD,XTERM);
6532
6533         case KEY_syswrite:
6534             LOP(OP_SYSWRITE,XTERM);
6535
6536         case KEY_tr:
6537             s = scan_trans(s);
6538             TERM(sublex_start());
6539
6540         case KEY_tell:
6541             UNI(OP_TELL);
6542
6543         case KEY_telldir:
6544             UNI(OP_TELLDIR);
6545
6546         case KEY_tie:
6547             LOP(OP_TIE,XTERM);
6548
6549         case KEY_tied:
6550             UNI(OP_TIED);
6551
6552         case KEY_time:
6553             FUN0(OP_TIME);
6554
6555         case KEY_times:
6556             FUN0(OP_TMS);
6557
6558         case KEY_truncate:
6559             LOP(OP_TRUNCATE,XTERM);
6560
6561         case KEY_uc:
6562             UNI(OP_UC);
6563
6564         case KEY_ucfirst:
6565             UNI(OP_UCFIRST);
6566
6567         case KEY_untie:
6568             UNI(OP_UNTIE);
6569
6570         case KEY_until:
6571             yylval.ival = CopLINE(PL_curcop);
6572             OPERATOR(UNTIL);
6573
6574         case KEY_unless:
6575             yylval.ival = CopLINE(PL_curcop);
6576             OPERATOR(UNLESS);
6577
6578         case KEY_unlink:
6579             LOP(OP_UNLINK,XTERM);
6580
6581         case KEY_undef:
6582             UNIDOR(OP_UNDEF);
6583
6584         case KEY_unpack:
6585             LOP(OP_UNPACK,XTERM);
6586
6587         case KEY_utime:
6588             LOP(OP_UTIME,XTERM);
6589
6590         case KEY_umask:
6591             UNIDOR(OP_UMASK);
6592
6593         case KEY_unshift:
6594             LOP(OP_UNSHIFT,XTERM);
6595
6596         case KEY_use:
6597             s = tokenize_use(1, s);
6598             OPERATOR(USE);
6599
6600         case KEY_values:
6601             UNI(OP_VALUES);
6602
6603         case KEY_vec:
6604             LOP(OP_VEC,XTERM);
6605
6606         case KEY_when:
6607             yylval.ival = CopLINE(PL_curcop);
6608             OPERATOR(WHEN);
6609
6610         case KEY_while:
6611             yylval.ival = CopLINE(PL_curcop);
6612             OPERATOR(WHILE);
6613
6614         case KEY_warn:
6615             PL_hints |= HINT_BLOCK_SCOPE;
6616             LOP(OP_WARN,XTERM);
6617
6618         case KEY_wait:
6619             FUN0(OP_WAIT);
6620
6621         case KEY_waitpid:
6622             LOP(OP_WAITPID,XTERM);
6623
6624         case KEY_wantarray:
6625             FUN0(OP_WANTARRAY);
6626
6627         case KEY_write:
6628 #ifdef EBCDIC
6629         {
6630             char ctl_l[2];
6631             ctl_l[0] = toCTRL('L');
6632             ctl_l[1] = '\0';
6633             gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
6634         }
6635 #else
6636             /* Make sure $^L is defined */
6637             gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
6638 #endif
6639             UNI(OP_ENTERWRITE);
6640
6641         case KEY_x:
6642             if (PL_expect == XOPERATOR)
6643                 Mop(OP_REPEAT);
6644             check_uni();
6645             goto just_a_word;
6646
6647         case KEY_xor:
6648             yylval.ival = OP_XOR;
6649             OPERATOR(OROP);
6650
6651         case KEY_y:
6652             s = scan_trans(s);
6653             TERM(sublex_start());
6654         }
6655     }}
6656 }
6657 #ifdef __SC__
6658 #pragma segment Main
6659 #endif
6660
6661 static int
6662 S_pending_ident(pTHX)
6663 {
6664     dVAR;
6665     register char *d;
6666     register I32 tmp = 0;
6667     /* pit holds the identifier we read and pending_ident is reset */
6668     char pit = PL_pending_ident;
6669     PL_pending_ident = 0;
6670
6671     /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
6672     DEBUG_T({ PerlIO_printf(Perl_debug_log,
6673           "### Pending identifier '%s'\n", PL_tokenbuf); });
6674
6675     /* if we're in a my(), we can't allow dynamics here.
6676        $foo'bar has already been turned into $foo::bar, so
6677        just check for colons.
6678
6679        if it's a legal name, the OP is a PADANY.
6680     */
6681     if (PL_in_my) {
6682         if (PL_in_my == KEY_our) {      /* "our" is merely analogous to "my" */
6683             if (strchr(PL_tokenbuf,':'))
6684                 yyerror(Perl_form(aTHX_ "No package name allowed for "
6685                                   "variable %s in \"our\"",
6686                                   PL_tokenbuf));
6687             tmp = allocmy(PL_tokenbuf);
6688         }
6689         else {
6690             if (strchr(PL_tokenbuf,':'))
6691                 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
6692
6693             yylval.opval = newOP(OP_PADANY, 0);
6694             yylval.opval->op_targ = allocmy(PL_tokenbuf);
6695             return PRIVATEREF;
6696         }
6697     }
6698
6699     /*
6700        build the ops for accesses to a my() variable.
6701
6702        Deny my($a) or my($b) in a sort block, *if* $a or $b is
6703        then used in a comparison.  This catches most, but not
6704        all cases.  For instance, it catches
6705            sort { my($a); $a <=> $b }
6706        but not
6707            sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
6708        (although why you'd do that is anyone's guess).
6709     */
6710
6711     if (!strchr(PL_tokenbuf,':')) {
6712         if (!PL_in_my)
6713             tmp = pad_findmy(PL_tokenbuf);
6714         if (tmp != NOT_IN_PAD) {
6715             /* might be an "our" variable" */
6716             if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
6717                 /* build ops for a bareword */
6718                 HV *  const stash = PAD_COMPNAME_OURSTASH(tmp);
6719                 HEK * const stashname = HvNAME_HEK(stash);
6720                 SV *  const sym = newSVhek(stashname);
6721                 sv_catpvs(sym, "::");
6722                 sv_catpv(sym, PL_tokenbuf+1);
6723                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
6724                 yylval.opval->op_private = OPpCONST_ENTERED;
6725                 gv_fetchsv(sym,
6726                     (PL_in_eval
6727                         ? (GV_ADDMULTI | GV_ADDINEVAL)
6728                         : GV_ADDMULTI
6729                     ),
6730                     ((PL_tokenbuf[0] == '$') ? SVt_PV
6731                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
6732                      : SVt_PVHV));
6733                 return WORD;
6734             }
6735
6736             /* if it's a sort block and they're naming $a or $b */
6737             if (PL_last_lop_op == OP_SORT &&
6738                 PL_tokenbuf[0] == '$' &&
6739                 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
6740                 && !PL_tokenbuf[2])
6741             {
6742                 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
6743                      d < PL_bufend && *d != '\n';
6744                      d++)
6745                 {
6746                     if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
6747                         Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
6748                               PL_tokenbuf);
6749                     }
6750                 }
6751             }
6752
6753             yylval.opval = newOP(OP_PADANY, 0);
6754             yylval.opval->op_targ = tmp;
6755             return PRIVATEREF;
6756         }
6757     }
6758
6759     /*
6760        Whine if they've said @foo in a doublequoted string,
6761        and @foo isn't a variable we can find in the symbol
6762        table.
6763     */
6764     if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
6765         GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
6766         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
6767              && ckWARN(WARN_AMBIGUOUS))
6768         {
6769             /* Downgraded from fatal to warning 20000522 mjd */
6770             Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6771                         "Possible unintended interpolation of %s in string",
6772                          PL_tokenbuf);
6773         }
6774     }
6775
6776     /* build ops for a bareword */
6777     yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
6778     yylval.opval->op_private = OPpCONST_ENTERED;
6779     gv_fetchpv(
6780             PL_tokenbuf+1,
6781             /* If the identifier refers to a stash, don't autovivify it.
6782              * Change 24660 had the side effect of causing symbol table
6783              * hashes to always be defined, even if they were freshly
6784              * created and the only reference in the entire program was
6785              * the single statement with the defined %foo::bar:: test.
6786              * It appears that all code in the wild doing this actually
6787              * wants to know whether sub-packages have been loaded, so
6788              * by avoiding auto-vivifying symbol tables, we ensure that
6789              * defined %foo::bar:: continues to be false, and the existing
6790              * tests still give the expected answers, even though what
6791              * they're actually testing has now changed subtly.
6792              */
6793             (*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'
6794              ? 0
6795              : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
6796             ((PL_tokenbuf[0] == '$') ? SVt_PV
6797              : (PL_tokenbuf[0] == '@') ? SVt_PVAV
6798              : SVt_PVHV));
6799     return WORD;
6800 }
6801
6802 /*
6803  *  The following code was generated by perl_keyword.pl.
6804  */
6805
6806 I32
6807 Perl_keyword (pTHX_ const char *name, I32 len)
6808 {
6809   dVAR;
6810   switch (len)
6811   {
6812     case 1: /* 5 tokens of length 1 */
6813       switch (name[0])
6814       {
6815         case 'm':
6816           {                                       /* m          */
6817             return KEY_m;
6818           }
6819
6820         case 'q':
6821           {                                       /* q          */
6822             return KEY_q;
6823           }
6824
6825         case 's':
6826           {                                       /* s          */
6827             return KEY_s;
6828           }
6829
6830         case 'x':
6831           {                                       /* x          */
6832             return -KEY_x;
6833           }
6834
6835         case 'y':
6836           {                                       /* y          */
6837             return KEY_y;
6838           }
6839
6840         default:
6841           goto unknown;
6842       }
6843
6844     case 2: /* 18 tokens of length 2 */
6845       switch (name[0])
6846       {
6847         case 'd':
6848           if (name[1] == 'o')
6849           {                                       /* do         */
6850             return KEY_do;
6851           }
6852
6853           goto unknown;
6854
6855         case 'e':
6856           if (name[1] == 'q')
6857           {                                       /* eq         */
6858             return -KEY_eq;
6859           }
6860
6861           goto unknown;
6862
6863         case 'g':
6864           switch (name[1])
6865           {
6866             case 'e':
6867               {                                   /* ge         */
6868                 return -KEY_ge;
6869               }
6870
6871             case 't':
6872               {                                   /* gt         */
6873                 return -KEY_gt;
6874               }
6875
6876             default:
6877               goto unknown;
6878           }
6879
6880         case 'i':
6881           if (name[1] == 'f')
6882           {                                       /* if         */
6883             return KEY_if;
6884           }
6885
6886           goto unknown;
6887
6888         case 'l':
6889           switch (name[1])
6890           {
6891             case 'c':
6892               {                                   /* lc         */
6893                 return -KEY_lc;
6894               }
6895
6896             case 'e':
6897               {                                   /* le         */
6898                 return -KEY_le;
6899               }
6900
6901             case 't':
6902               {                                   /* lt         */
6903                 return -KEY_lt;
6904               }
6905
6906             default:
6907               goto unknown;
6908           }
6909
6910         case 'm':
6911           if (name[1] == 'y')
6912           {                                       /* my         */
6913             return KEY_my;
6914           }
6915
6916           goto unknown;
6917
6918         case 'n':
6919           switch (name[1])
6920           {
6921             case 'e':
6922               {                                   /* ne         */
6923                 return -KEY_ne;
6924               }
6925
6926             case 'o':
6927               {                                   /* no         */
6928                 return KEY_no;
6929               }
6930
6931             default:
6932               goto unknown;
6933           }
6934
6935         case 'o':
6936           if (name[1] == 'r')
6937           {                                       /* or         */
6938             return -KEY_or;
6939           }
6940
6941           goto unknown;
6942
6943         case 'q':
6944           switch (name[1])
6945           {
6946             case 'q':
6947               {                                   /* qq         */
6948                 return KEY_qq;
6949               }
6950
6951             case 'r':
6952               {                                   /* qr         */
6953                 return KEY_qr;
6954               }
6955
6956             case 'w':
6957               {                                   /* qw         */
6958                 return KEY_qw;
6959               }
6960
6961             case 'x':
6962               {                                   /* qx         */
6963                 return KEY_qx;
6964               }
6965
6966             default:
6967               goto unknown;
6968           }
6969
6970         case 't':
6971           if (name[1] == 'r')
6972           {                                       /* tr         */
6973             return KEY_tr;
6974           }
6975
6976           goto unknown;
6977
6978         case 'u':
6979           if (name[1] == 'c')
6980           {                                       /* uc         */
6981             return -KEY_uc;
6982           }
6983
6984           goto unknown;
6985
6986         default:
6987           goto unknown;
6988       }
6989
6990     case 3: /* 29 tokens of length 3 */
6991       switch (name[0])
6992       {
6993         case 'E':
6994           if (name[1] == 'N' &&
6995               name[2] == 'D')
6996           {                                       /* END        */
6997             return KEY_END;
6998           }
6999
7000           goto unknown;
7001
7002         case 'a':
7003           switch (name[1])
7004           {
7005             case 'b':
7006               if (name[2] == 's')
7007               {                                   /* abs        */
7008                 return -KEY_abs;
7009               }
7010
7011               goto unknown;
7012
7013             case 'n':
7014               if (name[2] == 'd')
7015               {                                   /* and        */
7016                 return -KEY_and;
7017               }
7018
7019               goto unknown;
7020
7021             default:
7022               goto unknown;
7023           }
7024
7025         case 'c':
7026           switch (name[1])
7027           {
7028             case 'h':
7029               if (name[2] == 'r')
7030               {                                   /* chr        */
7031                 return -KEY_chr;
7032               }
7033
7034               goto unknown;
7035
7036             case 'm':
7037               if (name[2] == 'p')
7038               {                                   /* cmp        */
7039                 return -KEY_cmp;
7040               }
7041
7042               goto unknown;
7043
7044             case 'o':
7045               if (name[2] == 's')
7046               {                                   /* cos        */
7047                 return -KEY_cos;
7048               }
7049
7050               goto unknown;
7051
7052             default:
7053               goto unknown;
7054           }
7055
7056         case 'd':
7057           if (name[1] == 'i' &&
7058               name[2] == 'e')
7059           {                                       /* die        */
7060             return -KEY_die;
7061           }
7062
7063           goto unknown;
7064
7065         case 'e':
7066           switch (name[1])
7067           {
7068             case 'o':
7069               if (name[2] == 'f')
7070               {                                   /* eof        */
7071                 return -KEY_eof;
7072               }
7073
7074               goto unknown;
7075
7076             case 'r':
7077               if (name[2] == 'r')
7078               {                                   /* err        */
7079                 return (FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
7080               }
7081
7082               goto unknown;
7083
7084             case 'x':
7085               if (name[2] == 'p')
7086               {                                   /* exp        */
7087                 return -KEY_exp;
7088               }
7089
7090               goto unknown;
7091
7092             default:
7093               goto unknown;
7094           }
7095
7096         case 'f':
7097           if (name[1] == 'o' &&
7098               name[2] == 'r')
7099           {                                       /* for        */
7100             return KEY_for;
7101           }
7102
7103           goto unknown;
7104
7105         case 'h':
7106           if (name[1] == 'e' &&
7107               name[2] == 'x')
7108           {                                       /* hex        */
7109             return -KEY_hex;
7110           }
7111
7112           goto unknown;
7113
7114         case 'i':
7115           if (name[1] == 'n' &&
7116               name[2] == 't')
7117           {                                       /* int        */
7118             return -KEY_int;
7119           }
7120
7121           goto unknown;
7122
7123         case 'l':
7124           if (name[1] == 'o' &&
7125               name[2] == 'g')
7126           {                                       /* log        */
7127             return -KEY_log;
7128           }
7129
7130           goto unknown;
7131
7132         case 'm':
7133           if (name[1] == 'a' &&
7134               name[2] == 'p')
7135           {                                       /* map        */
7136             return KEY_map;
7137           }
7138
7139           goto unknown;
7140
7141         case 'n':
7142           if (name[1] == 'o' &&
7143               name[2] == 't')
7144           {                                       /* not        */
7145             return -KEY_not;
7146           }
7147
7148           goto unknown;
7149
7150         case 'o':
7151           switch (name[1])
7152           {
7153             case 'c':
7154               if (name[2] == 't')
7155               {                                   /* oct        */
7156                 return -KEY_oct;
7157               }
7158
7159               goto unknown;
7160
7161             case 'r':
7162               if (name[2] == 'd')
7163               {                                   /* ord        */
7164                 return -KEY_ord;
7165               }
7166
7167               goto unknown;
7168
7169             case 'u':
7170               if (name[2] == 'r')
7171               {                                   /* our        */
7172                 return KEY_our;
7173               }
7174
7175               goto unknown;
7176
7177             default:
7178               goto unknown;
7179           }
7180
7181         case 'p':
7182           if (name[1] == 'o')
7183           {
7184             switch (name[2])
7185             {
7186               case 'p':
7187                 {                                 /* pop        */
7188                   return -KEY_pop;
7189                 }
7190
7191               case 's':
7192                 {                                 /* pos        */
7193                   return KEY_pos;
7194                 }
7195
7196               default:
7197                 goto unknown;
7198             }
7199           }
7200
7201           goto unknown;
7202
7203         case 'r':
7204           if (name[1] == 'e' &&
7205               name[2] == 'f')
7206           {                                       /* ref        */
7207             return -KEY_ref;
7208           }
7209
7210           goto unknown;
7211
7212         case 's':
7213           switch (name[1])
7214           {
7215             case 'a':
7216               if (name[2] == 'y')
7217               {                                   /* say        */
7218                 return (FEATURE_IS_ENABLED("say") ? -KEY_say : 0);
7219               }
7220
7221               goto unknown;
7222
7223             case 'i':
7224               if (name[2] == 'n')
7225               {                                   /* sin        */
7226                 return -KEY_sin;
7227               }
7228
7229               goto unknown;
7230
7231             case 'u':
7232               if (name[2] == 'b')
7233               {                                   /* sub        */
7234                 return KEY_sub;
7235               }
7236
7237               goto unknown;
7238
7239             default:
7240               goto unknown;
7241           }
7242
7243         case 't':
7244           if (name[1] == 'i' &&
7245               name[2] == 'e')
7246           {                                       /* tie        */
7247             return KEY_tie;
7248           }
7249
7250           goto unknown;
7251
7252         case 'u':
7253           if (name[1] == 's' &&
7254               name[2] == 'e')
7255           {                                       /* use        */
7256             return KEY_use;
7257           }
7258
7259           goto unknown;
7260
7261         case 'v':
7262           if (name[1] == 'e' &&
7263               name[2] == 'c')
7264           {                                       /* vec        */
7265             return -KEY_vec;
7266           }
7267
7268           goto unknown;
7269
7270         case 'x':
7271           if (name[1] == 'o' &&
7272               name[2] == 'r')
7273           {                                       /* xor        */
7274             return -KEY_xor;
7275           }
7276
7277           goto unknown;
7278
7279         default:
7280           goto unknown;
7281       }
7282
7283     case 4: /* 41 tokens of length 4 */
7284       switch (name[0])
7285       {
7286         case 'C':
7287           if (name[1] == 'O' &&
7288               name[2] == 'R' &&
7289               name[3] == 'E')
7290           {                                       /* CORE       */
7291             return -KEY_CORE;
7292           }
7293
7294           goto unknown;
7295
7296         case 'I':
7297           if (name[1] == 'N' &&
7298               name[2] == 'I' &&
7299               name[3] == 'T')
7300           {                                       /* INIT       */
7301             return KEY_INIT;
7302           }
7303
7304           goto unknown;
7305
7306         case 'b':
7307           if (name[1] == 'i' &&
7308               name[2] == 'n' &&
7309               name[3] == 'd')
7310           {                                       /* bind       */
7311             return -KEY_bind;
7312           }
7313
7314           goto unknown;
7315
7316         case 'c':
7317           if (name[1] == 'h' &&
7318               name[2] == 'o' &&
7319               name[3] == 'p')
7320           {                                       /* chop       */
7321             return -KEY_chop;
7322           }
7323
7324           goto unknown;
7325
7326         case 'd':
7327           if (name[1] == 'u' &&
7328               name[2] == 'm' &&
7329               name[3] == 'p')
7330           {                                       /* dump       */
7331             return -KEY_dump;
7332           }
7333
7334           goto unknown;
7335
7336         case 'e':
7337           switch (name[1])
7338           {
7339             case 'a':
7340               if (name[2] == 'c' &&
7341                   name[3] == 'h')
7342               {                                   /* each       */
7343                 return -KEY_each;
7344               }
7345
7346               goto unknown;
7347
7348             case 'l':
7349               if (name[2] == 's' &&
7350                   name[3] == 'e')
7351               {                                   /* else       */
7352                 return KEY_else;
7353               }
7354
7355               goto unknown;
7356
7357             case 'v':
7358               if (name[2] == 'a' &&
7359                   name[3] == 'l')
7360               {                                   /* eval       */
7361                 return KEY_eval;
7362               }
7363
7364               goto unknown;
7365
7366             case 'x':
7367               switch (name[2])
7368               {
7369                 case 'e':
7370                   if (name[3] == 'c')
7371                   {                               /* exec       */
7372                     return -KEY_exec;
7373                   }
7374
7375                   goto unknown;
7376
7377                 case 'i':
7378                   if (name[3] == 't')
7379                   {                               /* exit       */
7380                     return -KEY_exit;
7381                   }
7382
7383                   goto unknown;
7384
7385                 default:
7386                   goto unknown;
7387               }
7388
7389             default:
7390               goto unknown;
7391           }
7392
7393         case 'f':
7394           if (name[1] == 'o' &&
7395               name[2] == 'r' &&
7396               name[3] == 'k')
7397           {                                       /* fork       */
7398             return -KEY_fork;
7399           }
7400
7401           goto unknown;
7402
7403         case 'g':
7404           switch (name[1])
7405           {
7406             case 'e':
7407               if (name[2] == 't' &&
7408                   name[3] == 'c')
7409               {                                   /* getc       */
7410                 return -KEY_getc;
7411               }
7412
7413               goto unknown;
7414
7415             case 'l':
7416               if (name[2] == 'o' &&
7417                   name[3] == 'b')
7418               {                                   /* glob       */
7419                 return KEY_glob;
7420               }
7421
7422               goto unknown;
7423
7424             case 'o':
7425               if (name[2] == 't' &&
7426                   name[3] == 'o')
7427               {                                   /* goto       */
7428                 return KEY_goto;
7429               }
7430
7431               goto unknown;
7432
7433             case 'r':
7434               if (name[2] == 'e' &&
7435                   name[3] == 'p')
7436               {                                   /* grep       */
7437                 return KEY_grep;
7438               }
7439
7440               goto unknown;
7441
7442             default:
7443               goto unknown;
7444           }
7445
7446         case 'j':
7447           if (name[1] == 'o' &&
7448               name[2] == 'i' &&
7449               name[3] == 'n')
7450           {                                       /* join       */
7451             return -KEY_join;
7452           }
7453
7454           goto unknown;
7455
7456         case 'k':
7457           switch (name[1])
7458           {
7459             case 'e':
7460               if (name[2] == 'y' &&
7461                   name[3] == 's')
7462               {                                   /* keys       */
7463                 return -KEY_keys;
7464               }
7465
7466               goto unknown;
7467
7468             case 'i':
7469               if (name[2] == 'l' &&
7470                   name[3] == 'l')
7471               {                                   /* kill       */
7472                 return -KEY_kill;
7473               }
7474
7475               goto unknown;
7476
7477             default:
7478               goto unknown;
7479           }
7480
7481         case 'l':
7482           switch (name[1])
7483           {
7484             case 'a':
7485               if (name[2] == 's' &&
7486                   name[3] == 't')
7487               {                                   /* last       */
7488                 return KEY_last;
7489               }
7490
7491               goto unknown;
7492
7493             case 'i':
7494               if (name[2] == 'n' &&
7495                   name[3] == 'k')
7496               {                                   /* link       */
7497                 return -KEY_link;
7498               }
7499
7500               goto unknown;
7501
7502             case 'o':
7503               if (name[2] == 'c' &&
7504                   name[3] == 'k')
7505               {                                   /* lock       */
7506                 return -KEY_lock;
7507               }
7508
7509               goto unknown;
7510
7511             default:
7512               goto unknown;
7513           }
7514
7515         case 'n':
7516           if (name[1] == 'e' &&
7517               name[2] == 'x' &&
7518               name[3] == 't')
7519           {                                       /* next       */
7520             return KEY_next;
7521           }
7522
7523           goto unknown;
7524
7525         case 'o':
7526           if (name[1] == 'p' &&
7527               name[2] == 'e' &&
7528               name[3] == 'n')
7529           {                                       /* open       */
7530             return -KEY_open;
7531           }
7532
7533           goto unknown;
7534
7535         case 'p':
7536           switch (name[1])
7537           {
7538             case 'a':
7539               if (name[2] == 'c' &&
7540                   name[3] == 'k')
7541               {                                   /* pack       */
7542                 return -KEY_pack;
7543               }
7544
7545               goto unknown;
7546
7547             case 'i':
7548               if (name[2] == 'p' &&
7549                   name[3] == 'e')
7550               {                                   /* pipe       */
7551                 return -KEY_pipe;
7552               }
7553
7554               goto unknown;
7555
7556             case 'u':
7557               if (name[2] == 's' &&
7558                   name[3] == 'h')
7559               {                                   /* push       */
7560                 return -KEY_push;
7561               }
7562
7563               goto unknown;
7564
7565             default:
7566               goto unknown;
7567           }
7568
7569         case 'r':
7570           switch (name[1])
7571           {
7572             case 'a':
7573               if (name[2] == 'n' &&
7574                   name[3] == 'd')
7575               {                                   /* rand       */
7576                 return -KEY_rand;
7577               }
7578
7579               goto unknown;
7580
7581             case 'e':
7582               switch (name[2])
7583               {
7584                 case 'a':
7585                   if (name[3] == 'd')
7586                   {                               /* read       */
7587                     return -KEY_read;
7588                   }
7589
7590                   goto unknown;
7591
7592                 case 'c':
7593                   if (name[3] == 'v')
7594                   {                               /* recv       */
7595                     return -KEY_recv;
7596                   }
7597
7598                   goto unknown;
7599
7600                 case 'd':
7601                   if (name[3] == 'o')
7602                   {                               /* redo       */
7603                     return KEY_redo;
7604                   }
7605
7606                   goto unknown;
7607
7608                 default:
7609                   goto unknown;
7610               }
7611
7612             default:
7613               goto unknown;
7614           }
7615
7616         case 's':
7617           switch (name[1])
7618           {
7619             case 'e':
7620               switch (name[2])
7621               {
7622                 case 'e':
7623                   if (name[3] == 'k')
7624                   {                               /* seek       */
7625                     return -KEY_seek;
7626                   }
7627
7628                   goto unknown;
7629
7630                 case 'n':
7631                   if (name[3] == 'd')
7632                   {                               /* send       */
7633                     return -KEY_send;
7634                   }
7635
7636                   goto unknown;
7637
7638                 default:
7639                   goto unknown;
7640               }
7641
7642             case 'o':
7643               if (name[2] == 'r' &&
7644                   name[3] == 't')
7645               {                                   /* sort       */
7646                 return KEY_sort;
7647               }
7648
7649               goto unknown;
7650
7651             case 'q':
7652               if (name[2] == 'r' &&
7653                   name[3] == 't')
7654               {                                   /* sqrt       */
7655                 return -KEY_sqrt;
7656               }
7657
7658               goto unknown;
7659
7660             case 't':
7661               if (name[2] == 'a' &&
7662                   name[3] == 't')
7663               {                                   /* stat       */
7664                 return -KEY_stat;
7665               }
7666
7667               goto unknown;
7668
7669             default:
7670               goto unknown;
7671           }
7672
7673         case 't':
7674           switch (name[1])
7675           {
7676             case 'e':
7677               if (name[2] == 'l' &&
7678                   name[3] == 'l')
7679               {                                   /* tell       */
7680                 return -KEY_tell;
7681               }
7682
7683               goto unknown;
7684
7685             case 'i':
7686               switch (name[2])
7687               {
7688                 case 'e':
7689                   if (name[3] == 'd')
7690                   {                               /* tied       */
7691                     return KEY_tied;
7692                   }
7693
7694                   goto unknown;
7695
7696                 case 'm':
7697                   if (name[3] == 'e')
7698                   {                               /* time       */
7699                     return -KEY_time;
7700                   }
7701
7702                   goto unknown;
7703
7704                 default:
7705                   goto unknown;
7706               }
7707
7708             default:
7709               goto unknown;
7710           }
7711
7712         case 'w':
7713           switch (name[1])
7714           {
7715             case 'a':
7716             switch (name[2])
7717             {
7718               case 'i':
7719                 if (name[3] == 't')
7720                 {                                 /* wait       */
7721                   return -KEY_wait;
7722                 }
7723
7724                 goto unknown;
7725
7726               case 'r':
7727                 if (name[3] == 'n')
7728                 {                                 /* warn       */
7729                   return -KEY_warn;
7730                 }
7731
7732                 goto unknown;
7733
7734               default:
7735                 goto unknown;
7736             }
7737
7738             case 'h':
7739               if (name[2] == 'e' &&
7740                   name[3] == 'n')
7741               {                                   /* when       */
7742                 return (FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
7743           }
7744
7745           goto unknown;
7746
7747         default:
7748           goto unknown;
7749       }
7750
7751         default:
7752           goto unknown;
7753       }
7754
7755     case 5: /* 38 tokens of length 5 */
7756       switch (name[0])
7757       {
7758         case 'B':
7759           if (name[1] == 'E' &&
7760               name[2] == 'G' &&
7761               name[3] == 'I' &&
7762               name[4] == 'N')
7763           {                                       /* BEGIN      */
7764             return KEY_BEGIN;
7765           }
7766
7767           goto unknown;
7768
7769         case 'C':
7770           if (name[1] == 'H' &&
7771               name[2] == 'E' &&
7772               name[3] == 'C' &&
7773               name[4] == 'K')
7774           {                                       /* CHECK      */
7775             return KEY_CHECK;
7776           }
7777
7778           goto unknown;
7779
7780         case 'a':
7781           switch (name[1])
7782           {
7783             case 'l':
7784               if (name[2] == 'a' &&
7785                   name[3] == 'r' &&
7786                   name[4] == 'm')
7787               {                                   /* alarm      */
7788                 return -KEY_alarm;
7789               }
7790
7791               goto unknown;
7792
7793             case 't':
7794               if (name[2] == 'a' &&
7795                   name[3] == 'n' &&
7796                   name[4] == '2')
7797               {                                   /* atan2      */
7798                 return -KEY_atan2;
7799               }
7800
7801               goto unknown;
7802
7803             default:
7804               goto unknown;
7805           }
7806
7807         case 'b':
7808           switch (name[1])
7809           {
7810             case 'l':
7811               if (name[2] == 'e' &&
7812               name[3] == 's' &&
7813               name[4] == 's')
7814           {                                       /* bless      */
7815             return -KEY_bless;
7816           }
7817
7818           goto unknown;
7819
7820             case 'r':
7821               if (name[2] == 'e' &&
7822                   name[3] == 'a' &&
7823                   name[4] == 'k')
7824               {                                   /* break      */
7825                 return (FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
7826               }
7827
7828               goto unknown;
7829
7830             default:
7831               goto unknown;
7832           }
7833
7834         case 'c':
7835           switch (name[1])
7836           {
7837             case 'h':
7838               switch (name[2])
7839               {
7840                 case 'd':
7841                   if (name[3] == 'i' &&
7842                       name[4] == 'r')
7843                   {                               /* chdir      */
7844                     return -KEY_chdir;
7845                   }
7846
7847                   goto unknown;
7848
7849                 case 'm':
7850                   if (name[3] == 'o' &&
7851                       name[4] == 'd')
7852                   {                               /* chmod      */
7853                     return -KEY_chmod;
7854                   }
7855
7856                   goto unknown;
7857
7858                 case 'o':
7859                   switch (name[3])
7860                   {
7861                     case 'm':
7862                       if (name[4] == 'p')
7863                       {                           /* chomp      */
7864                         return -KEY_chomp;
7865                       }
7866
7867                       goto unknown;
7868
7869                     case 'w':
7870                       if (name[4] == 'n')
7871                       {                           /* chown      */
7872                         return -KEY_chown;
7873                       }
7874
7875                       goto unknown;
7876
7877                     default:
7878                       goto unknown;
7879                   }
7880
7881                 default:
7882                   goto unknown;
7883               }
7884
7885             case 'l':
7886               if (name[2] == 'o' &&
7887                   name[3] == 's' &&
7888                   name[4] == 'e')
7889               {                                   /* close      */
7890                 return -KEY_close;
7891               }
7892
7893               goto unknown;
7894
7895             case 'r':
7896               if (name[2] == 'y' &&
7897                   name[3] == 'p' &&
7898                   name[4] == 't')
7899               {                                   /* crypt      */
7900                 return -KEY_crypt;
7901               }
7902
7903               goto unknown;
7904
7905             default:
7906               goto unknown;
7907           }
7908
7909         case 'e':
7910           if (name[1] == 'l' &&
7911               name[2] == 's' &&
7912               name[3] == 'i' &&
7913               name[4] == 'f')
7914           {                                       /* elsif      */
7915             return KEY_elsif;
7916           }
7917
7918           goto unknown;
7919
7920         case 'f':
7921           switch (name[1])
7922           {
7923             case 'c':
7924               if (name[2] == 'n' &&
7925                   name[3] == 't' &&
7926                   name[4] == 'l')
7927               {                                   /* fcntl      */
7928                 return -KEY_fcntl;
7929               }
7930
7931               goto unknown;
7932
7933             case 'l':
7934               if (name[2] == 'o' &&
7935                   name[3] == 'c' &&
7936                   name[4] == 'k')
7937               {                                   /* flock      */
7938                 return -KEY_flock;
7939               }
7940
7941               goto unknown;
7942
7943             default:
7944               goto unknown;
7945           }
7946
7947         case 'g':
7948           if (name[1] == 'i' &&
7949               name[2] == 'v' &&
7950               name[3] == 'e' &&
7951               name[4] == 'n')
7952           {                                       /* given      */
7953             return (FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
7954           }
7955
7956           goto unknown;
7957
7958         case 'i':
7959           switch (name[1])
7960           {
7961             case 'n':
7962               if (name[2] == 'd' &&
7963                   name[3] == 'e' &&
7964                   name[4] == 'x')
7965               {                                   /* index      */
7966                 return -KEY_index;
7967               }
7968
7969               goto unknown;
7970
7971             case 'o':
7972               if (name[2] == 'c' &&
7973                   name[3] == 't' &&
7974                   name[4] == 'l')
7975               {                                   /* ioctl      */
7976                 return -KEY_ioctl;
7977               }
7978
7979               goto unknown;
7980
7981             default:
7982               goto unknown;
7983           }
7984
7985         case 'l':
7986           switch (name[1])
7987           {
7988             case 'o':
7989               if (name[2] == 'c' &&
7990                   name[3] == 'a' &&
7991                   name[4] == 'l')
7992               {                                   /* local      */
7993                 return KEY_local;
7994               }
7995
7996               goto unknown;
7997
7998             case 's':
7999               if (name[2] == 't' &&
8000                   name[3] == 'a' &&
8001                   name[4] == 't')
8002               {                                   /* lstat      */
8003                 return -KEY_lstat;
8004               }
8005
8006               goto unknown;
8007
8008             default:
8009               goto unknown;
8010           }
8011
8012         case 'm':
8013           if (name[1] == 'k' &&
8014               name[2] == 'd' &&
8015               name[3] == 'i' &&
8016               name[4] == 'r')
8017           {                                       /* mkdir      */
8018             return -KEY_mkdir;
8019           }
8020
8021           goto unknown;
8022
8023         case 'p':
8024           if (name[1] == 'r' &&
8025               name[2] == 'i' &&
8026               name[3] == 'n' &&
8027               name[4] == 't')
8028           {                                       /* print      */
8029             return KEY_print;
8030           }
8031
8032           goto unknown;
8033
8034         case 'r':
8035           switch (name[1])
8036           {
8037             case 'e':
8038               if (name[2] == 's' &&
8039                   name[3] == 'e' &&
8040                   name[4] == 't')
8041               {                                   /* reset      */
8042                 return -KEY_reset;
8043               }
8044
8045               goto unknown;
8046
8047             case 'm':
8048               if (name[2] == 'd' &&
8049                   name[3] == 'i' &&
8050                   name[4] == 'r')
8051               {                                   /* rmdir      */
8052                 return -KEY_rmdir;
8053               }
8054
8055               goto unknown;
8056
8057             default:
8058               goto unknown;
8059           }
8060
8061         case 's':
8062           switch (name[1])
8063           {
8064             case 'e':
8065               if (name[2] == 'm' &&
8066                   name[3] == 'o' &&
8067                   name[4] == 'p')
8068               {                                   /* semop      */
8069                 return -KEY_semop;
8070               }
8071
8072               goto unknown;
8073
8074             case 'h':
8075               if (name[2] == 'i' &&
8076                   name[3] == 'f' &&
8077                   name[4] == 't')
8078               {                                   /* shift      */
8079                 return -KEY_shift;
8080               }
8081
8082               goto unknown;
8083
8084             case 'l':
8085               if (name[2] == 'e' &&
8086                   name[3] == 'e' &&
8087                   name[4] == 'p')
8088               {                                   /* sleep      */
8089                 return -KEY_sleep;
8090               }
8091
8092               goto unknown;
8093
8094             case 'p':
8095               if (name[2] == 'l' &&
8096                   name[3] == 'i' &&
8097                   name[4] == 't')
8098               {                                   /* split      */
8099                 return KEY_split;
8100               }
8101
8102               goto unknown;
8103
8104             case 'r':
8105               if (name[2] == 'a' &&
8106                   name[3] == 'n' &&
8107                   name[4] == 'd')
8108               {                                   /* srand      */
8109                 return -KEY_srand;
8110               }
8111
8112               goto unknown;
8113
8114             case 't':
8115               if (name[2] == 'u' &&
8116                   name[3] == 'd' &&
8117                   name[4] == 'y')
8118               {                                   /* study      */
8119                 return KEY_study;
8120               }
8121
8122               goto unknown;
8123
8124             default:
8125               goto unknown;
8126           }
8127
8128         case 't':
8129           if (name[1] == 'i' &&
8130               name[2] == 'm' &&
8131               name[3] == 'e' &&
8132               name[4] == 's')
8133           {                                       /* times      */
8134             return -KEY_times;
8135           }
8136
8137           goto unknown;
8138
8139         case 'u':
8140           switch (name[1])
8141           {
8142             case 'm':
8143               if (name[2] == 'a' &&
8144                   name[3] == 's' &&
8145                   name[4] == 'k')
8146               {                                   /* umask      */
8147                 return -KEY_umask;
8148               }
8149
8150               goto unknown;
8151
8152             case 'n':
8153               switch (name[2])
8154               {
8155                 case 'd':
8156                   if (name[3] == 'e' &&
8157                       name[4] == 'f')
8158                   {                               /* undef      */
8159                     return KEY_undef;
8160                   }
8161
8162                   goto unknown;
8163
8164                 case 't':
8165                   if (name[3] == 'i')
8166                   {
8167                     switch (name[4])
8168                     {
8169                       case 'e':
8170                         {                         /* untie      */
8171                           return KEY_untie;
8172                         }
8173
8174                       case 'l':
8175                         {                         /* until      */
8176                           return KEY_until;
8177                         }
8178
8179                       default:
8180                         goto unknown;
8181                     }
8182                   }
8183
8184                   goto unknown;
8185
8186                 default:
8187                   goto unknown;
8188               }
8189
8190             case 't':
8191               if (name[2] == 'i' &&
8192                   name[3] == 'm' &&
8193                   name[4] == 'e')
8194               {                                   /* utime      */
8195                 return -KEY_utime;
8196               }
8197
8198               goto unknown;
8199
8200             default:
8201               goto unknown;
8202           }
8203
8204         case 'w':
8205           switch (name[1])
8206           {
8207             case 'h':
8208               if (name[2] == 'i' &&
8209                   name[3] == 'l' &&
8210                   name[4] == 'e')
8211               {                                   /* while      */
8212                 return KEY_while;
8213               }
8214
8215               goto unknown;
8216
8217             case 'r':
8218               if (name[2] == 'i' &&
8219                   name[3] == 't' &&
8220                   name[4] == 'e')
8221               {                                   /* write      */
8222                 return -KEY_write;
8223               }
8224
8225               goto unknown;
8226
8227             default:
8228               goto unknown;
8229           }
8230
8231         default:
8232           goto unknown;
8233       }
8234
8235     case 6: /* 33 tokens of length 6 */
8236       switch (name[0])
8237       {
8238         case 'a':
8239           if (name[1] == 'c' &&
8240               name[2] == 'c' &&
8241               name[3] == 'e' &&
8242               name[4] == 'p' &&
8243               name[5] == 't')
8244           {                                       /* accept     */
8245             return -KEY_accept;
8246           }
8247
8248           goto unknown;
8249
8250         case 'c':
8251           switch (name[1])
8252           {
8253             case 'a':
8254               if (name[2] == 'l' &&
8255                   name[3] == 'l' &&
8256                   name[4] == 'e' &&
8257                   name[5] == 'r')
8258               {                                   /* caller     */
8259                 return -KEY_caller;
8260               }
8261
8262               goto unknown;
8263
8264             case 'h':
8265               if (name[2] == 'r' &&
8266                   name[3] == 'o' &&
8267                   name[4] == 'o' &&
8268                   name[5] == 't')
8269               {                                   /* chroot     */
8270                 return -KEY_chroot;
8271               }
8272
8273               goto unknown;
8274
8275             default:
8276               goto unknown;
8277           }
8278
8279         case 'd':
8280           if (name[1] == 'e' &&
8281               name[2] == 'l' &&
8282               name[3] == 'e' &&
8283               name[4] == 't' &&
8284               name[5] == 'e')
8285           {                                       /* delete     */
8286             return KEY_delete;
8287           }
8288
8289           goto unknown;
8290
8291         case 'e':
8292           switch (name[1])
8293           {
8294             case 'l':
8295               if (name[2] == 's' &&
8296                   name[3] == 'e' &&
8297                   name[4] == 'i' &&
8298                   name[5] == 'f')
8299               {                                   /* elseif     */
8300                 if(ckWARN_d(WARN_SYNTAX))
8301                   Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8302               }
8303
8304               goto unknown;
8305
8306             case 'x':
8307               if (name[2] == 'i' &&
8308                   name[3] == 's' &&
8309                   name[4] == 't' &&
8310                   name[5] == 's')
8311               {                                   /* exists     */
8312                 return KEY_exists;
8313               }
8314
8315               goto unknown;
8316
8317             default:
8318               goto unknown;
8319           }
8320
8321         case 'f':
8322           switch (name[1])
8323           {
8324             case 'i':
8325               if (name[2] == 'l' &&
8326                   name[3] == 'e' &&
8327                   name[4] == 'n' &&
8328                   name[5] == 'o')
8329               {                                   /* fileno     */
8330                 return -KEY_fileno;
8331               }
8332
8333               goto unknown;
8334
8335             case 'o':
8336               if (name[2] == 'r' &&
8337                   name[3] == 'm' &&
8338                   name[4] == 'a' &&
8339                   name[5] == 't')
8340               {                                   /* format     */
8341                 return KEY_format;
8342               }
8343
8344               goto unknown;
8345
8346             default:
8347               goto unknown;
8348           }
8349
8350         case 'g':
8351           if (name[1] == 'm' &&
8352               name[2] == 't' &&
8353               name[3] == 'i' &&
8354               name[4] == 'm' &&
8355               name[5] == 'e')
8356           {                                       /* gmtime     */
8357             return -KEY_gmtime;
8358           }
8359
8360           goto unknown;
8361
8362         case 'l':
8363           switch (name[1])
8364           {
8365             case 'e':
8366               if (name[2] == 'n' &&
8367                   name[3] == 'g' &&
8368                   name[4] == 't' &&
8369                   name[5] == 'h')
8370               {                                   /* length     */
8371                 return -KEY_length;
8372               }
8373
8374               goto unknown;
8375
8376             case 'i':
8377               if (name[2] == 's' &&
8378                   name[3] == 't' &&
8379                   name[4] == 'e' &&
8380                   name[5] == 'n')
8381               {                                   /* listen     */
8382                 return -KEY_listen;
8383               }
8384
8385               goto unknown;
8386
8387             default:
8388               goto unknown;
8389           }
8390
8391         case 'm':
8392           if (name[1] == 's' &&
8393               name[2] == 'g')
8394           {
8395             switch (name[3])
8396             {
8397               case 'c':
8398                 if (name[4] == 't' &&
8399                     name[5] == 'l')
8400                 {                                 /* msgctl     */
8401                   return -KEY_msgctl;
8402                 }
8403
8404                 goto unknown;
8405
8406               case 'g':
8407                 if (name[4] == 'e' &&
8408                     name[5] == 't')
8409                 {                                 /* msgget     */
8410                   return -KEY_msgget;
8411                 }
8412
8413                 goto unknown;
8414
8415               case 'r':
8416                 if (name[4] == 'c' &&
8417                     name[5] == 'v')
8418                 {                                 /* msgrcv     */
8419                   return -KEY_msgrcv;
8420                 }
8421
8422                 goto unknown;
8423
8424               case 's':
8425                 if (name[4] == 'n' &&
8426                     name[5] == 'd')
8427                 {                                 /* msgsnd     */
8428                   return -KEY_msgsnd;
8429                 }
8430
8431                 goto unknown;
8432
8433               default:
8434                 goto unknown;
8435             }
8436           }
8437
8438           goto unknown;
8439
8440         case 'p':
8441           if (name[1] == 'r' &&
8442               name[2] == 'i' &&
8443               name[3] == 'n' &&
8444               name[4] == 't' &&
8445               name[5] == 'f')
8446           {                                       /* printf     */
8447             return KEY_printf;
8448           }
8449
8450           goto unknown;
8451
8452         case 'r':
8453           switch (name[1])
8454           {
8455             case 'e':
8456               switch (name[2])
8457               {
8458                 case 'n':
8459                   if (name[3] == 'a' &&
8460                       name[4] == 'm' &&
8461                       name[5] == 'e')
8462                   {                               /* rename     */
8463                     return -KEY_rename;
8464                   }
8465
8466                   goto unknown;
8467
8468                 case 't':
8469                   if (name[3] == 'u' &&
8470                       name[4] == 'r' &&
8471                       name[5] == 'n')
8472                   {                               /* return     */
8473                     return KEY_return;
8474                   }
8475
8476                   goto unknown;
8477
8478                 default:
8479                   goto unknown;
8480               }
8481
8482             case 'i':
8483               if (name[2] == 'n' &&
8484                   name[3] == 'd' &&
8485                   name[4] == 'e' &&
8486                   name[5] == 'x')
8487               {                                   /* rindex     */
8488                 return -KEY_rindex;
8489               }
8490
8491               goto unknown;
8492
8493             default:
8494               goto unknown;
8495           }
8496
8497         case 's':
8498           switch (name[1])
8499           {
8500             case 'c':
8501               if (name[2] == 'a' &&
8502                   name[3] == 'l' &&
8503                   name[4] == 'a' &&
8504                   name[5] == 'r')
8505               {                                   /* scalar     */
8506                 return KEY_scalar;
8507               }
8508
8509               goto unknown;
8510
8511             case 'e':
8512               switch (name[2])
8513               {
8514                 case 'l':
8515                   if (name[3] == 'e' &&
8516                       name[4] == 'c' &&
8517                       name[5] == 't')
8518                   {                               /* select     */
8519                     return -KEY_select;
8520                   }
8521
8522                   goto unknown;
8523
8524                 case 'm':
8525                   switch (name[3])
8526                   {
8527                     case 'c':
8528                       if (name[4] == 't' &&
8529                           name[5] == 'l')
8530                       {                           /* semctl     */
8531                         return -KEY_semctl;
8532                       }
8533
8534                       goto unknown;
8535
8536                     case 'g':
8537                       if (name[4] == 'e' &&
8538                           name[5] == 't')
8539                       {                           /* semget     */
8540                         return -KEY_semget;
8541                       }
8542
8543                       goto unknown;
8544
8545                     default:
8546                       goto unknown;
8547                   }
8548
8549                 default:
8550                   goto unknown;
8551               }
8552
8553             case 'h':
8554               if (name[2] == 'm')
8555               {
8556                 switch (name[3])
8557                 {
8558                   case 'c':
8559                     if (name[4] == 't' &&
8560                         name[5] == 'l')
8561                     {                             /* shmctl     */
8562                       return -KEY_shmctl;
8563                     }
8564
8565                     goto unknown;
8566
8567                   case 'g':
8568                     if (name[4] == 'e' &&
8569                         name[5] == 't')
8570                     {                             /* shmget     */
8571                       return -KEY_shmget;
8572                     }
8573
8574                     goto unknown;
8575
8576                   default:
8577                     goto unknown;
8578                 }
8579               }
8580
8581               goto unknown;
8582
8583             case 'o':
8584               if (name[2] == 'c' &&
8585                   name[3] == 'k' &&
8586                   name[4] == 'e' &&
8587                   name[5] == 't')
8588               {                                   /* socket     */
8589                 return -KEY_socket;
8590               }
8591
8592               goto unknown;
8593
8594             case 'p':
8595               if (name[2] == 'l' &&
8596                   name[3] == 'i' &&
8597                   name[4] == 'c' &&
8598                   name[5] == 'e')
8599               {                                   /* splice     */
8600                 return -KEY_splice;
8601               }
8602
8603               goto unknown;
8604
8605             case 'u':
8606               if (name[2] == 'b' &&
8607                   name[3] == 's' &&
8608                   name[4] == 't' &&
8609                   name[5] == 'r')
8610               {                                   /* substr     */
8611                 return -KEY_substr;
8612               }
8613
8614               goto unknown;
8615
8616             case 'y':
8617               if (name[2] == 's' &&
8618                   name[3] == 't' &&
8619                   name[4] == 'e' &&
8620                   name[5] == 'm')
8621               {                                   /* system     */
8622                 return -KEY_system;
8623               }
8624
8625               goto unknown;
8626
8627             default:
8628               goto unknown;
8629           }
8630
8631         case 'u':
8632           if (name[1] == 'n')
8633           {
8634             switch (name[2])
8635             {
8636               case 'l':
8637                 switch (name[3])
8638                 {
8639                   case 'e':
8640                     if (name[4] == 's' &&
8641                         name[5] == 's')
8642                     {                             /* unless     */
8643                       return KEY_unless;
8644                     }
8645
8646                     goto unknown;
8647
8648                   case 'i':
8649                     if (name[4] == 'n' &&
8650                         name[5] == 'k')
8651                     {                             /* unlink     */
8652                       return -KEY_unlink;
8653                     }
8654
8655                     goto unknown;
8656
8657                   default:
8658                     goto unknown;
8659                 }
8660
8661               case 'p':
8662                 if (name[3] == 'a' &&
8663                     name[4] == 'c' &&
8664                     name[5] == 'k')
8665                 {                                 /* unpack     */
8666                   return -KEY_unpack;
8667                 }
8668
8669                 goto unknown;
8670
8671               default:
8672                 goto unknown;
8673             }
8674           }
8675
8676           goto unknown;
8677
8678         case 'v':
8679           if (name[1] == 'a' &&
8680               name[2] == 'l' &&
8681               name[3] == 'u' &&
8682               name[4] == 'e' &&
8683               name[5] == 's')
8684           {                                       /* values     */
8685             return -KEY_values;
8686           }
8687
8688           goto unknown;
8689
8690         default:
8691           goto unknown;
8692       }
8693
8694     case 7: /* 29 tokens of length 7 */
8695       switch (name[0])
8696       {
8697         case 'D':
8698           if (name[1] == 'E' &&
8699               name[2] == 'S' &&
8700               name[3] == 'T' &&
8701               name[4] == 'R' &&
8702               name[5] == 'O' &&
8703               name[6] == 'Y')
8704           {                                       /* DESTROY    */
8705             return KEY_DESTROY;
8706           }
8707
8708           goto unknown;
8709
8710         case '_':
8711           if (name[1] == '_' &&
8712               name[2] == 'E' &&
8713               name[3] == 'N' &&
8714               name[4] == 'D' &&
8715               name[5] == '_' &&
8716               name[6] == '_')
8717           {                                       /* __END__    */
8718             return KEY___END__;
8719           }
8720
8721           goto unknown;
8722
8723         case 'b':
8724           if (name[1] == 'i' &&
8725               name[2] == 'n' &&
8726               name[3] == 'm' &&
8727               name[4] == 'o' &&
8728               name[5] == 'd' &&
8729               name[6] == 'e')
8730           {                                       /* binmode    */
8731             return -KEY_binmode;
8732           }
8733
8734           goto unknown;
8735
8736         case 'c':
8737           if (name[1] == 'o' &&
8738               name[2] == 'n' &&
8739               name[3] == 'n' &&
8740               name[4] == 'e' &&
8741               name[5] == 'c' &&
8742               name[6] == 't')
8743           {                                       /* connect    */
8744             return -KEY_connect;
8745           }
8746
8747           goto unknown;
8748
8749         case 'd':
8750           switch (name[1])
8751           {
8752             case 'b':
8753               if (name[2] == 'm' &&
8754                   name[3] == 'o' &&
8755                   name[4] == 'p' &&
8756                   name[5] == 'e' &&
8757                   name[6] == 'n')
8758               {                                   /* dbmopen    */
8759                 return -KEY_dbmopen;
8760               }
8761
8762               goto unknown;
8763
8764             case 'e':
8765               if (name[2] == 'f')
8766               {
8767                 switch (name[3])
8768                 {
8769                   case 'a':
8770                     if (name[4] == 'u' &&
8771                         name[5] == 'l' &&
8772                         name[6] == 't')
8773                     {                             /* default    */
8774                       return (FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
8775                     }
8776
8777                     goto unknown;
8778
8779                   case 'i':
8780                     if (name[4] == 'n' &&
8781                   name[5] == 'e' &&
8782                   name[6] == 'd')
8783               {                                   /* defined    */
8784                 return KEY_defined;
8785               }
8786
8787               goto unknown;
8788
8789             default:
8790               goto unknown;
8791           }
8792               }
8793
8794               goto unknown;
8795
8796             default:
8797               goto unknown;
8798           }
8799
8800         case 'f':
8801           if (name[1] == 'o' &&
8802               name[2] == 'r' &&
8803               name[3] == 'e' &&
8804               name[4] == 'a' &&
8805               name[5] == 'c' &&
8806               name[6] == 'h')
8807           {                                       /* foreach    */
8808             return KEY_foreach;
8809           }
8810
8811           goto unknown;
8812
8813         case 'g':
8814           if (name[1] == 'e' &&
8815               name[2] == 't' &&
8816               name[3] == 'p')
8817           {
8818             switch (name[4])
8819             {
8820               case 'g':
8821                 if (name[5] == 'r' &&
8822                     name[6] == 'p')
8823                 {                                 /* getpgrp    */
8824                   return -KEY_getpgrp;
8825                 }
8826
8827                 goto unknown;
8828
8829               case 'p':
8830                 if (name[5] == 'i' &&
8831                     name[6] == 'd')
8832                 {                                 /* getppid    */
8833                   return -KEY_getppid;
8834                 }
8835
8836                 goto unknown;
8837
8838               default:
8839                 goto unknown;
8840             }
8841           }
8842
8843           goto unknown;
8844
8845         case 'l':
8846           if (name[1] == 'c' &&
8847               name[2] == 'f' &&
8848               name[3] == 'i' &&
8849               name[4] == 'r' &&
8850               name[5] == 's' &&
8851               name[6] == 't')
8852           {                                       /* lcfirst    */
8853             return -KEY_lcfirst;
8854           }
8855
8856           goto unknown;
8857
8858         case 'o':
8859           if (name[1] == 'p' &&
8860               name[2] == 'e' &&
8861               name[3] == 'n' &&
8862               name[4] == 'd' &&
8863               name[5] == 'i' &&
8864               name[6] == 'r')
8865           {                                       /* opendir    */
8866             return -KEY_opendir;
8867           }
8868
8869           goto unknown;
8870
8871         case 'p':
8872           if (name[1] == 'a' &&
8873               name[2] == 'c' &&
8874               name[3] == 'k' &&
8875               name[4] == 'a' &&
8876               name[5] == 'g' &&
8877               name[6] == 'e')
8878           {                                       /* package    */
8879             return KEY_package;
8880           }
8881
8882           goto unknown;
8883
8884         case 'r':
8885           if (name[1] == 'e')
8886           {
8887             switch (name[2])
8888             {
8889               case 'a':
8890                 if (name[3] == 'd' &&
8891                     name[4] == 'd' &&
8892                     name[5] == 'i' &&
8893                     name[6] == 'r')
8894                 {                                 /* readdir    */
8895                   return -KEY_readdir;
8896                 }
8897
8898                 goto unknown;
8899
8900               case 'q':
8901                 if (name[3] == 'u' &&
8902                     name[4] == 'i' &&
8903                     name[5] == 'r' &&
8904                     name[6] == 'e')
8905                 {                                 /* require    */
8906                   return KEY_require;
8907                 }
8908
8909                 goto unknown;
8910
8911               case 'v':
8912                 if (name[3] == 'e' &&
8913                     name[4] == 'r' &&
8914                     name[5] == 's' &&
8915                     name[6] == 'e')
8916                 {                                 /* reverse    */
8917                   return -KEY_reverse;
8918                 }
8919
8920                 goto unknown;
8921
8922               default:
8923                 goto unknown;
8924             }
8925           }
8926
8927           goto unknown;
8928
8929         case 's':
8930           switch (name[1])
8931           {
8932             case 'e':
8933               switch (name[2])
8934               {
8935                 case 'e':
8936                   if (name[3] == 'k' &&
8937                       name[4] == 'd' &&
8938                       name[5] == 'i' &&
8939                       name[6] == 'r')
8940                   {                               /* seekdir    */
8941                     return -KEY_seekdir;
8942                   }
8943
8944                   goto unknown;
8945
8946                 case 't':
8947                   if (name[3] == 'p' &&
8948                       name[4] == 'g' &&
8949                       name[5] == 'r' &&
8950                       name[6] == 'p')
8951                   {                               /* setpgrp    */
8952                     return -KEY_setpgrp;
8953                   }
8954
8955                   goto unknown;
8956
8957                 default:
8958                   goto unknown;
8959               }
8960
8961             case 'h':
8962               if (name[2] == 'm' &&
8963                   name[3] == 'r' &&
8964                   name[4] == 'e' &&
8965                   name[5] == 'a' &&
8966                   name[6] == 'd')
8967               {                                   /* shmread    */
8968                 return -KEY_shmread;
8969               }
8970
8971               goto unknown;
8972
8973             case 'p':
8974               if (name[2] == 'r' &&
8975                   name[3] == 'i' &&
8976                   name[4] == 'n' &&
8977                   name[5] == 't' &&
8978                   name[6] == 'f')
8979               {                                   /* sprintf    */
8980                 return -KEY_sprintf;
8981               }
8982
8983               goto unknown;
8984
8985             case 'y':
8986               switch (name[2])
8987               {
8988                 case 'm':
8989                   if (name[3] == 'l' &&
8990                       name[4] == 'i' &&
8991                       name[5] == 'n' &&
8992                       name[6] == 'k')
8993                   {                               /* symlink    */
8994                     return -KEY_symlink;
8995                   }
8996
8997                   goto unknown;
8998
8999                 case 's':
9000                   switch (name[3])
9001                   {
9002                     case 'c':
9003                       if (name[4] == 'a' &&
9004                           name[5] == 'l' &&
9005                           name[6] == 'l')
9006                       {                           /* syscall    */
9007                         return -KEY_syscall;
9008                       }
9009
9010                       goto unknown;
9011
9012                     case 'o':
9013                       if (name[4] == 'p' &&
9014                           name[5] == 'e' &&
9015                           name[6] == 'n')
9016                       {                           /* sysopen    */
9017                         return -KEY_sysopen;
9018                       }
9019
9020                       goto unknown;
9021
9022                     case 'r':
9023                       if (name[4] == 'e' &&
9024                           name[5] == 'a' &&
9025                           name[6] == 'd')
9026                       {                           /* sysread    */
9027                         return -KEY_sysread;
9028                       }
9029
9030                       goto unknown;
9031
9032                     case 's':
9033                       if (name[4] == 'e' &&
9034                           name[5] == 'e' &&
9035                           name[6] == 'k')
9036                       {                           /* sysseek    */
9037                         return -KEY_sysseek;
9038                       }
9039
9040                       goto unknown;
9041
9042                     default:
9043                       goto unknown;
9044                   }
9045
9046                 default:
9047                   goto unknown;
9048               }
9049
9050             default:
9051               goto unknown;
9052           }
9053
9054         case 't':
9055           if (name[1] == 'e' &&
9056               name[2] == 'l' &&
9057               name[3] == 'l' &&
9058               name[4] == 'd' &&
9059               name[5] == 'i' &&
9060               name[6] == 'r')
9061           {                                       /* telldir    */
9062             return -KEY_telldir;
9063           }
9064
9065           goto unknown;
9066
9067         case 'u':
9068           switch (name[1])
9069           {
9070             case 'c':
9071               if (name[2] == 'f' &&
9072                   name[3] == 'i' &&
9073                   name[4] == 'r' &&
9074                   name[5] == 's' &&
9075                   name[6] == 't')
9076               {                                   /* ucfirst    */
9077                 return -KEY_ucfirst;
9078               }
9079
9080               goto unknown;
9081
9082             case 'n':
9083               if (name[2] == 's' &&
9084                   name[3] == 'h' &&
9085                   name[4] == 'i' &&
9086                   name[5] == 'f' &&
9087                   name[6] == 't')
9088               {                                   /* unshift    */
9089                 return -KEY_unshift;
9090               }
9091
9092               goto unknown;
9093
9094             default:
9095               goto unknown;
9096           }
9097
9098         case 'w':
9099           if (name[1] == 'a' &&
9100               name[2] == 'i' &&
9101               name[3] == 't' &&
9102               name[4] == 'p' &&
9103               name[5] == 'i' &&
9104               name[6] == 'd')
9105           {                                       /* waitpid    */
9106             return -KEY_waitpid;
9107           }
9108
9109           goto unknown;
9110
9111         default:
9112           goto unknown;
9113       }
9114
9115     case 8: /* 26 tokens of length 8 */
9116       switch (name[0])
9117       {
9118         case 'A':
9119           if (name[1] == 'U' &&
9120               name[2] == 'T' &&
9121               name[3] == 'O' &&
9122               name[4] == 'L' &&
9123               name[5] == 'O' &&
9124               name[6] == 'A' &&
9125               name[7] == 'D')
9126           {                                       /* AUTOLOAD   */
9127             return KEY_AUTOLOAD;
9128           }
9129
9130           goto unknown;
9131
9132         case '_':
9133           if (name[1] == '_')
9134           {
9135             switch (name[2])
9136             {
9137               case 'D':
9138                 if (name[3] == 'A' &&
9139                     name[4] == 'T' &&
9140                     name[5] == 'A' &&
9141                     name[6] == '_' &&
9142                     name[7] == '_')
9143                 {                                 /* __DATA__   */
9144                   return KEY___DATA__;
9145                 }
9146
9147                 goto unknown;
9148
9149               case 'F':
9150                 if (name[3] == 'I' &&
9151                     name[4] == 'L' &&
9152                     name[5] == 'E' &&
9153                     name[6] == '_' &&
9154                     name[7] == '_')
9155                 {                                 /* __FILE__   */
9156                   return -KEY___FILE__;
9157                 }
9158
9159                 goto unknown;
9160
9161               case 'L':
9162                 if (name[3] == 'I' &&
9163                     name[4] == 'N' &&
9164                     name[5] == 'E' &&
9165                     name[6] == '_' &&
9166                     name[7] == '_')
9167                 {                                 /* __LINE__   */
9168                   return -KEY___LINE__;
9169                 }
9170
9171                 goto unknown;
9172
9173               default:
9174                 goto unknown;
9175             }
9176           }
9177
9178           goto unknown;
9179
9180         case 'c':
9181           switch (name[1])
9182           {
9183             case 'l':
9184               if (name[2] == 'o' &&
9185                   name[3] == 's' &&
9186                   name[4] == 'e' &&
9187                   name[5] == 'd' &&
9188                   name[6] == 'i' &&
9189                   name[7] == 'r')
9190               {                                   /* closedir   */
9191                 return -KEY_closedir;
9192               }
9193
9194               goto unknown;
9195
9196             case 'o':
9197               if (name[2] == 'n' &&
9198                   name[3] == 't' &&
9199                   name[4] == 'i' &&
9200                   name[5] == 'n' &&
9201                   name[6] == 'u' &&
9202                   name[7] == 'e')
9203               {                                   /* continue   */
9204                 return -KEY_continue;
9205               }
9206
9207               goto unknown;
9208
9209             default:
9210               goto unknown;
9211           }
9212
9213         case 'd':
9214           if (name[1] == 'b' &&
9215               name[2] == 'm' &&
9216               name[3] == 'c' &&
9217               name[4] == 'l' &&
9218               name[5] == 'o' &&
9219               name[6] == 's' &&
9220               name[7] == 'e')
9221           {                                       /* dbmclose   */
9222             return -KEY_dbmclose;
9223           }
9224
9225           goto unknown;
9226
9227         case 'e':
9228           if (name[1] == 'n' &&
9229               name[2] == 'd')
9230           {
9231             switch (name[3])
9232             {
9233               case 'g':
9234                 if (name[4] == 'r' &&
9235                     name[5] == 'e' &&
9236                     name[6] == 'n' &&
9237                     name[7] == 't')
9238                 {                                 /* endgrent   */
9239                   return -KEY_endgrent;
9240                 }
9241
9242                 goto unknown;
9243
9244               case 'p':
9245                 if (name[4] == 'w' &&
9246                     name[5] == 'e' &&
9247                     name[6] == 'n' &&
9248                     name[7] == 't')
9249                 {                                 /* endpwent   */
9250                   return -KEY_endpwent;
9251                 }
9252
9253                 goto unknown;
9254
9255               default:
9256                 goto unknown;
9257             }
9258           }
9259
9260           goto unknown;
9261
9262         case 'f':
9263           if (name[1] == 'o' &&
9264               name[2] == 'r' &&
9265               name[3] == 'm' &&
9266               name[4] == 'l' &&
9267               name[5] == 'i' &&
9268               name[6] == 'n' &&
9269               name[7] == 'e')
9270           {                                       /* formline   */
9271             return -KEY_formline;
9272           }
9273
9274           goto unknown;
9275
9276         case 'g':
9277           if (name[1] == 'e' &&
9278               name[2] == 't')
9279           {
9280             switch (name[3])
9281             {
9282               case 'g':
9283                 if (name[4] == 'r')
9284                 {
9285                   switch (name[5])
9286                   {
9287                     case 'e':
9288                       if (name[6] == 'n' &&
9289                           name[7] == 't')
9290                       {                           /* getgrent   */
9291                         return -KEY_getgrent;
9292                       }
9293
9294                       goto unknown;
9295
9296                     case 'g':
9297                       if (name[6] == 'i' &&
9298                           name[7] == 'd')
9299                       {                           /* getgrgid   */
9300                         return -KEY_getgrgid;
9301                       }
9302
9303                       goto unknown;
9304
9305                     case 'n':
9306                       if (name[6] == 'a' &&
9307                           name[7] == 'm')
9308                       {                           /* getgrnam   */
9309                         return -KEY_getgrnam;
9310                       }
9311
9312                       goto unknown;
9313
9314                     default:
9315                       goto unknown;
9316                   }
9317                 }
9318
9319                 goto unknown;
9320
9321               case 'l':
9322                 if (name[4] == 'o' &&
9323                     name[5] == 'g' &&
9324                     name[6] == 'i' &&
9325                     name[7] == 'n')
9326                 {                                 /* getlogin   */
9327                   return -KEY_getlogin;
9328                 }
9329
9330                 goto unknown;
9331
9332               case 'p':
9333                 if (name[4] == 'w')
9334                 {
9335                   switch (name[5])
9336                   {
9337                     case 'e':
9338                       if (name[6] == 'n' &&
9339                           name[7] == 't')
9340                       {                           /* getpwent   */
9341                         return -KEY_getpwent;
9342                       }
9343
9344                       goto unknown;
9345
9346                     case 'n':
9347                       if (name[6] == 'a' &&
9348                           name[7] == 'm')
9349                       {                           /* getpwnam   */
9350                         return -KEY_getpwnam;
9351                       }
9352
9353                       goto unknown;
9354
9355                     case 'u':
9356                       if (name[6] == 'i' &&
9357                           name[7] == 'd')
9358                       {                           /* getpwuid   */
9359                         return -KEY_getpwuid;
9360                       }
9361
9362                       goto unknown;
9363
9364                     default:
9365                       goto unknown;
9366                   }
9367                 }
9368
9369                 goto unknown;
9370
9371               default:
9372                 goto unknown;
9373             }
9374           }
9375
9376           goto unknown;
9377
9378         case 'r':
9379           if (name[1] == 'e' &&
9380               name[2] == 'a' &&
9381               name[3] == 'd')
9382           {
9383             switch (name[4])
9384             {
9385               case 'l':
9386                 if (name[5] == 'i' &&
9387                     name[6] == 'n')
9388                 {
9389                   switch (name[7])
9390                   {
9391                     case 'e':
9392                       {                           /* readline   */
9393                         return -KEY_readline;
9394                       }
9395
9396                     case 'k':
9397                       {                           /* readlink   */
9398                         return -KEY_readlink;
9399                       }
9400
9401                     default:
9402                       goto unknown;
9403                   }
9404                 }
9405
9406                 goto unknown;
9407
9408               case 'p':
9409                 if (name[5] == 'i' &&
9410                     name[6] == 'p' &&
9411                     name[7] == 'e')
9412                 {                                 /* readpipe   */
9413                   return -KEY_readpipe;
9414                 }
9415
9416                 goto unknown;
9417
9418               default:
9419                 goto unknown;
9420             }
9421           }
9422
9423           goto unknown;
9424
9425         case 's':
9426           switch (name[1])
9427           {
9428             case 'e':
9429               if (name[2] == 't')
9430               {
9431                 switch (name[3])
9432                 {
9433                   case 'g':
9434                     if (name[4] == 'r' &&
9435                         name[5] == 'e' &&
9436                         name[6] == 'n' &&
9437                         name[7] == 't')
9438                     {                             /* setgrent   */
9439                       return -KEY_setgrent;
9440                     }
9441
9442                     goto unknown;
9443
9444                   case 'p':
9445                     if (name[4] == 'w' &&
9446                         name[5] == 'e' &&
9447                         name[6] == 'n' &&
9448                         name[7] == 't')
9449                     {                             /* setpwent   */
9450                       return -KEY_setpwent;
9451                     }
9452
9453                     goto unknown;
9454
9455                   default:
9456                     goto unknown;
9457                 }
9458               }
9459
9460               goto unknown;
9461
9462             case 'h':
9463               switch (name[2])
9464               {
9465                 case 'm':
9466                   if (name[3] == 'w' &&
9467                       name[4] == 'r' &&
9468                       name[5] == 'i' &&
9469                       name[6] == 't' &&
9470                       name[7] == 'e')
9471                   {                               /* shmwrite   */
9472                     return -KEY_shmwrite;
9473                   }
9474
9475                   goto unknown;
9476
9477                 case 'u':
9478                   if (name[3] == 't' &&
9479                       name[4] == 'd' &&
9480                       name[5] == 'o' &&
9481                       name[6] == 'w' &&
9482                       name[7] == 'n')
9483                   {                               /* shutdown   */
9484                     return -KEY_shutdown;
9485                   }
9486
9487                   goto unknown;
9488
9489                 default:
9490                   goto unknown;
9491               }
9492
9493             case 'y':
9494               if (name[2] == 's' &&
9495                   name[3] == 'w' &&
9496                   name[4] == 'r' &&
9497                   name[5] == 'i' &&
9498                   name[6] == 't' &&
9499                   name[7] == 'e')
9500               {                                   /* syswrite   */
9501                 return -KEY_syswrite;
9502               }
9503
9504               goto unknown;
9505
9506             default:
9507               goto unknown;
9508           }
9509
9510         case 't':
9511           if (name[1] == 'r' &&
9512               name[2] == 'u' &&
9513               name[3] == 'n' &&
9514               name[4] == 'c' &&
9515               name[5] == 'a' &&
9516               name[6] == 't' &&
9517               name[7] == 'e')
9518           {                                       /* truncate   */
9519             return -KEY_truncate;
9520           }
9521
9522           goto unknown;
9523
9524         default:
9525           goto unknown;
9526       }
9527
9528     case 9: /* 8 tokens of length 9 */
9529       switch (name[0])
9530       {
9531         case 'e':
9532           if (name[1] == 'n' &&
9533               name[2] == 'd' &&
9534               name[3] == 'n' &&
9535               name[4] == 'e' &&
9536               name[5] == 't' &&
9537               name[6] == 'e' &&
9538               name[7] == 'n' &&
9539               name[8] == 't')
9540           {                                       /* endnetent  */
9541             return -KEY_endnetent;
9542           }
9543
9544           goto unknown;
9545
9546         case 'g':
9547           if (name[1] == 'e' &&
9548               name[2] == 't' &&
9549               name[3] == 'n' &&
9550               name[4] == 'e' &&
9551               name[5] == 't' &&
9552               name[6] == 'e' &&
9553               name[7] == 'n' &&
9554               name[8] == 't')
9555           {                                       /* getnetent  */
9556             return -KEY_getnetent;
9557           }
9558
9559           goto unknown;
9560
9561         case 'l':
9562           if (name[1] == 'o' &&
9563               name[2] == 'c' &&
9564               name[3] == 'a' &&
9565               name[4] == 'l' &&
9566               name[5] == 't' &&
9567               name[6] == 'i' &&
9568               name[7] == 'm' &&
9569               name[8] == 'e')
9570           {                                       /* localtime  */
9571             return -KEY_localtime;
9572           }
9573
9574           goto unknown;
9575
9576         case 'p':
9577           if (name[1] == 'r' &&
9578               name[2] == 'o' &&
9579               name[3] == 't' &&
9580               name[4] == 'o' &&
9581               name[5] == 't' &&
9582               name[6] == 'y' &&
9583               name[7] == 'p' &&
9584               name[8] == 'e')
9585           {                                       /* prototype  */
9586             return KEY_prototype;
9587           }
9588
9589           goto unknown;
9590
9591         case 'q':
9592           if (name[1] == 'u' &&
9593               name[2] == 'o' &&
9594               name[3] == 't' &&
9595               name[4] == 'e' &&
9596               name[5] == 'm' &&
9597               name[6] == 'e' &&
9598               name[7] == 't' &&
9599               name[8] == 'a')
9600           {                                       /* quotemeta  */
9601             return -KEY_quotemeta;
9602           }
9603
9604           goto unknown;
9605
9606         case 'r':
9607           if (name[1] == 'e' &&
9608               name[2] == 'w' &&
9609               name[3] == 'i' &&
9610               name[4] == 'n' &&
9611               name[5] == 'd' &&
9612               name[6] == 'd' &&
9613               name[7] == 'i' &&
9614               name[8] == 'r')
9615           {                                       /* rewinddir  */
9616             return -KEY_rewinddir;
9617           }
9618
9619           goto unknown;
9620
9621         case 's':
9622           if (name[1] == 'e' &&
9623               name[2] == 't' &&
9624               name[3] == 'n' &&
9625               name[4] == 'e' &&
9626               name[5] == 't' &&
9627               name[6] == 'e' &&
9628               name[7] == 'n' &&
9629               name[8] == 't')
9630           {                                       /* setnetent  */
9631             return -KEY_setnetent;
9632           }
9633
9634           goto unknown;
9635
9636         case 'w':
9637           if (name[1] == 'a' &&
9638               name[2] == 'n' &&
9639               name[3] == 't' &&
9640               name[4] == 'a' &&
9641               name[5] == 'r' &&
9642               name[6] == 'r' &&
9643               name[7] == 'a' &&
9644               name[8] == 'y')
9645           {                                       /* wantarray  */
9646             return -KEY_wantarray;
9647           }
9648
9649           goto unknown;
9650
9651         default:
9652           goto unknown;
9653       }
9654
9655     case 10: /* 9 tokens of length 10 */
9656       switch (name[0])
9657       {
9658         case 'e':
9659           if (name[1] == 'n' &&
9660               name[2] == 'd')
9661           {
9662             switch (name[3])
9663             {
9664               case 'h':
9665                 if (name[4] == 'o' &&
9666                     name[5] == 's' &&
9667                     name[6] == 't' &&
9668                     name[7] == 'e' &&
9669                     name[8] == 'n' &&
9670                     name[9] == 't')
9671                 {                                 /* endhostent */
9672                   return -KEY_endhostent;
9673                 }
9674
9675                 goto unknown;
9676
9677               case 's':
9678                 if (name[4] == 'e' &&
9679                     name[5] == 'r' &&
9680                     name[6] == 'v' &&
9681                     name[7] == 'e' &&
9682                     name[8] == 'n' &&
9683                     name[9] == 't')
9684                 {                                 /* endservent */
9685                   return -KEY_endservent;
9686                 }
9687
9688                 goto unknown;
9689
9690               default:
9691                 goto unknown;
9692             }
9693           }
9694
9695           goto unknown;
9696
9697         case 'g':
9698           if (name[1] == 'e' &&
9699               name[2] == 't')
9700           {
9701             switch (name[3])
9702             {
9703               case 'h':
9704                 if (name[4] == 'o' &&
9705                     name[5] == 's' &&
9706                     name[6] == 't' &&
9707                     name[7] == 'e' &&
9708                     name[8] == 'n' &&
9709                     name[9] == 't')
9710                 {                                 /* gethostent */
9711                   return -KEY_gethostent;
9712                 }
9713
9714                 goto unknown;
9715
9716               case 's':
9717                 switch (name[4])
9718                 {
9719                   case 'e':
9720                     if (name[5] == 'r' &&
9721                         name[6] == 'v' &&
9722                         name[7] == 'e' &&
9723                         name[8] == 'n' &&
9724                         name[9] == 't')
9725                     {                             /* getservent */
9726                       return -KEY_getservent;
9727                     }
9728
9729                     goto unknown;
9730
9731                   case 'o':
9732                     if (name[5] == 'c' &&
9733                         name[6] == 'k' &&
9734                         name[7] == 'o' &&
9735                         name[8] == 'p' &&
9736                         name[9] == 't')
9737                     {                             /* getsockopt */
9738                       return -KEY_getsockopt;
9739                     }
9740
9741                     goto unknown;
9742
9743                   default:
9744                     goto unknown;
9745                 }
9746
9747               default:
9748                 goto unknown;
9749             }
9750           }
9751
9752           goto unknown;
9753
9754         case 's':
9755           switch (name[1])
9756           {
9757             case 'e':
9758               if (name[2] == 't')
9759               {
9760                 switch (name[3])
9761                 {
9762                   case 'h':
9763                     if (name[4] == 'o' &&
9764                         name[5] == 's' &&
9765                         name[6] == 't' &&
9766                         name[7] == 'e' &&
9767                         name[8] == 'n' &&
9768                         name[9] == 't')
9769                     {                             /* sethostent */
9770                       return -KEY_sethostent;
9771                     }
9772
9773                     goto unknown;
9774
9775                   case 's':
9776                     switch (name[4])
9777                     {
9778                       case 'e':
9779                         if (name[5] == 'r' &&
9780                             name[6] == 'v' &&
9781                             name[7] == 'e' &&
9782                             name[8] == 'n' &&
9783                             name[9] == 't')
9784                         {                         /* setservent */
9785                           return -KEY_setservent;
9786                         }
9787
9788                         goto unknown;
9789
9790                       case 'o':
9791                         if (name[5] == 'c' &&
9792                             name[6] == 'k' &&
9793                             name[7] == 'o' &&
9794                             name[8] == 'p' &&
9795                             name[9] == 't')
9796                         {                         /* setsockopt */
9797                           return -KEY_setsockopt;
9798                         }
9799
9800                         goto unknown;
9801
9802                       default:
9803                         goto unknown;
9804                     }
9805
9806                   default:
9807                     goto unknown;
9808                 }
9809               }
9810
9811               goto unknown;
9812
9813             case 'o':
9814               if (name[2] == 'c' &&
9815                   name[3] == 'k' &&
9816                   name[4] == 'e' &&
9817                   name[5] == 't' &&
9818                   name[6] == 'p' &&
9819                   name[7] == 'a' &&
9820                   name[8] == 'i' &&
9821                   name[9] == 'r')
9822               {                                   /* socketpair */
9823                 return -KEY_socketpair;
9824               }
9825
9826               goto unknown;
9827
9828             default:
9829               goto unknown;
9830           }
9831
9832         default:
9833           goto unknown;
9834       }
9835
9836     case 11: /* 8 tokens of length 11 */
9837       switch (name[0])
9838       {
9839         case '_':
9840           if (name[1] == '_' &&
9841               name[2] == 'P' &&
9842               name[3] == 'A' &&
9843               name[4] == 'C' &&
9844               name[5] == 'K' &&
9845               name[6] == 'A' &&
9846               name[7] == 'G' &&
9847               name[8] == 'E' &&
9848               name[9] == '_' &&
9849               name[10] == '_')
9850           {                                       /* __PACKAGE__ */
9851             return -KEY___PACKAGE__;
9852           }
9853
9854           goto unknown;
9855
9856         case 'e':
9857           if (name[1] == 'n' &&
9858               name[2] == 'd' &&
9859               name[3] == 'p' &&
9860               name[4] == 'r' &&
9861               name[5] == 'o' &&
9862               name[6] == 't' &&
9863               name[7] == 'o' &&
9864               name[8] == 'e' &&
9865               name[9] == 'n' &&
9866               name[10] == 't')
9867           {                                       /* endprotoent */
9868             return -KEY_endprotoent;
9869           }
9870
9871           goto unknown;
9872
9873         case 'g':
9874           if (name[1] == 'e' &&
9875               name[2] == 't')
9876           {
9877             switch (name[3])
9878             {
9879               case 'p':
9880                 switch (name[4])
9881                 {
9882                   case 'e':
9883                     if (name[5] == 'e' &&
9884                         name[6] == 'r' &&
9885                         name[7] == 'n' &&
9886                         name[8] == 'a' &&
9887                         name[9] == 'm' &&
9888                         name[10] == 'e')
9889                     {                             /* getpeername */
9890                       return -KEY_getpeername;
9891                     }
9892
9893                     goto unknown;
9894
9895                   case 'r':
9896                     switch (name[5])
9897                     {
9898                       case 'i':
9899                         if (name[6] == 'o' &&
9900                             name[7] == 'r' &&
9901                             name[8] == 'i' &&
9902                             name[9] == 't' &&
9903                             name[10] == 'y')
9904                         {                         /* getpriority */
9905                           return -KEY_getpriority;
9906                         }
9907
9908                         goto unknown;
9909
9910                       case 'o':
9911                         if (name[6] == 't' &&
9912                             name[7] == 'o' &&
9913                             name[8] == 'e' &&
9914                             name[9] == 'n' &&
9915                             name[10] == 't')
9916                         {                         /* getprotoent */
9917                           return -KEY_getprotoent;
9918                         }
9919
9920                         goto unknown;
9921
9922                       default:
9923                         goto unknown;
9924                     }
9925
9926                   default:
9927                     goto unknown;
9928                 }
9929
9930               case 's':
9931                 if (name[4] == 'o' &&
9932                     name[5] == 'c' &&
9933                     name[6] == 'k' &&
9934                     name[7] == 'n' &&
9935                     name[8] == 'a' &&
9936                     name[9] == 'm' &&
9937                     name[10] == 'e')
9938                 {                                 /* getsockname */
9939                   return -KEY_getsockname;
9940                 }
9941
9942                 goto unknown;
9943
9944               default:
9945                 goto unknown;
9946             }
9947           }
9948
9949           goto unknown;
9950
9951         case 's':
9952           if (name[1] == 'e' &&
9953               name[2] == 't' &&
9954               name[3] == 'p' &&
9955               name[4] == 'r')
9956           {
9957             switch (name[5])
9958             {
9959               case 'i':
9960                 if (name[6] == 'o' &&
9961                     name[7] == 'r' &&
9962                     name[8] == 'i' &&
9963                     name[9] == 't' &&
9964                     name[10] == 'y')
9965                 {                                 /* setpriority */
9966                   return -KEY_setpriority;
9967                 }
9968
9969                 goto unknown;
9970
9971               case 'o':
9972                 if (name[6] == 't' &&
9973                     name[7] == 'o' &&
9974                     name[8] == 'e' &&
9975                     name[9] == 'n' &&
9976                     name[10] == 't')
9977                 {                                 /* setprotoent */
9978                   return -KEY_setprotoent;
9979                 }
9980
9981                 goto unknown;
9982
9983               default:
9984                 goto unknown;
9985             }
9986           }
9987
9988           goto unknown;
9989
9990         default:
9991           goto unknown;
9992       }
9993
9994     case 12: /* 2 tokens of length 12 */
9995       if (name[0] == 'g' &&
9996           name[1] == 'e' &&
9997           name[2] == 't' &&
9998           name[3] == 'n' &&
9999           name[4] == 'e' &&
10000           name[5] == 't' &&
10001           name[6] == 'b' &&
10002           name[7] == 'y')
10003       {
10004         switch (name[8])
10005         {
10006           case 'a':
10007             if (name[9] == 'd' &&
10008                 name[10] == 'd' &&
10009                 name[11] == 'r')
10010             {                                     /* getnetbyaddr */
10011               return -KEY_getnetbyaddr;
10012             }
10013
10014             goto unknown;
10015
10016           case 'n':
10017             if (name[9] == 'a' &&
10018                 name[10] == 'm' &&
10019                 name[11] == 'e')
10020             {                                     /* getnetbyname */
10021               return -KEY_getnetbyname;
10022             }
10023
10024             goto unknown;
10025
10026           default:
10027             goto unknown;
10028         }
10029       }
10030
10031       goto unknown;
10032
10033     case 13: /* 4 tokens of length 13 */
10034       if (name[0] == 'g' &&
10035           name[1] == 'e' &&
10036           name[2] == 't')
10037       {
10038         switch (name[3])
10039         {
10040           case 'h':
10041             if (name[4] == 'o' &&
10042                 name[5] == 's' &&
10043                 name[6] == 't' &&
10044                 name[7] == 'b' &&
10045                 name[8] == 'y')
10046             {
10047               switch (name[9])
10048               {
10049                 case 'a':
10050                   if (name[10] == 'd' &&
10051                       name[11] == 'd' &&
10052                       name[12] == 'r')
10053                   {                               /* gethostbyaddr */
10054                     return -KEY_gethostbyaddr;
10055                   }
10056
10057                   goto unknown;
10058
10059                 case 'n':
10060                   if (name[10] == 'a' &&
10061                       name[11] == 'm' &&
10062                       name[12] == 'e')
10063                   {                               /* gethostbyname */
10064                     return -KEY_gethostbyname;
10065                   }
10066
10067                   goto unknown;
10068
10069                 default:
10070                   goto unknown;
10071               }
10072             }
10073
10074             goto unknown;
10075
10076           case 's':
10077             if (name[4] == 'e' &&
10078                 name[5] == 'r' &&
10079                 name[6] == 'v' &&
10080                 name[7] == 'b' &&
10081                 name[8] == 'y')
10082             {
10083               switch (name[9])
10084               {
10085                 case 'n':
10086                   if (name[10] == 'a' &&
10087                       name[11] == 'm' &&
10088                       name[12] == 'e')
10089                   {                               /* getservbyname */
10090                     return -KEY_getservbyname;
10091                   }
10092
10093                   goto unknown;
10094
10095                 case 'p':
10096                   if (name[10] == 'o' &&
10097                       name[11] == 'r' &&
10098                       name[12] == 't')
10099                   {                               /* getservbyport */
10100                     return -KEY_getservbyport;
10101                   }
10102
10103                   goto unknown;
10104
10105                 default:
10106                   goto unknown;
10107               }
10108             }
10109
10110             goto unknown;
10111
10112           default:
10113             goto unknown;
10114         }
10115       }
10116
10117       goto unknown;
10118
10119     case 14: /* 1 tokens of length 14 */
10120       if (name[0] == 'g' &&
10121           name[1] == 'e' &&
10122           name[2] == 't' &&
10123           name[3] == 'p' &&
10124           name[4] == 'r' &&
10125           name[5] == 'o' &&
10126           name[6] == 't' &&
10127           name[7] == 'o' &&
10128           name[8] == 'b' &&
10129           name[9] == 'y' &&
10130           name[10] == 'n' &&
10131           name[11] == 'a' &&
10132           name[12] == 'm' &&
10133           name[13] == 'e')
10134       {                                           /* getprotobyname */
10135         return -KEY_getprotobyname;
10136       }
10137
10138       goto unknown;
10139
10140     case 16: /* 1 tokens of length 16 */
10141       if (name[0] == 'g' &&
10142           name[1] == 'e' &&
10143           name[2] == 't' &&
10144           name[3] == 'p' &&
10145           name[4] == 'r' &&
10146           name[5] == 'o' &&
10147           name[6] == 't' &&
10148           name[7] == 'o' &&
10149           name[8] == 'b' &&
10150           name[9] == 'y' &&
10151           name[10] == 'n' &&
10152           name[11] == 'u' &&
10153           name[12] == 'm' &&
10154           name[13] == 'b' &&
10155           name[14] == 'e' &&
10156           name[15] == 'r')
10157       {                                           /* getprotobynumber */
10158         return -KEY_getprotobynumber;
10159       }
10160
10161       goto unknown;
10162
10163     default:
10164       goto unknown;
10165   }
10166
10167 unknown:
10168   return 0;
10169 }
10170
10171 STATIC void
10172 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10173 {
10174     dVAR;
10175
10176     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
10177         if (ckWARN(WARN_SYNTAX)) {
10178             int level = 1;
10179             const char *w;
10180             for (w = s+2; *w && level; w++) {
10181                 if (*w == '(')
10182                     ++level;
10183                 else if (*w == ')')
10184                     --level;
10185             }
10186             while (isSPACE(*w))
10187                 ++w;
10188             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
10189                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10190                             "%s (...) interpreted as function",name);
10191         }
10192     }
10193     while (s < PL_bufend && isSPACE(*s))
10194         s++;
10195     if (*s == '(')
10196         s++;
10197     while (s < PL_bufend && isSPACE(*s))
10198         s++;
10199     if (isIDFIRST_lazy_if(s,UTF)) {
10200         const char * const w = s++;
10201         while (isALNUM_lazy_if(s,UTF))
10202             s++;
10203         while (s < PL_bufend && isSPACE(*s))
10204             s++;
10205         if (*s == ',') {
10206             GV* gv;
10207             if (keyword(w, s - w))
10208                 return;
10209
10210             gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10211             if (gv && GvCVu(gv))
10212                 return;
10213             Perl_croak(aTHX_ "No comma allowed after %s", what);
10214         }
10215     }
10216 }
10217
10218 /* Either returns sv, or mortalizes sv and returns a new SV*.
10219    Best used as sv=new_constant(..., sv, ...).
10220    If s, pv are NULL, calls subroutine with one argument,
10221    and type is used with error messages only. */
10222
10223 STATIC SV *
10224 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
10225                const char *type)
10226 {
10227     dVAR; dSP;
10228     HV * const table = GvHV(PL_hintgv);          /* ^H */
10229     SV *res;
10230     SV **cvp;
10231     SV *cv, *typesv;
10232     const char *why1 = "", *why2 = "", *why3 = "";
10233
10234     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10235         SV *msg;
10236
10237         why2 = strEQ(key,"charnames")
10238                ? "(possibly a missing \"use charnames ...\")"
10239                : "";
10240         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10241                             (type ? type: "undef"), why2);
10242
10243         /* This is convoluted and evil ("goto considered harmful")
10244          * but I do not understand the intricacies of all the different
10245          * failure modes of %^H in here.  The goal here is to make
10246          * the most probable error message user-friendly. --jhi */
10247
10248         goto msgdone;
10249
10250     report:
10251         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10252                             (type ? type: "undef"), why1, why2, why3);
10253     msgdone:
10254         yyerror(SvPVX_const(msg));
10255         SvREFCNT_dec(msg);
10256         return sv;
10257     }
10258     cvp = hv_fetch(table, key, strlen(key), FALSE);
10259     if (!cvp || !SvOK(*cvp)) {
10260         why1 = "$^H{";
10261         why2 = key;
10262         why3 = "} is not defined";
10263         goto report;
10264     }
10265     sv_2mortal(sv);                     /* Parent created it permanently */
10266     cv = *cvp;
10267     if (!pv && s)
10268         pv = sv_2mortal(newSVpvn(s, len));
10269     if (type && pv)
10270         typesv = sv_2mortal(newSVpv(type, 0));
10271     else
10272         typesv = &PL_sv_undef;
10273
10274     PUSHSTACKi(PERLSI_OVERLOAD);
10275     ENTER ;
10276     SAVETMPS;
10277
10278     PUSHMARK(SP) ;
10279     EXTEND(sp, 3);
10280     if (pv)
10281         PUSHs(pv);
10282     PUSHs(sv);
10283     if (pv)
10284         PUSHs(typesv);
10285     PUTBACK;
10286     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10287
10288     SPAGAIN ;
10289
10290     /* Check the eval first */
10291     if (!PL_in_eval && SvTRUE(ERRSV)) {
10292         sv_catpvs(ERRSV, "Propagated");
10293         yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10294         (void)POPs;
10295         res = SvREFCNT_inc_simple(sv);
10296     }
10297     else {
10298         res = POPs;
10299         SvREFCNT_inc_simple_void(res);
10300     }
10301
10302     PUTBACK ;
10303     FREETMPS ;
10304     LEAVE ;
10305     POPSTACK;
10306
10307     if (!SvOK(res)) {
10308         why1 = "Call to &{$^H{";
10309         why2 = key;
10310         why3 = "}} did not return a defined value";
10311         sv = res;
10312         goto report;
10313     }
10314
10315     return res;
10316 }
10317
10318 /* Returns a NUL terminated string, with the length of the string written to
10319    *slp
10320    */
10321 STATIC char *
10322 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10323 {
10324     dVAR;
10325     register char *d = dest;
10326     register char * const e = d + destlen - 3;  /* two-character token, ending NUL */
10327     for (;;) {
10328         if (d >= e)
10329             Perl_croak(aTHX_ ident_too_long);
10330         if (isALNUM(*s))        /* UTF handled below */
10331             *d++ = *s++;
10332         else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
10333             *d++ = ':';
10334             *d++ = ':';
10335             s++;
10336         }
10337         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
10338             *d++ = *s++;
10339             *d++ = *s++;
10340         }
10341         else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10342             char *t = s + UTF8SKIP(s);
10343             while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10344                 t += UTF8SKIP(t);
10345             if (d + (t - s) > e)
10346                 Perl_croak(aTHX_ ident_too_long);
10347             Copy(s, d, t - s, char);
10348             d += t - s;
10349             s = t;
10350         }
10351         else {
10352             *d = '\0';
10353             *slp = d - dest;
10354             return s;
10355         }
10356     }
10357 }
10358
10359 STATIC char *
10360 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10361 {
10362     dVAR;
10363     char *bracket = NULL;
10364     char funny = *s++;
10365     register char *d = dest;
10366     register char * const e = d + destlen + 3;    /* two-character token, ending NUL */
10367
10368     if (isSPACE(*s))
10369         s = PEEKSPACE(s);
10370     if (isDIGIT(*s)) {
10371         while (isDIGIT(*s)) {
10372             if (d >= e)
10373                 Perl_croak(aTHX_ ident_too_long);
10374             *d++ = *s++;
10375         }
10376     }
10377     else {
10378         for (;;) {
10379             if (d >= e)
10380                 Perl_croak(aTHX_ ident_too_long);
10381             if (isALNUM(*s))    /* UTF handled below */
10382                 *d++ = *s++;
10383             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10384                 *d++ = ':';
10385                 *d++ = ':';
10386                 s++;
10387             }
10388             else if (*s == ':' && s[1] == ':') {
10389                 *d++ = *s++;
10390                 *d++ = *s++;
10391             }
10392             else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10393                 char *t = s + UTF8SKIP(s);
10394                 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10395                     t += UTF8SKIP(t);
10396                 if (d + (t - s) > e)
10397                     Perl_croak(aTHX_ ident_too_long);
10398                 Copy(s, d, t - s, char);
10399                 d += t - s;
10400                 s = t;
10401             }
10402             else
10403                 break;
10404         }
10405     }
10406     *d = '\0';
10407     d = dest;
10408     if (*d) {
10409         if (PL_lex_state != LEX_NORMAL)
10410             PL_lex_state = LEX_INTERPENDMAYBE;
10411         return s;
10412     }
10413     if (*s == '$' && s[1] &&
10414         (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10415     {
10416         return s;
10417     }
10418     if (*s == '{') {
10419         bracket = s;
10420         s++;
10421     }
10422     else if (ck_uni)
10423         check_uni();
10424     if (s < send)
10425         *d = *s++;
10426     d[1] = '\0';
10427     if (*d == '^' && *s && isCONTROLVAR(*s)) {
10428         *d = toCTRL(*s);
10429         s++;
10430     }
10431     if (bracket) {
10432         if (isSPACE(s[-1])) {
10433             while (s < send) {
10434                 const char ch = *s++;
10435                 if (!SPACE_OR_TAB(ch)) {
10436                     *d = ch;
10437                     break;
10438                 }
10439             }
10440         }
10441         if (isIDFIRST_lazy_if(d,UTF)) {
10442             d++;
10443             if (UTF) {
10444                 char *end = s;
10445                 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10446                     end += UTF8SKIP(end);
10447                     while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10448                         end += UTF8SKIP(end);
10449                 }
10450                 Copy(s, d, end - s, char);
10451                 d += end - s;
10452                 s = end;
10453             }
10454             else {
10455                 while ((isALNUM(*s) || *s == ':') && d < e)
10456                     *d++ = *s++;
10457                 if (d >= e)
10458                     Perl_croak(aTHX_ ident_too_long);
10459             }
10460             *d = '\0';
10461             while (s < send && SPACE_OR_TAB(*s)) s++;
10462             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10463                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
10464                     const char *brack = *s == '[' ? "[...]" : "{...}";
10465                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10466                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10467                         funny, dest, brack, funny, dest, brack);
10468                 }
10469                 bracket++;
10470                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10471                 return s;
10472             }
10473         }
10474         /* Handle extended ${^Foo} variables
10475          * 1999-02-27 mjd-perl-patch@plover.com */
10476         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10477                  && isALNUM(*s))
10478         {
10479             d++;
10480             while (isALNUM(*s) && d < e) {
10481                 *d++ = *s++;
10482             }
10483             if (d >= e)
10484                 Perl_croak(aTHX_ ident_too_long);
10485             *d = '\0';
10486         }
10487         if (*s == '}') {
10488             s++;
10489             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10490                 PL_lex_state = LEX_INTERPEND;
10491                 PL_expect = XREF;
10492             }
10493             if (funny == '#')
10494                 funny = '@';
10495             if (PL_lex_state == LEX_NORMAL) {
10496                 if (ckWARN(WARN_AMBIGUOUS) &&
10497                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
10498                 {
10499                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10500                         "Ambiguous use of %c{%s} resolved to %c%s",
10501                         funny, dest, funny, dest);
10502                 }
10503             }
10504         }
10505         else {
10506             s = bracket;                /* let the parser handle it */
10507             *dest = '\0';
10508         }
10509     }
10510     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10511         PL_lex_state = LEX_INTERPEND;
10512     return s;
10513 }
10514
10515 void
10516 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10517 {
10518     PERL_UNUSED_CONTEXT;
10519     if (ch == 'i')
10520         *pmfl |= PMf_FOLD;
10521     else if (ch == 'g')
10522         *pmfl |= PMf_GLOBAL;
10523     else if (ch == 'c')
10524         *pmfl |= PMf_CONTINUE;
10525     else if (ch == 'o')
10526         *pmfl |= PMf_KEEP;
10527     else if (ch == 'm')
10528         *pmfl |= PMf_MULTILINE;
10529     else if (ch == 's')
10530         *pmfl |= PMf_SINGLELINE;
10531     else if (ch == 'x')
10532         *pmfl |= PMf_EXTENDED;
10533 }
10534
10535 STATIC char *
10536 S_scan_pat(pTHX_ char *start, I32 type)
10537 {
10538     dVAR;
10539     PMOP *pm;
10540     char *s = scan_str(start,!!PL_madskills,FALSE);
10541     const char * const valid_flags = (type == OP_QR) ? "iomsx" : "iogcmsx";
10542 #ifdef PERL_MAD
10543     char *modstart;
10544 #endif
10545
10546
10547     if (!s) {
10548         const char * const delimiter = skipspace(start);
10549         Perl_croak(aTHX_ *delimiter == '?'
10550                    ? "Search pattern not terminated or ternary operator parsed as search pattern"
10551                    : "Search pattern not terminated" );
10552     }
10553
10554     pm = (PMOP*)newPMOP(type, 0);
10555     if (PL_multi_open == '?')
10556         pm->op_pmflags |= PMf_ONCE;
10557 #ifdef PERL_MAD
10558     modstart = s;
10559 #endif
10560     while (*s && strchr(valid_flags, *s))
10561         pmflag(&pm->op_pmflags,*s++);
10562 #ifdef PERL_MAD
10563     if (PL_madskills && modstart != s) {
10564         SV* tmptoken = newSVpvn(modstart, s - modstart);
10565         append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
10566     }
10567 #endif
10568     /* issue a warning if /c is specified,but /g is not */
10569     if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
10570             && ckWARN(WARN_REGEXP))
10571     {
10572         Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
10573     }
10574
10575     pm->op_pmpermflags = pm->op_pmflags;
10576
10577     PL_lex_op = (OP*)pm;
10578     yylval.ival = OP_MATCH;
10579     return s;
10580 }
10581
10582 STATIC char *
10583 S_scan_subst(pTHX_ char *start)
10584 {
10585     dVAR;
10586     register char *s;
10587     register PMOP *pm;
10588     I32 first_start;
10589     I32 es = 0;
10590 #ifdef PERL_MAD
10591     char *modstart;
10592 #endif
10593
10594     yylval.ival = OP_NULL;
10595
10596     s = scan_str(start,!!PL_madskills,FALSE);
10597
10598     if (!s)
10599         Perl_croak(aTHX_ "Substitution pattern not terminated");
10600
10601     if (s[-1] == PL_multi_open)
10602         s--;
10603 #ifdef PERL_MAD
10604     if (PL_madskills) {
10605         CURMAD('q', PL_thisopen);
10606         CURMAD('_', PL_thiswhite);
10607         CURMAD('E', PL_thisstuff);
10608         CURMAD('Q', PL_thisclose);
10609         PL_realtokenstart = s - SvPVX(PL_linestr);
10610     }
10611 #endif
10612
10613     first_start = PL_multi_start;
10614     s = scan_str(s,!!PL_madskills,FALSE);
10615     if (!s) {
10616         if (PL_lex_stuff) {
10617             SvREFCNT_dec(PL_lex_stuff);
10618             PL_lex_stuff = NULL;
10619         }
10620         Perl_croak(aTHX_ "Substitution replacement not terminated");
10621     }
10622     PL_multi_start = first_start;       /* so whole substitution is taken together */
10623
10624     pm = (PMOP*)newPMOP(OP_SUBST, 0);
10625
10626 #ifdef PERL_MAD
10627     if (PL_madskills) {
10628         CURMAD('z', PL_thisopen);
10629         CURMAD('R', PL_thisstuff);
10630         CURMAD('Z', PL_thisclose);
10631     }
10632     modstart = s;
10633 #endif
10634
10635     while (*s) {
10636         if (*s == 'e') {
10637             s++;
10638             es++;
10639         }
10640         else if (strchr("iogcmsx", *s))
10641             pmflag(&pm->op_pmflags,*s++);
10642         else
10643             break;
10644     }
10645
10646 #ifdef PERL_MAD
10647     if (PL_madskills) {
10648         if (modstart != s)
10649             curmad('m', newSVpvn(modstart, s - modstart));
10650         append_madprops(PL_thismad, (OP*)pm, 0);
10651         PL_thismad = 0;
10652     }
10653 #endif
10654     if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
10655         Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
10656     }
10657
10658     if (es) {
10659         SV * const repl = newSVpvs("");
10660
10661         PL_sublex_info.super_bufptr = s;
10662         PL_sublex_info.super_bufend = PL_bufend;
10663         PL_multi_end = 0;
10664         pm->op_pmflags |= PMf_EVAL;
10665         while (es-- > 0)
10666             sv_catpv(repl, es ? "eval " : "do ");
10667         sv_catpvs(repl, "{");
10668         sv_catsv(repl, PL_lex_repl);
10669         sv_catpvs(repl, "}");
10670         SvEVALED_on(repl);
10671         SvREFCNT_dec(PL_lex_repl);
10672         PL_lex_repl = repl;
10673     }
10674
10675     pm->op_pmpermflags = pm->op_pmflags;
10676     PL_lex_op = (OP*)pm;
10677     yylval.ival = OP_SUBST;
10678     return s;
10679 }
10680
10681 STATIC char *
10682 S_scan_trans(pTHX_ char *start)
10683 {
10684     dVAR;
10685     register char* s;
10686     OP *o;
10687     short *tbl;
10688     I32 squash;
10689     I32 del;
10690     I32 complement;
10691 #ifdef PERL_MAD
10692     char *modstart;
10693 #endif
10694
10695     yylval.ival = OP_NULL;
10696
10697     s = scan_str(start,!!PL_madskills,FALSE);
10698     if (!s)
10699         Perl_croak(aTHX_ "Transliteration pattern not terminated");
10700
10701     if (s[-1] == PL_multi_open)
10702         s--;
10703 #ifdef PERL_MAD
10704     if (PL_madskills) {
10705         CURMAD('q', PL_thisopen);
10706         CURMAD('_', PL_thiswhite);
10707         CURMAD('E', PL_thisstuff);
10708         CURMAD('Q', PL_thisclose);
10709         PL_realtokenstart = s - SvPVX(PL_linestr);
10710     }
10711 #endif
10712
10713     s = scan_str(s,!!PL_madskills,FALSE);
10714     if (!s) {
10715         if (PL_lex_stuff) {
10716             SvREFCNT_dec(PL_lex_stuff);
10717             PL_lex_stuff = NULL;
10718         }
10719         Perl_croak(aTHX_ "Transliteration replacement not terminated");
10720     }
10721     if (PL_madskills) {
10722         CURMAD('z', PL_thisopen);
10723         CURMAD('R', PL_thisstuff);
10724         CURMAD('Z', PL_thisclose);
10725     }
10726
10727     complement = del = squash = 0;
10728 #ifdef PERL_MAD
10729     modstart = s;
10730 #endif
10731     while (1) {
10732         switch (*s) {
10733         case 'c':
10734             complement = OPpTRANS_COMPLEMENT;
10735             break;
10736         case 'd':
10737             del = OPpTRANS_DELETE;
10738             break;
10739         case 's':
10740             squash = OPpTRANS_SQUASH;
10741             break;
10742         default:
10743             goto no_more;
10744         }
10745         s++;
10746     }
10747   no_more:
10748
10749     Newx(tbl, complement&&!del?258:256, short);
10750     o = newPVOP(OP_TRANS, 0, (char*)tbl);
10751     o->op_private &= ~OPpTRANS_ALL;
10752     o->op_private |= del|squash|complement|
10753       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
10754       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
10755
10756     PL_lex_op = o;
10757     yylval.ival = OP_TRANS;
10758
10759 #ifdef PERL_MAD
10760     if (PL_madskills) {
10761         if (modstart != s)
10762             curmad('m', newSVpvn(modstart, s - modstart));
10763         append_madprops(PL_thismad, o, 0);
10764         PL_thismad = 0;
10765     }
10766 #endif
10767
10768     return s;
10769 }
10770
10771 STATIC char *
10772 S_scan_heredoc(pTHX_ register char *s)
10773 {
10774     dVAR;
10775     SV *herewas;
10776     I32 op_type = OP_SCALAR;
10777     I32 len;
10778     SV *tmpstr;
10779     char term;
10780     const char *found_newline;
10781     register char *d;
10782     register char *e;
10783     char *peek;
10784     const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
10785 #ifdef PERL_MAD
10786     I32 stuffstart = s - SvPVX(PL_linestr);
10787     char *tstart;
10788
10789     PL_realtokenstart = -1;
10790 #endif
10791
10792     s += 2;
10793     d = PL_tokenbuf;
10794     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
10795     if (!outer)
10796         *d++ = '\n';
10797     for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
10798     if (*peek == '`' || *peek == '\'' || *peek =='"') {
10799         s = peek;
10800         term = *s++;
10801         s = delimcpy(d, e, s, PL_bufend, term, &len);
10802         d += len;
10803         if (s < PL_bufend)
10804             s++;
10805     }
10806     else {
10807         if (*s == '\\')
10808             s++, term = '\'';
10809         else
10810             term = '"';
10811         if (!isALNUM_lazy_if(s,UTF))
10812             deprecate_old("bare << to mean <<\"\"");
10813         for (; isALNUM_lazy_if(s,UTF); s++) {
10814             if (d < e)
10815                 *d++ = *s;
10816         }
10817     }
10818     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
10819         Perl_croak(aTHX_ "Delimiter for here document is too long");
10820     *d++ = '\n';
10821     *d = '\0';
10822     len = d - PL_tokenbuf;
10823
10824 #ifdef PERL_MAD
10825     if (PL_madskills) {
10826         tstart = PL_tokenbuf + !outer;
10827         PL_thisclose = newSVpvn(tstart, len - !outer);
10828         tstart = SvPVX(PL_linestr) + stuffstart;
10829         PL_thisopen = newSVpvn(tstart, s - tstart);
10830         stuffstart = s - SvPVX(PL_linestr);
10831     }
10832 #endif
10833 #ifndef PERL_STRICT_CR
10834     d = strchr(s, '\r');
10835     if (d) {
10836         char * const olds = s;
10837         s = d;
10838         while (s < PL_bufend) {
10839             if (*s == '\r') {
10840                 *d++ = '\n';
10841                 if (*++s == '\n')
10842                     s++;
10843             }
10844             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
10845                 *d++ = *s++;
10846                 s++;
10847             }
10848             else
10849                 *d++ = *s++;
10850         }
10851         *d = '\0';
10852         PL_bufend = d;
10853         SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10854         s = olds;
10855     }
10856 #endif
10857 #ifdef PERL_MAD
10858     found_newline = 0;
10859 #endif
10860     if ( outer || !(found_newline = memchr(s, '\n', PL_bufend - s)) ) {
10861         herewas = newSVpvn(s,PL_bufend-s);
10862     }
10863     else {
10864 #ifdef PERL_MAD
10865         herewas = newSVpvn(s-1,found_newline-s+1);
10866 #else
10867         s--;
10868         herewas = newSVpvn(s,found_newline-s);
10869 #endif
10870     }
10871 #ifdef PERL_MAD
10872     if (PL_madskills) {
10873         tstart = SvPVX(PL_linestr) + stuffstart;
10874         if (PL_thisstuff)
10875             sv_catpvn(PL_thisstuff, tstart, s - tstart);
10876         else
10877             PL_thisstuff = newSVpvn(tstart, s - tstart);
10878     }
10879 #endif
10880     s += SvCUR(herewas);
10881
10882 #ifdef PERL_MAD
10883     stuffstart = s - SvPVX(PL_linestr);
10884
10885     if (found_newline)
10886         s--;
10887 #endif
10888
10889     tmpstr = newSV(79);
10890     sv_upgrade(tmpstr, SVt_PVIV);
10891     if (term == '\'') {
10892         op_type = OP_CONST;
10893         SvIV_set(tmpstr, -1);
10894     }
10895     else if (term == '`') {
10896         op_type = OP_BACKTICK;
10897         SvIV_set(tmpstr, '\\');
10898     }
10899
10900     CLINE;
10901     PL_multi_start = CopLINE(PL_curcop);
10902     PL_multi_open = PL_multi_close = '<';
10903     term = *PL_tokenbuf;
10904     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
10905         char * const bufptr = PL_sublex_info.super_bufptr;
10906         char * const bufend = PL_sublex_info.super_bufend;
10907         char * const olds = s - SvCUR(herewas);
10908         s = strchr(bufptr, '\n');
10909         if (!s)
10910             s = bufend;
10911         d = s;
10912         while (s < bufend &&
10913           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
10914             if (*s++ == '\n')
10915                 CopLINE_inc(PL_curcop);
10916         }
10917         if (s >= bufend) {
10918             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10919             missingterm(PL_tokenbuf);
10920         }
10921         sv_setpvn(herewas,bufptr,d-bufptr+1);
10922         sv_setpvn(tmpstr,d+1,s-d);
10923         s += len - 1;
10924         sv_catpvn(herewas,s,bufend-s);
10925         Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
10926
10927         s = olds;
10928         goto retval;
10929     }
10930     else if (!outer) {
10931         d = s;
10932         while (s < PL_bufend &&
10933           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
10934             if (*s++ == '\n')
10935                 CopLINE_inc(PL_curcop);
10936         }
10937         if (s >= PL_bufend) {
10938             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10939             missingterm(PL_tokenbuf);
10940         }
10941         sv_setpvn(tmpstr,d+1,s-d);
10942 #ifdef PERL_MAD
10943         if (PL_madskills) {
10944             if (PL_thisstuff)
10945                 sv_catpvn(PL_thisstuff, d + 1, s - d);
10946             else
10947                 PL_thisstuff = newSVpvn(d + 1, s - d);
10948             stuffstart = s - SvPVX(PL_linestr);
10949         }
10950 #endif
10951         s += len - 1;
10952         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
10953
10954         sv_catpvn(herewas,s,PL_bufend-s);
10955         sv_setsv(PL_linestr,herewas);
10956         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
10957         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10958         PL_last_lop = PL_last_uni = NULL;
10959     }
10960     else
10961         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
10962     while (s >= PL_bufend) {    /* multiple line string? */
10963 #ifdef PERL_MAD
10964         if (PL_madskills) {
10965             tstart = SvPVX(PL_linestr) + stuffstart;
10966             if (PL_thisstuff)
10967                 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10968             else
10969                 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10970         }
10971 #endif
10972         if (!outer ||
10973          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
10974             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10975             missingterm(PL_tokenbuf);
10976         }
10977 #ifdef PERL_MAD
10978         stuffstart = s - SvPVX(PL_linestr);
10979 #endif
10980         CopLINE_inc(PL_curcop);
10981         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10982         PL_last_lop = PL_last_uni = NULL;
10983 #ifndef PERL_STRICT_CR
10984         if (PL_bufend - PL_linestart >= 2) {
10985             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
10986                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10987             {
10988                 PL_bufend[-2] = '\n';
10989                 PL_bufend--;
10990                 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10991             }
10992             else if (PL_bufend[-1] == '\r')
10993                 PL_bufend[-1] = '\n';
10994         }
10995         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10996             PL_bufend[-1] = '\n';
10997 #endif
10998         if (PERLDB_LINE && PL_curstash != PL_debstash) {
10999             SV * const sv = newSV(0);
11000
11001             sv_upgrade(sv, SVt_PVMG);
11002             sv_setsv(sv,PL_linestr);
11003             (void)SvIOK_on(sv);
11004             SvIV_set(sv, 0);
11005             av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop),sv);
11006         }
11007         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11008             STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11009             *(SvPVX(PL_linestr) + off ) = ' ';
11010             sv_catsv(PL_linestr,herewas);
11011             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11012             s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11013         }
11014         else {
11015             s = PL_bufend;
11016             sv_catsv(tmpstr,PL_linestr);
11017         }
11018     }
11019     s++;
11020 retval:
11021     PL_multi_end = CopLINE(PL_curcop);
11022     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11023         SvPV_shrink_to_cur(tmpstr);
11024     }
11025     SvREFCNT_dec(herewas);
11026     if (!IN_BYTES) {
11027         if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11028             SvUTF8_on(tmpstr);
11029         else if (PL_encoding)
11030             sv_recode_to_utf8(tmpstr, PL_encoding);
11031     }
11032     PL_lex_stuff = tmpstr;
11033     yylval.ival = op_type;
11034     return s;
11035 }
11036
11037 /* scan_inputsymbol
11038    takes: current position in input buffer
11039    returns: new position in input buffer
11040    side-effects: yylval and lex_op are set.
11041
11042    This code handles:
11043
11044    <>           read from ARGV
11045    <FH>         read from filehandle
11046    <pkg::FH>    read from package qualified filehandle
11047    <pkg'FH>     read from package qualified filehandle
11048    <$fh>        read from filehandle in $fh
11049    <*.h>        filename glob
11050
11051 */
11052
11053 STATIC char *
11054 S_scan_inputsymbol(pTHX_ char *start)
11055 {
11056     dVAR;
11057     register char *s = start;           /* current position in buffer */
11058     char *end;
11059     I32 len;
11060
11061     char *d = PL_tokenbuf;                                      /* start of temp holding space */
11062     const char * const e = PL_tokenbuf + sizeof PL_tokenbuf;    /* end of temp holding space */
11063
11064     end = strchr(s, '\n');
11065     if (!end)
11066         end = PL_bufend;
11067     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
11068
11069     /* die if we didn't have space for the contents of the <>,
11070        or if it didn't end, or if we see a newline
11071     */
11072
11073     if (len >= sizeof PL_tokenbuf)
11074         Perl_croak(aTHX_ "Excessively long <> operator");
11075     if (s >= end)
11076         Perl_croak(aTHX_ "Unterminated <> operator");
11077
11078     s++;
11079
11080     /* check for <$fh>
11081        Remember, only scalar variables are interpreted as filehandles by
11082        this code.  Anything more complex (e.g., <$fh{$num}>) will be
11083        treated as a glob() call.
11084        This code makes use of the fact that except for the $ at the front,
11085        a scalar variable and a filehandle look the same.
11086     */
11087     if (*d == '$' && d[1]) d++;
11088
11089     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11090     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11091         d++;
11092
11093     /* If we've tried to read what we allow filehandles to look like, and
11094        there's still text left, then it must be a glob() and not a getline.
11095        Use scan_str to pull out the stuff between the <> and treat it
11096        as nothing more than a string.
11097     */
11098
11099     if (d - PL_tokenbuf != len) {
11100         yylval.ival = OP_GLOB;
11101         set_csh();
11102         s = scan_str(start,!!PL_madskills,FALSE);
11103         if (!s)
11104            Perl_croak(aTHX_ "Glob not terminated");
11105         return s;
11106     }
11107     else {
11108         bool readline_overriden = FALSE;
11109         GV *gv_readline;
11110         GV **gvp;
11111         /* we're in a filehandle read situation */
11112         d = PL_tokenbuf;
11113
11114         /* turn <> into <ARGV> */
11115         if (!len)
11116             Copy("ARGV",d,5,char);
11117
11118         /* Check whether readline() is overriden */
11119         gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11120         if ((gv_readline
11121                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11122                 ||
11123                 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11124                 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
11125                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11126             readline_overriden = TRUE;
11127
11128         /* if <$fh>, create the ops to turn the variable into a
11129            filehandle
11130         */
11131         if (*d == '$') {
11132             I32 tmp;
11133
11134             /* try to find it in the pad for this block, otherwise find
11135                add symbol table ops
11136             */
11137             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
11138                 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11139                     HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11140                     HEK * const stashname = HvNAME_HEK(stash);
11141                     SV * const sym = sv_2mortal(newSVhek(stashname));
11142                     sv_catpvs(sym, "::");
11143                     sv_catpv(sym, d+1);
11144                     d = SvPVX(sym);
11145                     goto intro_sym;
11146                 }
11147                 else {
11148                     OP * const o = newOP(OP_PADSV, 0);
11149                     o->op_targ = tmp;
11150                     PL_lex_op = readline_overriden
11151                         ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11152                                 append_elem(OP_LIST, o,
11153                                     newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11154                         : (OP*)newUNOP(OP_READLINE, 0, o);
11155                 }
11156             }
11157             else {
11158                 GV *gv;
11159                 ++d;
11160 intro_sym:
11161                 gv = gv_fetchpv(d,
11162                                 (PL_in_eval
11163                                  ? (GV_ADDMULTI | GV_ADDINEVAL)
11164                                  : GV_ADDMULTI),
11165                                 SVt_PV);
11166                 PL_lex_op = readline_overriden
11167                     ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11168                             append_elem(OP_LIST,
11169                                 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11170                                 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11171                     : (OP*)newUNOP(OP_READLINE, 0,
11172                             newUNOP(OP_RV2SV, 0,
11173                                 newGVOP(OP_GV, 0, gv)));
11174             }
11175             if (!readline_overriden)
11176                 PL_lex_op->op_flags |= OPf_SPECIAL;
11177             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
11178             yylval.ival = OP_NULL;
11179         }
11180
11181         /* If it's none of the above, it must be a literal filehandle
11182            (<Foo::BAR> or <FOO>) so build a simple readline OP */
11183         else {
11184             GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11185             PL_lex_op = readline_overriden
11186                 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11187                         append_elem(OP_LIST,
11188                             newGVOP(OP_GV, 0, gv),
11189                             newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11190                 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11191             yylval.ival = OP_NULL;
11192         }
11193     }
11194
11195     return s;
11196 }
11197
11198
11199 /* scan_str
11200    takes: start position in buffer
11201           keep_quoted preserve \ on the embedded delimiter(s)
11202           keep_delims preserve the delimiters around the string
11203    returns: position to continue reading from buffer
11204    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11205         updates the read buffer.
11206
11207    This subroutine pulls a string out of the input.  It is called for:
11208         q               single quotes           q(literal text)
11209         '               single quotes           'literal text'
11210         qq              double quotes           qq(interpolate $here please)
11211         "               double quotes           "interpolate $here please"
11212         qx              backticks               qx(/bin/ls -l)
11213         `               backticks               `/bin/ls -l`
11214         qw              quote words             @EXPORT_OK = qw( func() $spam )
11215         m//             regexp match            m/this/
11216         s///            regexp substitute       s/this/that/
11217         tr///           string transliterate    tr/this/that/
11218         y///            string transliterate    y/this/that/
11219         ($*@)           sub prototypes          sub foo ($)
11220         (stuff)         sub attr parameters     sub foo : attr(stuff)
11221         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
11222
11223    In most of these cases (all but <>, patterns and transliterate)
11224    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
11225    calls scan_str().  s/// makes yylex() call scan_subst() which calls
11226    scan_str().  tr/// and y/// make yylex() call scan_trans() which
11227    calls scan_str().
11228
11229    It skips whitespace before the string starts, and treats the first
11230    character as the delimiter.  If the delimiter is one of ([{< then
11231    the corresponding "close" character )]}> is used as the closing
11232    delimiter.  It allows quoting of delimiters, and if the string has
11233    balanced delimiters ([{<>}]) it allows nesting.
11234
11235    On success, the SV with the resulting string is put into lex_stuff or,
11236    if that is already non-NULL, into lex_repl. The second case occurs only
11237    when parsing the RHS of the special constructs s/// and tr/// (y///).
11238    For convenience, the terminating delimiter character is stuffed into
11239    SvIVX of the SV.
11240 */
11241
11242 STATIC char *
11243 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11244 {
11245     dVAR;
11246     SV *sv;                             /* scalar value: string */
11247     char *tmps;                         /* temp string, used for delimiter matching */
11248     register char *s = start;           /* current position in the buffer */
11249     register char term;                 /* terminating character */
11250     register char *to;                  /* current position in the sv's data */
11251     I32 brackets = 1;                   /* bracket nesting level */
11252     bool has_utf8 = FALSE;              /* is there any utf8 content? */
11253     I32 termcode;                       /* terminating char. code */
11254     U8 termstr[UTF8_MAXBYTES];          /* terminating string */
11255     STRLEN termlen;                     /* length of terminating string */
11256     char *last = NULL;                  /* last position for nesting bracket */
11257 #ifdef PERL_MAD
11258     int stuffstart;
11259     char *tstart;
11260 #endif
11261
11262     /* skip space before the delimiter */
11263     if (isSPACE(*s)) {
11264         s = PEEKSPACE(s);
11265     }
11266
11267 #ifdef PERL_MAD
11268     if (PL_realtokenstart >= 0) {
11269         stuffstart = PL_realtokenstart;
11270         PL_realtokenstart = -1;
11271     }
11272     else
11273         stuffstart = start - SvPVX(PL_linestr);
11274 #endif
11275     /* mark where we are, in case we need to report errors */
11276     CLINE;
11277
11278     /* after skipping whitespace, the next character is the terminator */
11279     term = *s;
11280     if (!UTF) {
11281         termcode = termstr[0] = term;
11282         termlen = 1;
11283     }
11284     else {
11285         termcode = utf8_to_uvchr((U8*)s, &termlen);
11286         Copy(s, termstr, termlen, U8);
11287         if (!UTF8_IS_INVARIANT(term))
11288             has_utf8 = TRUE;
11289     }
11290
11291     /* mark where we are */
11292     PL_multi_start = CopLINE(PL_curcop);
11293     PL_multi_open = term;
11294
11295     /* find corresponding closing delimiter */
11296     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11297         termcode = termstr[0] = term = tmps[5];
11298
11299     PL_multi_close = term;
11300
11301     /* create a new SV to hold the contents.  79 is the SV's initial length.
11302        What a random number. */
11303     sv = newSV(79);
11304     sv_upgrade(sv, SVt_PVIV);
11305     SvIV_set(sv, termcode);
11306     (void)SvPOK_only(sv);               /* validate pointer */
11307
11308     /* move past delimiter and try to read a complete string */
11309     if (keep_delims)
11310         sv_catpvn(sv, s, termlen);
11311     s += termlen;
11312 #ifdef PERL_MAD
11313     tstart = SvPVX(PL_linestr) + stuffstart;
11314     if (!PL_thisopen && !keep_delims) {
11315         PL_thisopen = newSVpvn(tstart, s - tstart);
11316         stuffstart = s - SvPVX(PL_linestr);
11317     }
11318 #endif
11319     for (;;) {
11320         if (PL_encoding && !UTF) {
11321             bool cont = TRUE;
11322
11323             while (cont) {
11324                 int offset = s - SvPVX_const(PL_linestr);
11325                 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11326                                            &offset, (char*)termstr, termlen);
11327                 const char * const ns = SvPVX_const(PL_linestr) + offset;
11328                 char * const svlast = SvEND(sv) - 1;
11329
11330                 for (; s < ns; s++) {
11331                     if (*s == '\n' && !PL_rsfp)
11332                         CopLINE_inc(PL_curcop);
11333                 }
11334                 if (!found)
11335                     goto read_more_line;
11336                 else {
11337                     /* handle quoted delimiters */
11338                     if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11339                         const char *t;
11340                         for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11341                             t--;
11342                         if ((svlast-1 - t) % 2) {
11343                             if (!keep_quoted) {
11344                                 *(svlast-1) = term;
11345                                 *svlast = '\0';
11346                                 SvCUR_set(sv, SvCUR(sv) - 1);
11347                             }
11348                             continue;
11349                         }
11350                     }
11351                     if (PL_multi_open == PL_multi_close) {
11352                         cont = FALSE;
11353                     }
11354                     else {
11355                         const char *t;
11356                         char *w;
11357                         if (!last)
11358                             last = SvPVX(sv);
11359                         for (t = w = last; t < svlast; w++, t++) {
11360                             /* At here, all closes are "was quoted" one,
11361                                so we don't check PL_multi_close. */
11362                             if (*t == '\\') {
11363                                 if (!keep_quoted && *(t+1) == PL_multi_open)
11364                                     t++;
11365                                 else
11366                                     *w++ = *t++;
11367                             }
11368                             else if (*t == PL_multi_open)
11369                                 brackets++;
11370
11371                             *w = *t;
11372                         }
11373                         if (w < t) {
11374                             *w++ = term;
11375                             *w = '\0';
11376                             SvCUR_set(sv, w - SvPVX_const(sv));
11377                         }
11378                         last = w;
11379                         if (--brackets <= 0)
11380                             cont = FALSE;
11381                     }
11382                 }
11383             }
11384             if (!keep_delims) {
11385                 SvCUR_set(sv, SvCUR(sv) - 1);
11386                 *SvEND(sv) = '\0';
11387             }
11388             break;
11389         }
11390
11391         /* extend sv if need be */
11392         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11393         /* set 'to' to the next character in the sv's string */
11394         to = SvPVX(sv)+SvCUR(sv);
11395
11396         /* if open delimiter is the close delimiter read unbridle */
11397         if (PL_multi_open == PL_multi_close) {
11398             for (; s < PL_bufend; s++,to++) {
11399                 /* embedded newlines increment the current line number */
11400                 if (*s == '\n' && !PL_rsfp)
11401                     CopLINE_inc(PL_curcop);
11402                 /* handle quoted delimiters */
11403                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11404                     if (!keep_quoted && s[1] == term)
11405                         s++;
11406                 /* any other quotes are simply copied straight through */
11407                     else
11408                         *to++ = *s++;
11409                 }
11410                 /* terminate when run out of buffer (the for() condition), or
11411                    have found the terminator */
11412                 else if (*s == term) {
11413                     if (termlen == 1)
11414                         break;
11415                     if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11416                         break;
11417                 }
11418                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11419                     has_utf8 = TRUE;
11420                 *to = *s;
11421             }
11422         }
11423
11424         /* if the terminator isn't the same as the start character (e.g.,
11425            matched brackets), we have to allow more in the quoting, and
11426            be prepared for nested brackets.
11427         */
11428         else {
11429             /* read until we run out of string, or we find the terminator */
11430             for (; s < PL_bufend; s++,to++) {
11431                 /* embedded newlines increment the line count */
11432                 if (*s == '\n' && !PL_rsfp)
11433                     CopLINE_inc(PL_curcop);
11434                 /* backslashes can escape the open or closing characters */
11435                 if (*s == '\\' && s+1 < PL_bufend) {
11436                     if (!keep_quoted &&
11437                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11438                         s++;
11439                     else
11440                         *to++ = *s++;
11441                 }
11442                 /* allow nested opens and closes */
11443                 else if (*s == PL_multi_close && --brackets <= 0)
11444                     break;
11445                 else if (*s == PL_multi_open)
11446                     brackets++;
11447                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11448                     has_utf8 = TRUE;
11449                 *to = *s;
11450             }
11451         }
11452         /* terminate the copied string and update the sv's end-of-string */
11453         *to = '\0';
11454         SvCUR_set(sv, to - SvPVX_const(sv));
11455
11456         /*
11457          * this next chunk reads more into the buffer if we're not done yet
11458          */
11459
11460         if (s < PL_bufend)
11461             break;              /* handle case where we are done yet :-) */
11462
11463 #ifndef PERL_STRICT_CR
11464         if (to - SvPVX_const(sv) >= 2) {
11465             if ((to[-2] == '\r' && to[-1] == '\n') ||
11466                 (to[-2] == '\n' && to[-1] == '\r'))
11467             {
11468                 to[-2] = '\n';
11469                 to--;
11470                 SvCUR_set(sv, to - SvPVX_const(sv));
11471             }
11472             else if (to[-1] == '\r')
11473                 to[-1] = '\n';
11474         }
11475         else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11476             to[-1] = '\n';
11477 #endif
11478
11479      read_more_line:
11480         /* if we're out of file, or a read fails, bail and reset the current
11481            line marker so we can report where the unterminated string began
11482         */
11483 #ifdef PERL_MAD
11484         if (PL_madskills) {
11485             char *tstart = SvPVX(PL_linestr) + stuffstart;
11486             if (PL_thisstuff)
11487                 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11488             else
11489                 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11490         }
11491 #endif
11492         if (!PL_rsfp ||
11493          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11494             sv_free(sv);
11495             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11496             return NULL;
11497         }
11498 #ifdef PERL_MAD
11499         stuffstart = 0;
11500 #endif
11501         /* we read a line, so increment our line counter */
11502         CopLINE_inc(PL_curcop);
11503
11504         /* update debugger info */
11505         if (PERLDB_LINE && PL_curstash != PL_debstash) {
11506             SV * const line_sv = newSV(0);
11507
11508             sv_upgrade(line_sv, SVt_PVMG);
11509             sv_setsv(line_sv,PL_linestr);
11510             (void)SvIOK_on(line_sv);
11511             SvIV_set(line_sv, 0);
11512             av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop), line_sv);
11513         }
11514
11515         /* having changed the buffer, we must update PL_bufend */
11516         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11517         PL_last_lop = PL_last_uni = NULL;
11518     }
11519
11520     /* at this point, we have successfully read the delimited string */
11521
11522     if (!PL_encoding || UTF) {
11523 #ifdef PERL_MAD
11524         if (PL_madskills) {
11525             char *tstart = SvPVX(PL_linestr) + stuffstart;
11526             if (PL_thisstuff)
11527                 sv_catpvn(PL_thisstuff, tstart, s - tstart);
11528             else
11529                 PL_thisstuff = newSVpvn(tstart, s - tstart);
11530             if (!PL_thisclose && !keep_delims)
11531                 PL_thisclose = newSVpvn(s,termlen);
11532         }
11533 #endif
11534
11535         if (keep_delims)
11536             sv_catpvn(sv, s, termlen);
11537         s += termlen;
11538     }
11539 #ifdef PERL_MAD
11540     else {
11541         if (PL_madskills) {
11542             char *tstart = SvPVX(PL_linestr) + stuffstart;
11543             if (PL_thisstuff)
11544                 sv_catpvn(PL_thisstuff, tstart, s - tstart - termlen);
11545             else
11546                 PL_thisstuff = newSVpvn(tstart, s - tstart - termlen);
11547             if (!PL_thisclose && !keep_delims)
11548                 PL_thisclose = newSVpvn(s - termlen,termlen);
11549         }
11550     }
11551 #endif
11552     if (has_utf8 || PL_encoding)
11553         SvUTF8_on(sv);
11554
11555     PL_multi_end = CopLINE(PL_curcop);
11556
11557     /* if we allocated too much space, give some back */
11558     if (SvCUR(sv) + 5 < SvLEN(sv)) {
11559         SvLEN_set(sv, SvCUR(sv) + 1);
11560         SvPV_renew(sv, SvLEN(sv));
11561     }
11562
11563     /* decide whether this is the first or second quoted string we've read
11564        for this op
11565     */
11566
11567     if (PL_lex_stuff)
11568         PL_lex_repl = sv;
11569     else
11570         PL_lex_stuff = sv;
11571     return s;
11572 }
11573
11574 /*
11575   scan_num
11576   takes: pointer to position in buffer
11577   returns: pointer to new position in buffer
11578   side-effects: builds ops for the constant in yylval.op
11579
11580   Read a number in any of the formats that Perl accepts:
11581
11582   \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)      12 12.34 12.
11583   \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                     .34
11584   0b[01](_?[01])*
11585   0[0-7](_?[0-7])*
11586   0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
11587
11588   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
11589   thing it reads.
11590
11591   If it reads a number without a decimal point or an exponent, it will
11592   try converting the number to an integer and see if it can do so
11593   without loss of precision.
11594 */
11595
11596 char *
11597 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
11598 {
11599     dVAR;
11600     register const char *s = start;     /* current position in buffer */
11601     register char *d;                   /* destination in temp buffer */
11602     register char *e;                   /* end of temp buffer */
11603     NV nv;                              /* number read, as a double */
11604     SV *sv = NULL;                      /* place to put the converted number */
11605     bool floatit;                       /* boolean: int or float? */
11606     const char *lastub = NULL;          /* position of last underbar */
11607     static char const number_too_long[] = "Number too long";
11608
11609     /* We use the first character to decide what type of number this is */
11610
11611     switch (*s) {
11612     default:
11613       Perl_croak(aTHX_ "panic: scan_num");
11614
11615     /* if it starts with a 0, it could be an octal number, a decimal in
11616        0.13 disguise, or a hexadecimal number, or a binary number. */
11617     case '0':
11618         {
11619           /* variables:
11620              u          holds the "number so far"
11621              shift      the power of 2 of the base
11622                         (hex == 4, octal == 3, binary == 1)
11623              overflowed was the number more than we can hold?
11624
11625              Shift is used when we add a digit.  It also serves as an "are
11626              we in octal/hex/binary?" indicator to disallow hex characters
11627              when in octal mode.
11628            */
11629             NV n = 0.0;
11630             UV u = 0;
11631             I32 shift;
11632             bool overflowed = FALSE;
11633             bool just_zero  = TRUE;     /* just plain 0 or binary number? */
11634             static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
11635             static const char* const bases[5] =
11636               { "", "binary", "", "octal", "hexadecimal" };
11637             static const char* const Bases[5] =
11638               { "", "Binary", "", "Octal", "Hexadecimal" };
11639             static const char* const maxima[5] =
11640               { "",
11641                 "0b11111111111111111111111111111111",
11642                 "",
11643                 "037777777777",
11644                 "0xffffffff" };
11645             const char *base, *Base, *max;
11646
11647             /* check for hex */
11648             if (s[1] == 'x') {
11649                 shift = 4;
11650                 s += 2;
11651                 just_zero = FALSE;
11652             } else if (s[1] == 'b') {
11653                 shift = 1;
11654                 s += 2;
11655                 just_zero = FALSE;
11656             }
11657             /* check for a decimal in disguise */
11658             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
11659                 goto decimal;
11660             /* so it must be octal */
11661             else {
11662                 shift = 3;
11663                 s++;
11664             }
11665
11666             if (*s == '_') {
11667                if (ckWARN(WARN_SYNTAX))
11668                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11669                                "Misplaced _ in number");
11670                lastub = s++;
11671             }
11672
11673             base = bases[shift];
11674             Base = Bases[shift];
11675             max  = maxima[shift];
11676
11677             /* read the rest of the number */
11678             for (;;) {
11679                 /* x is used in the overflow test,
11680                    b is the digit we're adding on. */
11681                 UV x, b;
11682
11683                 switch (*s) {
11684
11685                 /* if we don't mention it, we're done */
11686                 default:
11687                     goto out;
11688
11689                 /* _ are ignored -- but warned about if consecutive */
11690                 case '_':
11691                     if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
11692                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11693                                     "Misplaced _ in number");
11694                     lastub = s++;
11695                     break;
11696
11697                 /* 8 and 9 are not octal */
11698                 case '8': case '9':
11699                     if (shift == 3)
11700                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
11701                     /* FALL THROUGH */
11702
11703                 /* octal digits */
11704                 case '2': case '3': case '4':
11705                 case '5': case '6': case '7':
11706                     if (shift == 1)
11707                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
11708                     /* FALL THROUGH */
11709
11710                 case '0': case '1':
11711                     b = *s++ & 15;              /* ASCII digit -> value of digit */
11712                     goto digit;
11713
11714                 /* hex digits */
11715                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
11716                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
11717                     /* make sure they said 0x */
11718                     if (shift != 4)
11719                         goto out;
11720                     b = (*s++ & 7) + 9;
11721
11722                     /* Prepare to put the digit we have onto the end
11723                        of the number so far.  We check for overflows.
11724                     */
11725
11726                   digit:
11727                     just_zero = FALSE;
11728                     if (!overflowed) {
11729                         x = u << shift; /* make room for the digit */
11730
11731                         if ((x >> shift) != u
11732                             && !(PL_hints & HINT_NEW_BINARY)) {
11733                             overflowed = TRUE;
11734                             n = (NV) u;
11735                             if (ckWARN_d(WARN_OVERFLOW))
11736                                 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11737                                             "Integer overflow in %s number",
11738                                             base);
11739                         } else
11740                             u = x | b;          /* add the digit to the end */
11741                     }
11742                     if (overflowed) {
11743                         n *= nvshift[shift];
11744                         /* If an NV has not enough bits in its
11745                          * mantissa to represent an UV this summing of
11746                          * small low-order numbers is a waste of time
11747                          * (because the NV cannot preserve the
11748                          * low-order bits anyway): we could just
11749                          * remember when did we overflow and in the
11750                          * end just multiply n by the right
11751                          * amount. */
11752                         n += (NV) b;
11753                     }
11754                     break;
11755                 }
11756             }
11757
11758           /* if we get here, we had success: make a scalar value from
11759              the number.
11760           */
11761           out:
11762
11763             /* final misplaced underbar check */
11764             if (s[-1] == '_') {
11765                 if (ckWARN(WARN_SYNTAX))
11766                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
11767             }
11768
11769             sv = newSV(0);
11770             if (overflowed) {
11771                 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
11772                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
11773                                 "%s number > %s non-portable",
11774                                 Base, max);
11775                 sv_setnv(sv, n);
11776             }
11777             else {
11778 #if UVSIZE > 4
11779                 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
11780                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
11781                                 "%s number > %s non-portable",
11782                                 Base, max);
11783 #endif
11784                 sv_setuv(sv, u);
11785             }
11786             if (just_zero && (PL_hints & HINT_NEW_INTEGER))
11787                 sv = new_constant(start, s - start, "integer",
11788                                   sv, NULL, NULL);
11789             else if (PL_hints & HINT_NEW_BINARY)
11790                 sv = new_constant(start, s - start, "binary", sv, NULL, NULL);
11791         }
11792         break;
11793
11794     /*
11795       handle decimal numbers.
11796       we're also sent here when we read a 0 as the first digit
11797     */
11798     case '1': case '2': case '3': case '4': case '5':
11799     case '6': case '7': case '8': case '9': case '.':
11800       decimal:
11801         d = PL_tokenbuf;
11802         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11803         floatit = FALSE;
11804
11805         /* read next group of digits and _ and copy into d */
11806         while (isDIGIT(*s) || *s == '_') {
11807             /* skip underscores, checking for misplaced ones
11808                if -w is on
11809             */
11810             if (*s == '_') {
11811                 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
11812                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11813                                 "Misplaced _ in number");
11814                 lastub = s++;
11815             }
11816             else {
11817                 /* check for end of fixed-length buffer */
11818                 if (d >= e)
11819                     Perl_croak(aTHX_ number_too_long);
11820                 /* if we're ok, copy the character */
11821                 *d++ = *s++;
11822             }
11823         }
11824
11825         /* final misplaced underbar check */
11826         if (lastub && s == lastub + 1) {
11827             if (ckWARN(WARN_SYNTAX))
11828                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
11829         }
11830
11831         /* read a decimal portion if there is one.  avoid
11832            3..5 being interpreted as the number 3. followed
11833            by .5
11834         */
11835         if (*s == '.' && s[1] != '.') {
11836             floatit = TRUE;
11837             *d++ = *s++;
11838
11839             if (*s == '_') {
11840                 if (ckWARN(WARN_SYNTAX))
11841                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11842                                 "Misplaced _ in number");
11843                 lastub = s;
11844             }
11845
11846             /* copy, ignoring underbars, until we run out of digits.
11847             */
11848             for (; isDIGIT(*s) || *s == '_'; s++) {
11849                 /* fixed length buffer check */
11850                 if (d >= e)
11851                     Perl_croak(aTHX_ number_too_long);
11852                 if (*s == '_') {
11853                    if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
11854                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11855                                    "Misplaced _ in number");
11856                    lastub = s;
11857                 }
11858                 else
11859                     *d++ = *s;
11860             }
11861             /* fractional part ending in underbar? */
11862             if (s[-1] == '_') {
11863                 if (ckWARN(WARN_SYNTAX))
11864                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11865                                 "Misplaced _ in number");
11866             }
11867             if (*s == '.' && isDIGIT(s[1])) {
11868                 /* oops, it's really a v-string, but without the "v" */
11869                 s = start;
11870                 goto vstring;
11871             }
11872         }
11873
11874         /* read exponent part, if present */
11875         if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
11876             floatit = TRUE;
11877             s++;
11878
11879             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
11880             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
11881
11882             /* stray preinitial _ */
11883             if (*s == '_') {
11884                 if (ckWARN(WARN_SYNTAX))
11885                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11886                                 "Misplaced _ in number");
11887                 lastub = s++;
11888             }
11889
11890             /* allow positive or negative exponent */
11891             if (*s == '+' || *s == '-')
11892                 *d++ = *s++;
11893
11894             /* stray initial _ */
11895             if (*s == '_') {
11896                 if (ckWARN(WARN_SYNTAX))
11897                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11898                                 "Misplaced _ in number");
11899                 lastub = s++;
11900             }
11901
11902             /* read digits of exponent */
11903             while (isDIGIT(*s) || *s == '_') {
11904                 if (isDIGIT(*s)) {
11905                     if (d >= e)
11906                         Perl_croak(aTHX_ number_too_long);
11907                     *d++ = *s++;
11908                 }
11909                 else {
11910                    if (((lastub && s == lastub + 1) ||
11911                         (!isDIGIT(s[1]) && s[1] != '_'))
11912                     && ckWARN(WARN_SYNTAX))
11913                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11914                                    "Misplaced _ in number");
11915                    lastub = s++;
11916                 }
11917             }
11918         }
11919
11920
11921         /* make an sv from the string */
11922         sv = newSV(0);
11923
11924         /*
11925            We try to do an integer conversion first if no characters
11926            indicating "float" have been found.
11927          */
11928
11929         if (!floatit) {
11930             UV uv;
11931             const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11932
11933             if (flags == IS_NUMBER_IN_UV) {
11934               if (uv <= IV_MAX)
11935                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
11936               else
11937                 sv_setuv(sv, uv);
11938             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11939               if (uv <= (UV) IV_MIN)
11940                 sv_setiv(sv, -(IV)uv);
11941               else
11942                 floatit = TRUE;
11943             } else
11944               floatit = TRUE;
11945         }
11946         if (floatit) {
11947             /* terminate the string */
11948             *d = '\0';
11949             nv = Atof(PL_tokenbuf);
11950             sv_setnv(sv, nv);
11951         }
11952
11953         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
11954                        (PL_hints & HINT_NEW_INTEGER) )
11955             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
11956                               (floatit ? "float" : "integer"),
11957                               sv, NULL, NULL);
11958         break;
11959
11960     /* if it starts with a v, it could be a v-string */
11961     case 'v':
11962 vstring:
11963                 sv = newSV(5); /* preallocate storage space */
11964                 s = scan_vstring(s,sv);
11965         break;
11966     }
11967
11968     /* make the op for the constant and return */
11969
11970     if (sv)
11971         lvalp->opval = newSVOP(OP_CONST, 0, sv);
11972     else
11973         lvalp->opval = NULL;
11974
11975     return (char *)s;
11976 }
11977
11978 STATIC char *
11979 S_scan_formline(pTHX_ register char *s)
11980 {
11981     dVAR;
11982     register char *eol;
11983     register char *t;
11984     SV * const stuff = newSVpvs("");
11985     bool needargs = FALSE;
11986     bool eofmt = FALSE;
11987 #ifdef PERL_MAD
11988     char *tokenstart = s;
11989     SV* savewhite;
11990
11991     if (PL_madskills) {
11992         savewhite = PL_thiswhite;
11993         PL_thiswhite = 0;
11994     }
11995 #endif
11996
11997     while (!needargs) {
11998         if (*s == '.') {
11999 #ifdef PERL_STRICT_CR
12000             for (t = s+1;SPACE_OR_TAB(*t); t++) ;
12001 #else
12002             for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
12003 #endif
12004             if (*t == '\n' || t == PL_bufend) {
12005                 eofmt = TRUE;
12006                 break;
12007             }
12008         }
12009         if (PL_in_eval && !PL_rsfp) {
12010             eol = (char *) memchr(s,'\n',PL_bufend-s);
12011             if (!eol++)
12012                 eol = PL_bufend;
12013         }
12014         else
12015             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12016         if (*s != '#') {
12017             for (t = s; t < eol; t++) {
12018                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12019                     needargs = FALSE;
12020                     goto enough;        /* ~~ must be first line in formline */
12021                 }
12022                 if (*t == '@' || *t == '^')
12023                     needargs = TRUE;
12024             }
12025             if (eol > s) {
12026                 sv_catpvn(stuff, s, eol-s);
12027 #ifndef PERL_STRICT_CR
12028                 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12029                     char *end = SvPVX(stuff) + SvCUR(stuff);
12030                     end[-2] = '\n';
12031                     end[-1] = '\0';
12032                     SvCUR_set(stuff, SvCUR(stuff) - 1);
12033                 }
12034 #endif
12035             }
12036             else
12037               break;
12038         }
12039         s = (char*)eol;
12040         if (PL_rsfp) {
12041 #ifdef PERL_MAD
12042             if (PL_madskills) {
12043                 if (PL_thistoken)
12044                     sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12045                 else
12046                     PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12047             }
12048 #endif
12049             s = filter_gets(PL_linestr, PL_rsfp, 0);
12050 #ifdef PERL_MAD
12051             tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12052 #else
12053             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12054 #endif
12055             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12056             PL_last_lop = PL_last_uni = NULL;
12057             if (!s) {
12058                 s = PL_bufptr;
12059                 break;
12060             }
12061         }
12062         incline(s);
12063     }
12064   enough:
12065     if (SvCUR(stuff)) {
12066         PL_expect = XTERM;
12067         if (needargs) {
12068             PL_lex_state = LEX_NORMAL;
12069             start_force(PL_curforce);
12070             NEXTVAL_NEXTTOKE.ival = 0;
12071             force_next(',');
12072         }
12073         else
12074             PL_lex_state = LEX_FORMLINE;
12075         if (!IN_BYTES) {
12076             if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12077                 SvUTF8_on(stuff);
12078             else if (PL_encoding)
12079                 sv_recode_to_utf8(stuff, PL_encoding);
12080         }
12081         start_force(PL_curforce);
12082         NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12083         force_next(THING);
12084         start_force(PL_curforce);
12085         NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12086         force_next(LSTOP);
12087     }
12088     else {
12089         SvREFCNT_dec(stuff);
12090         if (eofmt)
12091             PL_lex_formbrack = 0;
12092         PL_bufptr = s;
12093     }
12094 #ifdef PERL_MAD
12095     if (PL_madskills) {
12096         if (PL_thistoken)
12097             sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12098         else
12099             PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12100         PL_thiswhite = savewhite;
12101     }
12102 #endif
12103     return s;
12104 }
12105
12106 STATIC void
12107 S_set_csh(pTHX)
12108 {
12109 #ifdef CSH
12110     dVAR;
12111     if (!PL_cshlen)
12112         PL_cshlen = strlen(PL_cshname);
12113 #else
12114 #if defined(USE_ITHREADS)
12115     PERL_UNUSED_CONTEXT;
12116 #endif
12117 #endif
12118 }
12119
12120 I32
12121 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12122 {
12123     dVAR;
12124     const I32 oldsavestack_ix = PL_savestack_ix;
12125     CV* const outsidecv = PL_compcv;
12126
12127     if (PL_compcv) {
12128         assert(SvTYPE(PL_compcv) == SVt_PVCV);
12129     }
12130     SAVEI32(PL_subline);
12131     save_item(PL_subname);
12132     SAVESPTR(PL_compcv);
12133
12134     PL_compcv = (CV*)newSV(0);
12135     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
12136     CvFLAGS(PL_compcv) |= flags;
12137
12138     PL_subline = CopLINE(PL_curcop);
12139     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12140     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv);
12141     CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12142
12143     return oldsavestack_ix;
12144 }
12145
12146 #ifdef __SC__
12147 #pragma segment Perl_yylex
12148 #endif
12149 int
12150 Perl_yywarn(pTHX_ const char *s)
12151 {
12152     dVAR;
12153     PL_in_eval |= EVAL_WARNONLY;
12154     yyerror(s);
12155     PL_in_eval &= ~EVAL_WARNONLY;
12156     return 0;
12157 }
12158
12159 int
12160 Perl_yyerror(pTHX_ const char *s)
12161 {
12162     dVAR;
12163     const char *where = NULL;
12164     const char *context = NULL;
12165     int contlen = -1;
12166     SV *msg;
12167
12168     if (!yychar || (yychar == ';' && !PL_rsfp))
12169         where = "at EOF";
12170     else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12171       PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12172       PL_oldbufptr != PL_bufptr) {
12173         /*
12174                 Only for NetWare:
12175                 The code below is removed for NetWare because it abends/crashes on NetWare
12176                 when the script has error such as not having the closing quotes like:
12177                     if ($var eq "value)
12178                 Checking of white spaces is anyway done in NetWare code.
12179         */
12180 #ifndef NETWARE
12181         while (isSPACE(*PL_oldoldbufptr))
12182             PL_oldoldbufptr++;
12183 #endif
12184         context = PL_oldoldbufptr;
12185         contlen = PL_bufptr - PL_oldoldbufptr;
12186     }
12187     else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12188       PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12189         /*
12190                 Only for NetWare:
12191                 The code below is removed for NetWare because it abends/crashes on NetWare
12192                 when the script has error such as not having the closing quotes like:
12193                     if ($var eq "value)
12194                 Checking of white spaces is anyway done in NetWare code.
12195         */
12196 #ifndef NETWARE
12197         while (isSPACE(*PL_oldbufptr))
12198             PL_oldbufptr++;
12199 #endif
12200         context = PL_oldbufptr;
12201         contlen = PL_bufptr - PL_oldbufptr;
12202     }
12203     else if (yychar > 255)
12204         where = "next token ???";
12205     else if (yychar == -2) { /* YYEMPTY */
12206         if (PL_lex_state == LEX_NORMAL ||
12207            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12208             where = "at end of line";
12209         else if (PL_lex_inpat)
12210             where = "within pattern";
12211         else
12212             where = "within string";
12213     }
12214     else {
12215         SV * const where_sv = sv_2mortal(newSVpvs("next char "));
12216         if (yychar < 32)
12217             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12218         else if (isPRINT_LC(yychar))
12219             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
12220         else
12221             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12222         where = SvPVX_const(where_sv);
12223     }
12224     msg = sv_2mortal(newSVpv(s, 0));
12225     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12226         OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12227     if (context)
12228         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12229     else
12230         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12231     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12232         Perl_sv_catpvf(aTHX_ msg,
12233         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12234                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12235         PL_multi_end = 0;
12236     }
12237     if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
12238         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
12239     else
12240         qerror(msg);
12241     if (PL_error_count >= 10) {
12242         if (PL_in_eval && SvCUR(ERRSV))
12243             Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12244             ERRSV, OutCopFILE(PL_curcop));
12245         else
12246             Perl_croak(aTHX_ "%s has too many errors.\n",
12247             OutCopFILE(PL_curcop));
12248     }
12249     PL_in_my = 0;
12250     PL_in_my_stash = NULL;
12251     return 0;
12252 }
12253 #ifdef __SC__
12254 #pragma segment Main
12255 #endif
12256
12257 STATIC char*
12258 S_swallow_bom(pTHX_ U8 *s)
12259 {
12260     dVAR;
12261     const STRLEN slen = SvCUR(PL_linestr);
12262     switch (s[0]) {
12263     case 0xFF:
12264         if (s[1] == 0xFE) {
12265             /* UTF-16 little-endian? (or UTF32-LE?) */
12266             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
12267                 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12268 #ifndef PERL_NO_UTF16_FILTER
12269             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12270             s += 2;
12271         utf16le:
12272             if (PL_bufend > (char*)s) {
12273                 U8 *news;
12274                 I32 newlen;
12275
12276                 filter_add(utf16rev_textfilter, NULL);
12277                 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12278                 utf16_to_utf8_reversed(s, news,
12279                                        PL_bufend - (char*)s - 1,
12280                                        &newlen);
12281                 sv_setpvn(PL_linestr, (const char*)news, newlen);
12282 #ifdef PERL_MAD
12283                 s = (U8*)SvPVX(PL_linestr);
12284                 Copy(news, s, newlen, U8);
12285                 s[newlen] = '\0';
12286 #endif
12287                 Safefree(news);
12288                 SvUTF8_on(PL_linestr);
12289                 s = (U8*)SvPVX(PL_linestr);
12290 #ifdef PERL_MAD
12291                 /* FIXME - is this a general bug fix?  */
12292                 s[newlen] = '\0';
12293 #endif
12294                 PL_bufend = SvPVX(PL_linestr) + newlen;
12295             }
12296 #else
12297             Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12298 #endif
12299         }
12300         break;
12301     case 0xFE:
12302         if (s[1] == 0xFF) {   /* UTF-16 big-endian? */
12303 #ifndef PERL_NO_UTF16_FILTER
12304             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12305             s += 2;
12306         utf16be:
12307             if (PL_bufend > (char *)s) {
12308                 U8 *news;
12309                 I32 newlen;
12310
12311                 filter_add(utf16_textfilter, NULL);
12312                 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12313                 utf16_to_utf8(s, news,
12314                               PL_bufend - (char*)s,
12315                               &newlen);
12316                 sv_setpvn(PL_linestr, (const char*)news, newlen);
12317                 Safefree(news);
12318                 SvUTF8_on(PL_linestr);
12319                 s = (U8*)SvPVX(PL_linestr);
12320                 PL_bufend = SvPVX(PL_linestr) + newlen;
12321             }
12322 #else
12323             Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12324 #endif
12325         }
12326         break;
12327     case 0xEF:
12328         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12329             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12330             s += 3;                      /* UTF-8 */
12331         }
12332         break;
12333     case 0:
12334         if (slen > 3) {
12335              if (s[1] == 0) {
12336                   if (s[2] == 0xFE && s[3] == 0xFF) {
12337                        /* UTF-32 big-endian */
12338                        Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12339                   }
12340              }
12341              else if (s[2] == 0 && s[3] != 0) {
12342                   /* Leading bytes
12343                    * 00 xx 00 xx
12344                    * are a good indicator of UTF-16BE. */
12345                   if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12346                   goto utf16be;
12347              }
12348         }
12349     default:
12350          if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12351                   /* Leading bytes
12352                    * xx 00 xx 00
12353                    * are a good indicator of UTF-16LE. */
12354               if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12355               goto utf16le;
12356          }
12357     }
12358     return (char*)s;
12359 }
12360
12361 /*
12362  * restore_rsfp
12363  * Restore a source filter.
12364  */
12365
12366 static void
12367 restore_rsfp(pTHX_ void *f)
12368 {
12369     dVAR;
12370     PerlIO * const fp = (PerlIO*)f;
12371
12372     if (PL_rsfp == PerlIO_stdin())
12373         PerlIO_clearerr(PL_rsfp);
12374     else if (PL_rsfp && (PL_rsfp != fp))
12375         PerlIO_close(PL_rsfp);
12376     PL_rsfp = fp;
12377 }
12378
12379 #ifndef PERL_NO_UTF16_FILTER
12380 static I32
12381 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12382 {
12383     dVAR;
12384     const STRLEN old = SvCUR(sv);
12385     const I32 count = FILTER_READ(idx+1, sv, maxlen);
12386     DEBUG_P(PerlIO_printf(Perl_debug_log,
12387                           "utf16_textfilter(%p): %d %d (%d)\n",
12388                           utf16_textfilter, idx, maxlen, (int) count));
12389     if (count) {
12390         U8* tmps;
12391         I32 newlen;
12392         Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12393         Copy(SvPVX_const(sv), tmps, old, char);
12394         utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12395                       SvCUR(sv) - old, &newlen);
12396         sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12397     }
12398     DEBUG_P({sv_dump(sv);});
12399     return SvCUR(sv);
12400 }
12401
12402 static I32
12403 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12404 {
12405     dVAR;
12406     const STRLEN old = SvCUR(sv);
12407     const I32 count = FILTER_READ(idx+1, sv, maxlen);
12408     DEBUG_P(PerlIO_printf(Perl_debug_log,
12409                           "utf16rev_textfilter(%p): %d %d (%d)\n",
12410                           utf16rev_textfilter, idx, maxlen, (int) count));
12411     if (count) {
12412         U8* tmps;
12413         I32 newlen;
12414         Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12415         Copy(SvPVX_const(sv), tmps, old, char);
12416         utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12417                       SvCUR(sv) - old, &newlen);
12418         sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12419     }
12420     DEBUG_P({ sv_dump(sv); });
12421     return count;
12422 }
12423 #endif
12424
12425 /*
12426 Returns a pointer to the next character after the parsed
12427 vstring, as well as updating the passed in sv.
12428
12429 Function must be called like
12430
12431         sv = newSV(5);
12432         s = scan_vstring(s,sv);
12433
12434 The sv should already be large enough to store the vstring
12435 passed in, for performance reasons.
12436
12437 */
12438
12439 char *
12440 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
12441 {
12442     dVAR;
12443     const char *pos = s;
12444     const char *start = s;
12445     if (*pos == 'v') pos++;  /* get past 'v' */
12446     while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12447         pos++;
12448     if ( *pos != '.') {
12449         /* this may not be a v-string if followed by => */
12450         const char *next = pos;
12451         while (next < PL_bufend && isSPACE(*next))
12452             ++next;
12453         if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
12454             /* return string not v-string */
12455             sv_setpvn(sv,(char *)s,pos-s);
12456             return (char *)pos;
12457         }
12458     }
12459
12460     if (!isALPHA(*pos)) {
12461         U8 tmpbuf[UTF8_MAXBYTES+1];
12462
12463         if (*s == 'v')
12464             s++;  /* get past 'v' */
12465
12466         sv_setpvn(sv, "", 0);
12467
12468         for (;;) {
12469             /* this is atoi() that tolerates underscores */
12470             U8 *tmpend;
12471             UV rev = 0;
12472             const char *end = pos;
12473             UV mult = 1;
12474             while (--end >= s) {
12475                 if (*end != '_') {
12476                     const UV orev = rev;
12477                     rev += (*end - '0') * mult;
12478                     mult *= 10;
12479                     if (orev > rev && ckWARN_d(WARN_OVERFLOW))
12480                         Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12481                                     "Integer overflow in decimal number");
12482                 }
12483             }
12484 #ifdef EBCDIC
12485             if (rev > 0x7FFFFFFF)
12486                  Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
12487 #endif
12488             /* Append native character for the rev point */
12489             tmpend = uvchr_to_utf8(tmpbuf, rev);
12490             sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12491             if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
12492                  SvUTF8_on(sv);
12493             if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
12494                  s = ++pos;
12495             else {
12496                  s = pos;
12497                  break;
12498             }
12499             while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12500                  pos++;
12501         }
12502         SvPOK_on(sv);
12503         sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12504         SvRMAGICAL_on(sv);
12505     }
12506     return (char *)s;
12507 }
12508
12509 /*
12510  * Local variables:
12511  * c-indentation-style: bsd
12512  * c-basic-offset: 4
12513  * indent-tabs-mode: t
12514  * End:
12515  *
12516  * ex: set ts=8 sts=4 sw=4 noet:
12517  */