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
2637     if (!PL_rsfp_filters)
2638         return -1;
2639     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
2640         /* Provide a default input filter to make life easy.    */
2641         /* Note that we append to the line. This is handy.      */
2642         DEBUG_P(PerlIO_printf(Perl_debug_log,
2643                               "filter_read %d: from rsfp\n", idx));
2644         if (maxlen) {
2645             /* Want a block */
2646             int len ;
2647             const int old_len = SvCUR(buf_sv);
2648
2649             /* ensure buf_sv is large enough */
2650             SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2651             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2652                 if (PerlIO_error(PL_rsfp))
2653                     return -1;          /* error */
2654                 else
2655                     return 0 ;          /* end of file */
2656             }
2657             SvCUR_set(buf_sv, old_len + len) ;
2658         } else {
2659             /* Want a line */
2660             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2661                 if (PerlIO_error(PL_rsfp))
2662                     return -1;          /* error */
2663                 else
2664                     return 0 ;          /* end of file */
2665             }
2666         }
2667         return SvCUR(buf_sv);
2668     }
2669     /* Skip this filter slot if filter has been deleted */
2670     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2671         DEBUG_P(PerlIO_printf(Perl_debug_log,
2672                               "filter_read %d: skipped (filter deleted)\n",
2673                               idx));
2674         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2675     }
2676     /* Get function pointer hidden within datasv        */
2677     funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2678     DEBUG_P(PerlIO_printf(Perl_debug_log,
2679                           "filter_read %d: via function %p (%s)\n",
2680                           idx, datasv, SvPV_nolen_const(datasv)));
2681     /* Call function. The function is expected to       */
2682     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2683     /* Return: <0:error, =0:eof, >0:not eof             */
2684     return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2685 }
2686
2687 STATIC char *
2688 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2689 {
2690     dVAR;
2691 #ifdef PERL_CR_FILTER
2692     if (!PL_rsfp_filters) {
2693         filter_add(S_cr_textfilter,NULL);
2694     }
2695 #endif
2696     if (PL_rsfp_filters) {
2697         if (!append)
2698             SvCUR_set(sv, 0);   /* start with empty line        */
2699         if (FILTER_READ(0, sv, 0) > 0)
2700             return ( SvPVX(sv) ) ;
2701         else
2702             return NULL ;
2703     }
2704     else
2705         return (sv_gets(sv, fp, append));
2706 }
2707
2708 STATIC HV *
2709 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2710 {
2711     dVAR;
2712     GV *gv;
2713
2714     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2715         return PL_curstash;
2716
2717     if (len > 2 &&
2718         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2719         (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
2720     {
2721         return GvHV(gv);                        /* Foo:: */
2722     }
2723
2724     /* use constant CLASS => 'MyClass' */
2725     if ((gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV))) {
2726         SV *sv;
2727         if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2728             pkgname = SvPV_nolen_const(sv);
2729         }
2730     }
2731
2732     return gv_stashpv(pkgname, FALSE);
2733 }
2734
2735 #ifdef PERL_MAD
2736  /*
2737  * Perl_madlex
2738  * The intent of this yylex wrapper is to minimize the changes to the
2739  * tokener when we aren't interested in collecting madprops.  It remains
2740  * to be seen how successful this strategy will be...
2741  */
2742
2743 int
2744 Perl_madlex(pTHX)
2745 {
2746     int optype;
2747     char *s = PL_bufptr;
2748
2749     /* make sure PL_thiswhite is initialized */
2750     PL_thiswhite = 0;
2751     PL_thismad = 0;
2752
2753     /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
2754     if (PL_pending_ident)
2755         return S_pending_ident(aTHX);
2756
2757     /* previous token ate up our whitespace? */
2758     if (!PL_lasttoke && PL_nextwhite) {
2759         PL_thiswhite = PL_nextwhite;
2760         PL_nextwhite = 0;
2761     }
2762
2763     /* isolate the token, and figure out where it is without whitespace */
2764     PL_realtokenstart = -1;
2765     PL_thistoken = 0;
2766     optype = yylex();
2767     s = PL_bufptr;
2768     assert(PL_curforce < 0);
2769
2770     if (!PL_thismad || PL_thismad->mad_key == '^') {    /* not forced already? */
2771         if (!PL_thistoken) {
2772             if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
2773                 PL_thistoken = newSVpvn("",0);
2774             else {
2775                 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
2776                 PL_thistoken = newSVpvn(tstart, s - tstart);
2777             }
2778         }
2779         if (PL_thismad) /* install head */
2780             CURMAD('X', PL_thistoken);
2781     }
2782
2783     /* last whitespace of a sublex? */
2784     if (optype == ')' && PL_endwhite) {
2785         CURMAD('X', PL_endwhite);
2786     }
2787
2788     if (!PL_thismad) {
2789
2790         /* if no whitespace and we're at EOF, bail.  Otherwise fake EOF below. */
2791         if (!PL_thiswhite && !PL_endwhite && !optype) {
2792             sv_free(PL_thistoken);
2793             PL_thistoken = 0;
2794             return 0;
2795         }
2796
2797         /* put off final whitespace till peg */
2798         if (optype == ';' && !PL_rsfp) {
2799             PL_nextwhite = PL_thiswhite;
2800             PL_thiswhite = 0;
2801         }
2802         else if (PL_thisopen) {
2803             CURMAD('q', PL_thisopen);
2804             if (PL_thistoken)
2805                 sv_free(PL_thistoken);
2806             PL_thistoken = 0;
2807         }
2808         else {
2809             /* Store actual token text as madprop X */
2810             CURMAD('X', PL_thistoken);
2811         }
2812
2813         if (PL_thiswhite) {
2814             /* add preceding whitespace as madprop _ */
2815             CURMAD('_', PL_thiswhite);
2816         }
2817
2818         if (PL_thisstuff) {
2819             /* add quoted material as madprop = */
2820             CURMAD('=', PL_thisstuff);
2821         }
2822
2823         if (PL_thisclose) {
2824             /* add terminating quote as madprop Q */
2825             CURMAD('Q', PL_thisclose);
2826         }
2827     }
2828
2829     /* special processing based on optype */
2830
2831     switch (optype) {
2832
2833     /* opval doesn't need a TOKEN since it can already store mp */
2834     case WORD:
2835     case METHOD:
2836     case FUNCMETH:
2837     case THING:
2838     case PMFUNC:
2839     case PRIVATEREF:
2840     case FUNC0SUB:
2841     case UNIOPSUB:
2842     case LSTOPSUB:
2843         if (yylval.opval)
2844             append_madprops(PL_thismad, yylval.opval, 0);
2845         PL_thismad = 0;
2846         return optype;
2847
2848     /* fake EOF */
2849     case 0:
2850         optype = PEG;
2851         if (PL_endwhite) {
2852             addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
2853             PL_endwhite = 0;
2854         }
2855         break;
2856
2857     case ']':
2858     case '}':
2859         if (PL_faketokens)
2860             break;
2861         /* remember any fake bracket that lexer is about to discard */
2862         if (PL_lex_brackets == 1 &&
2863             ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
2864         {
2865             s = PL_bufptr;
2866             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2867                 s++;
2868             if (*s == '}') {
2869                 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
2870                 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
2871                 PL_thiswhite = 0;
2872                 PL_bufptr = s - 1;
2873                 break;  /* don't bother looking for trailing comment */
2874             }
2875             else
2876                 s = PL_bufptr;
2877         }
2878         if (optype == ']')
2879             break;
2880         /* FALLTHROUGH */
2881
2882     /* attach a trailing comment to its statement instead of next token */
2883     case ';':
2884         if (PL_faketokens)
2885             break;
2886         if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
2887             s = PL_bufptr;
2888             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2889                 s++;
2890             if (*s == '\n' || *s == '#') {
2891                 while (s < PL_bufend && *s != '\n')
2892                     s++;
2893                 if (s < PL_bufend)
2894                     s++;
2895                 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
2896                 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
2897                 PL_thiswhite = 0;
2898                 PL_bufptr = s;
2899             }
2900         }
2901         break;
2902
2903     /* pval */
2904     case LABEL:
2905         break;
2906
2907     /* ival */
2908     default:
2909         break;
2910
2911     }
2912
2913     /* Create new token struct.  Note: opvals return early above. */
2914     yylval.tkval = newTOKEN(optype, yylval, PL_thismad);
2915     PL_thismad = 0;
2916     return optype;
2917 }
2918 #endif
2919
2920 STATIC char *
2921 S_tokenize_use(pTHX_ int is_use, char *s) {
2922     dVAR;
2923     if (PL_expect != XSTATE)
2924         yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
2925                     is_use ? "use" : "no"));
2926     s = SKIPSPACE1(s);
2927     if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
2928         s = force_version(s, TRUE);
2929         if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
2930             start_force(PL_curforce);
2931             NEXTVAL_NEXTTOKE.opval = NULL;
2932             force_next(WORD);
2933         }
2934         else if (*s == 'v') {
2935             s = force_word(s,WORD,FALSE,TRUE,FALSE);
2936             s = force_version(s, FALSE);
2937         }
2938     }
2939     else {
2940         s = force_word(s,WORD,FALSE,TRUE,FALSE);
2941         s = force_version(s, FALSE);
2942     }
2943     yylval.ival = is_use;
2944     return s;
2945 }
2946 #ifdef DEBUGGING
2947     static const char* const exp_name[] =
2948         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2949           "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2950         };
2951 #endif
2952
2953 /*
2954   yylex
2955
2956   Works out what to call the token just pulled out of the input
2957   stream.  The yacc parser takes care of taking the ops we return and
2958   stitching them into a tree.
2959
2960   Returns:
2961     PRIVATEREF
2962
2963   Structure:
2964       if read an identifier
2965           if we're in a my declaration
2966               croak if they tried to say my($foo::bar)
2967               build the ops for a my() declaration
2968           if it's an access to a my() variable
2969               are we in a sort block?
2970                   croak if my($a); $a <=> $b
2971               build ops for access to a my() variable
2972           if in a dq string, and they've said @foo and we can't find @foo
2973               croak
2974           build ops for a bareword
2975       if we already built the token before, use it.
2976 */
2977
2978
2979 #ifdef __SC__
2980 #pragma segment Perl_yylex
2981 #endif
2982 int
2983 Perl_yylex(pTHX)
2984 {
2985     dVAR;
2986     register char *s = PL_bufptr;
2987     register char *d;
2988     STRLEN len;
2989     bool bof = FALSE;
2990
2991     DEBUG_T( {
2992         SV* tmp = newSVpvs("");
2993         PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
2994             (IV)CopLINE(PL_curcop),
2995             lex_state_names[PL_lex_state],
2996             exp_name[PL_expect],
2997             pv_display(tmp, s, strlen(s), 0, 60));
2998         SvREFCNT_dec(tmp);
2999     } );
3000     /* check if there's an identifier for us to look at */
3001     if (PL_pending_ident)
3002         return REPORT(S_pending_ident(aTHX));
3003
3004     /* no identifier pending identification */
3005
3006     switch (PL_lex_state) {
3007 #ifdef COMMENTARY
3008     case LEX_NORMAL:            /* Some compilers will produce faster */
3009     case LEX_INTERPNORMAL:      /* code if we comment these out. */
3010         break;
3011 #endif
3012
3013     /* when we've already built the next token, just pull it out of the queue */
3014     case LEX_KNOWNEXT:
3015 #ifdef PERL_MAD
3016         PL_lasttoke--;
3017         yylval = PL_nexttoke[PL_lasttoke].next_val;
3018         if (PL_madskills) {
3019             PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3020             PL_nexttoke[PL_lasttoke].next_mad = 0;
3021             if (PL_thismad && PL_thismad->mad_key == '_') {
3022                 PL_thiswhite = (SV*)PL_thismad->mad_val;
3023                 PL_thismad->mad_val = 0;
3024                 mad_free(PL_thismad);
3025                 PL_thismad = 0;
3026             }
3027         }
3028         if (!PL_lasttoke) {
3029             PL_lex_state = PL_lex_defer;
3030             PL_expect = PL_lex_expect;
3031             PL_lex_defer = LEX_NORMAL;
3032             if (!PL_nexttoke[PL_lasttoke].next_type)
3033                 return yylex();
3034         }
3035 #else
3036         PL_nexttoke--;
3037         yylval = PL_nextval[PL_nexttoke];
3038         if (!PL_nexttoke) {
3039             PL_lex_state = PL_lex_defer;
3040             PL_expect = PL_lex_expect;
3041             PL_lex_defer = LEX_NORMAL;
3042         }
3043 #endif
3044 #ifdef PERL_MAD
3045         /* FIXME - can these be merged?  */
3046         return(PL_nexttoke[PL_lasttoke].next_type);
3047 #else
3048         return REPORT(PL_nexttype[PL_nexttoke]);
3049 #endif
3050
3051     /* interpolated case modifiers like \L \U, including \Q and \E.
3052        when we get here, PL_bufptr is at the \
3053     */
3054     case LEX_INTERPCASEMOD:
3055 #ifdef DEBUGGING
3056         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3057             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3058 #endif
3059         /* handle \E or end of string */
3060         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3061             /* if at a \E */
3062             if (PL_lex_casemods) {
3063                 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3064                 PL_lex_casestack[PL_lex_casemods] = '\0';
3065
3066                 if (PL_bufptr != PL_bufend
3067                     && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3068                     PL_bufptr += 2;
3069                     PL_lex_state = LEX_INTERPCONCAT;
3070 #ifdef PERL_MAD
3071                     if (PL_madskills)
3072                         PL_thistoken = newSVpvn("\\E",2);
3073 #endif
3074                 }
3075                 return REPORT(')');
3076             }
3077 #ifdef PERL_MAD
3078             while (PL_bufptr != PL_bufend &&
3079               PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3080                 if (!PL_thiswhite)
3081                     PL_thiswhite = newSVpvn("",0);
3082                 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3083                 PL_bufptr += 2;
3084             }
3085 #else
3086             if (PL_bufptr != PL_bufend)
3087                 PL_bufptr += 2;
3088 #endif
3089             PL_lex_state = LEX_INTERPCONCAT;
3090             return yylex();
3091         }
3092         else {
3093             DEBUG_T({ PerlIO_printf(Perl_debug_log,
3094               "### Saw case modifier\n"); });
3095             s = PL_bufptr + 1;
3096             if (s[1] == '\\' && s[2] == 'E') {
3097 #ifdef PERL_MAD
3098                 if (!PL_thiswhite)
3099                     PL_thiswhite = newSVpvn("",0);
3100                 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3101 #endif
3102                 PL_bufptr = s + 3;
3103                 PL_lex_state = LEX_INTERPCONCAT;
3104                 return yylex();
3105             }
3106             else {
3107                 I32 tmp;
3108                 if (!PL_madskills) /* when just compiling don't need correct */
3109                     if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3110                         tmp = *s, *s = s[2], s[2] = (char)tmp;  /* misordered... */
3111                 if ((*s == 'L' || *s == 'U') &&
3112                     (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3113                     PL_lex_casestack[--PL_lex_casemods] = '\0';
3114                     return REPORT(')');
3115                 }
3116                 if (PL_lex_casemods > 10)
3117                     Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3118                 PL_lex_casestack[PL_lex_casemods++] = *s;
3119                 PL_lex_casestack[PL_lex_casemods] = '\0';
3120                 PL_lex_state = LEX_INTERPCONCAT;
3121                 start_force(PL_curforce);
3122                 NEXTVAL_NEXTTOKE.ival = 0;
3123                 force_next('(');
3124                 start_force(PL_curforce);
3125                 if (*s == 'l')
3126                     NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3127                 else if (*s == 'u')
3128                     NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3129                 else if (*s == 'L')
3130                     NEXTVAL_NEXTTOKE.ival = OP_LC;
3131                 else if (*s == 'U')
3132                     NEXTVAL_NEXTTOKE.ival = OP_UC;
3133                 else if (*s == 'Q')
3134                     NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3135                 else
3136                     Perl_croak(aTHX_ "panic: yylex");
3137                 if (PL_madskills) {
3138                     SV* const tmpsv = newSVpvn("",0);
3139                     Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
3140                     curmad('_', tmpsv);
3141                 }
3142                 PL_bufptr = s + 1;
3143             }
3144             force_next(FUNC);
3145             if (PL_lex_starts) {
3146                 s = PL_bufptr;
3147                 PL_lex_starts = 0;
3148 #ifdef PERL_MAD
3149                 if (PL_madskills) {
3150                     if (PL_thistoken)
3151                         sv_free(PL_thistoken);
3152                     PL_thistoken = newSVpvn("",0);
3153                 }
3154 #endif
3155                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3156                 if (PL_lex_casemods == 1 && PL_lex_inpat)
3157                     OPERATOR(',');
3158                 else
3159                     Aop(OP_CONCAT);
3160             }
3161             else
3162                 return yylex();
3163         }
3164
3165     case LEX_INTERPPUSH:
3166         return REPORT(sublex_push());
3167
3168     case LEX_INTERPSTART:
3169         if (PL_bufptr == PL_bufend)
3170             return REPORT(sublex_done());
3171         DEBUG_T({ PerlIO_printf(Perl_debug_log,
3172               "### Interpolated variable\n"); });
3173         PL_expect = XTERM;
3174         PL_lex_dojoin = (*PL_bufptr == '@');
3175         PL_lex_state = LEX_INTERPNORMAL;
3176         if (PL_lex_dojoin) {
3177             start_force(PL_curforce);
3178             NEXTVAL_NEXTTOKE.ival = 0;
3179             force_next(',');
3180             start_force(PL_curforce);
3181             force_ident("\"", '$');
3182             start_force(PL_curforce);
3183             NEXTVAL_NEXTTOKE.ival = 0;
3184             force_next('$');
3185             start_force(PL_curforce);
3186             NEXTVAL_NEXTTOKE.ival = 0;
3187             force_next('(');
3188             start_force(PL_curforce);
3189             NEXTVAL_NEXTTOKE.ival = OP_JOIN;    /* emulate join($", ...) */
3190             force_next(FUNC);
3191         }
3192         if (PL_lex_starts++) {
3193             s = PL_bufptr;
3194 #ifdef PERL_MAD
3195             if (PL_madskills) {
3196                 if (PL_thistoken)
3197                     sv_free(PL_thistoken);
3198                 PL_thistoken = newSVpvn("",0);
3199             }
3200 #endif
3201             /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3202             if (!PL_lex_casemods && PL_lex_inpat)
3203                 OPERATOR(',');
3204             else
3205                 Aop(OP_CONCAT);
3206         }
3207         return yylex();
3208
3209     case LEX_INTERPENDMAYBE:
3210         if (intuit_more(PL_bufptr)) {
3211             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
3212             break;
3213         }
3214         /* FALL THROUGH */
3215
3216     case LEX_INTERPEND:
3217         if (PL_lex_dojoin) {
3218             PL_lex_dojoin = FALSE;
3219             PL_lex_state = LEX_INTERPCONCAT;
3220 #ifdef PERL_MAD
3221             if (PL_madskills) {
3222                 if (PL_thistoken)
3223                     sv_free(PL_thistoken);
3224                 PL_thistoken = newSVpvn("",0);
3225             }
3226 #endif
3227             return REPORT(')');
3228         }
3229         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3230             && SvEVALED(PL_lex_repl))
3231         {
3232             if (PL_bufptr != PL_bufend)
3233                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3234             PL_lex_repl = NULL;
3235         }
3236         /* FALLTHROUGH */
3237     case LEX_INTERPCONCAT:
3238 #ifdef DEBUGGING
3239         if (PL_lex_brackets)
3240             Perl_croak(aTHX_ "panic: INTERPCONCAT");
3241 #endif
3242         if (PL_bufptr == PL_bufend)
3243             return REPORT(sublex_done());
3244
3245         if (SvIVX(PL_linestr) == '\'') {
3246             SV *sv = newSVsv(PL_linestr);
3247             if (!PL_lex_inpat)
3248                 sv = tokeq(sv);
3249             else if ( PL_hints & HINT_NEW_RE )
3250                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
3251             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3252             s = PL_bufend;
3253         }
3254         else {
3255             s = scan_const(PL_bufptr);
3256             if (*s == '\\')
3257                 PL_lex_state = LEX_INTERPCASEMOD;
3258             else
3259                 PL_lex_state = LEX_INTERPSTART;
3260         }
3261
3262         if (s != PL_bufptr) {
3263             start_force(PL_curforce);
3264             if (PL_madskills) {
3265                 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3266             }
3267             NEXTVAL_NEXTTOKE = yylval;
3268             PL_expect = XTERM;
3269             force_next(THING);
3270             if (PL_lex_starts++) {
3271 #ifdef PERL_MAD
3272                 if (PL_madskills) {
3273                     if (PL_thistoken)
3274                         sv_free(PL_thistoken);
3275                     PL_thistoken = newSVpvn("",0);
3276                 }
3277 #endif
3278                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3279                 if (!PL_lex_casemods && PL_lex_inpat)
3280                     OPERATOR(',');
3281                 else
3282                     Aop(OP_CONCAT);
3283             }
3284             else {
3285                 PL_bufptr = s;
3286                 return yylex();
3287             }
3288         }
3289
3290         return yylex();
3291     case LEX_FORMLINE:
3292         PL_lex_state = LEX_NORMAL;
3293         s = scan_formline(PL_bufptr);
3294         if (!PL_lex_formbrack)
3295             goto rightbracket;
3296         OPERATOR(';');
3297     }
3298
3299     s = PL_bufptr;
3300     PL_oldoldbufptr = PL_oldbufptr;
3301     PL_oldbufptr = s;
3302
3303   retry:
3304 #ifdef PERL_MAD
3305     if (PL_thistoken) {
3306         sv_free(PL_thistoken);
3307         PL_thistoken = 0;
3308     }
3309     PL_realtokenstart = s - SvPVX(PL_linestr);  /* assume but undo on ws */
3310 #endif
3311     switch (*s) {
3312     default:
3313         if (isIDFIRST_lazy_if(s,UTF))
3314             goto keylookup;
3315         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
3316     case 4:
3317     case 26:
3318         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
3319     case 0:
3320 #ifdef PERL_MAD
3321         if (PL_madskills)
3322             PL_faketokens = 0;
3323 #endif
3324         if (!PL_rsfp) {
3325             PL_last_uni = 0;
3326             PL_last_lop = 0;
3327             if (PL_lex_brackets) {
3328                 yyerror(PL_lex_formbrack
3329                     ? "Format not terminated"
3330                     : "Missing right curly or square bracket");
3331             }
3332             DEBUG_T( { PerlIO_printf(Perl_debug_log,
3333                         "### Tokener got EOF\n");
3334             } );
3335             TOKEN(0);
3336         }
3337         if (s++ < PL_bufend)
3338             goto retry;                 /* ignore stray nulls */
3339         PL_last_uni = 0;
3340         PL_last_lop = 0;
3341         if (!PL_in_eval && !PL_preambled) {
3342             PL_preambled = TRUE;
3343 #ifdef PERL_MAD
3344             if (PL_madskills)
3345                 PL_faketokens = 1;
3346 #endif
3347             sv_setpv(PL_linestr,incl_perldb());
3348             if (SvCUR(PL_linestr))
3349                 sv_catpvs(PL_linestr,";");
3350             if (PL_preambleav){
3351                 while(AvFILLp(PL_preambleav) >= 0) {
3352                     SV *tmpsv = av_shift(PL_preambleav);
3353                     sv_catsv(PL_linestr, tmpsv);
3354                     sv_catpvs(PL_linestr, ";");
3355                     sv_free(tmpsv);
3356                 }
3357                 sv_free((SV*)PL_preambleav);
3358                 PL_preambleav = NULL;
3359             }
3360             if (PL_minus_n || PL_minus_p) {
3361                 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3362                 if (PL_minus_l)
3363                     sv_catpvs(PL_linestr,"chomp;");
3364                 if (PL_minus_a) {
3365                     if (PL_minus_F) {
3366                         if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3367                              || *PL_splitstr == '"')
3368                               && strchr(PL_splitstr + 1, *PL_splitstr))
3369                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3370                         else {
3371                             /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3372                                bytes can be used as quoting characters.  :-) */
3373                             const char *splits = PL_splitstr;
3374                             sv_catpvs(PL_linestr, "our @F=split(q\0");
3375                             do {
3376                                 /* Need to \ \s  */
3377                                 if (*splits == '\\')
3378                                     sv_catpvn(PL_linestr, splits, 1);
3379                                 sv_catpvn(PL_linestr, splits, 1);
3380                             } while (*splits++);
3381                             /* This loop will embed the trailing NUL of
3382                                PL_linestr as the last thing it does before
3383                                terminating.  */
3384                             sv_catpvs(PL_linestr, ");");
3385                         }
3386                     }
3387                     else
3388                         sv_catpvs(PL_linestr,"our @F=split(' ');");
3389                 }
3390             }
3391             if (PL_minus_E)
3392                 sv_catpvs(PL_linestr,"use feature ':5.10';");
3393             sv_catpvs(PL_linestr, "\n");
3394             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3395             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3396             PL_last_lop = PL_last_uni = NULL;
3397             if (PERLDB_LINE && PL_curstash != PL_debstash) {
3398                 SV * const sv = newSV(0);
3399
3400                 sv_upgrade(sv, SVt_PVMG);
3401                 sv_setsv(sv,PL_linestr);
3402                 (void)SvIOK_on(sv);
3403                 SvIV_set(sv, 0);
3404                 av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
3405             }
3406             goto retry;
3407         }
3408         do {
3409             bof = PL_rsfp ? TRUE : FALSE;
3410             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3411               fake_eof:
3412 #ifdef PERL_MAD
3413                 PL_realtokenstart = -1;
3414 #endif
3415                 if (PL_rsfp) {
3416                     if (PL_preprocess && !PL_in_eval)
3417                         (void)PerlProc_pclose(PL_rsfp);
3418                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3419                         PerlIO_clearerr(PL_rsfp);
3420                     else
3421                         (void)PerlIO_close(PL_rsfp);
3422                     PL_rsfp = NULL;
3423                     PL_doextract = FALSE;
3424                 }
3425                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3426 #ifdef PERL_MAD
3427                     if (PL_madskills)
3428                         PL_faketokens = 1;
3429 #endif
3430                     sv_setpv(PL_linestr,PL_minus_p
3431                              ? ";}continue{print;}" : ";}");
3432                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3433                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3434                     PL_last_lop = PL_last_uni = NULL;
3435                     PL_minus_n = PL_minus_p = 0;
3436                     goto retry;
3437                 }
3438                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3439                 PL_last_lop = PL_last_uni = NULL;
3440                 sv_setpvn(PL_linestr,"",0);
3441                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
3442             }
3443             /* If it looks like the start of a BOM or raw UTF-16,
3444              * check if it in fact is. */
3445             else if (bof &&
3446                      (*s == 0 ||
3447                       *(U8*)s == 0xEF ||
3448                       *(U8*)s >= 0xFE ||
3449                       s[1] == 0)) {
3450 #ifdef PERLIO_IS_STDIO
3451 #  ifdef __GNU_LIBRARY__
3452 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3453 #      define FTELL_FOR_PIPE_IS_BROKEN
3454 #    endif
3455 #  else
3456 #    ifdef __GLIBC__
3457 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3458 #        define FTELL_FOR_PIPE_IS_BROKEN
3459 #      endif
3460 #    endif
3461 #  endif
3462 #endif
3463 #ifdef FTELL_FOR_PIPE_IS_BROKEN
3464                 /* This loses the possibility to detect the bof
3465                  * situation on perl -P when the libc5 is being used.
3466                  * Workaround?  Maybe attach some extra state to PL_rsfp?
3467                  */
3468                 if (!PL_preprocess)
3469                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
3470 #else
3471                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3472 #endif
3473                 if (bof) {
3474                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3475                     s = swallow_bom((U8*)s);
3476                 }
3477             }
3478             if (PL_doextract) {
3479                 /* Incest with pod. */
3480 #ifdef PERL_MAD
3481                 if (PL_madskills)
3482                     sv_catsv(PL_thiswhite, PL_linestr);
3483 #endif
3484                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
3485                     sv_setpvn(PL_linestr, "", 0);
3486                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3487                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3488                     PL_last_lop = PL_last_uni = NULL;
3489                     PL_doextract = FALSE;
3490                 }
3491             }
3492             incline(s);
3493         } while (PL_doextract);
3494         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3495         if (PERLDB_LINE && PL_curstash != PL_debstash) {
3496             SV * const sv = newSV(0);
3497
3498             sv_upgrade(sv, SVt_PVMG);
3499             sv_setsv(sv,PL_linestr);
3500             (void)SvIOK_on(sv);
3501             SvIV_set(sv, 0);
3502             av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
3503         }
3504         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3505         PL_last_lop = PL_last_uni = NULL;
3506         if (CopLINE(PL_curcop) == 1) {
3507             while (s < PL_bufend && isSPACE(*s))
3508                 s++;
3509             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3510                 s++;
3511 #ifdef PERL_MAD
3512             if (PL_madskills)
3513                 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3514 #endif
3515             d = NULL;
3516             if (!PL_in_eval) {
3517                 if (*s == '#' && *(s+1) == '!')
3518                     d = s + 2;
3519 #ifdef ALTERNATE_SHEBANG
3520                 else {
3521                     static char const as[] = ALTERNATE_SHEBANG;
3522                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3523                         d = s + (sizeof(as) - 1);
3524                 }
3525 #endif /* ALTERNATE_SHEBANG */
3526             }
3527             if (d) {
3528                 char *ipath;
3529                 char *ipathend;
3530
3531                 while (isSPACE(*d))
3532                     d++;
3533                 ipath = d;
3534                 while (*d && !isSPACE(*d))
3535                     d++;
3536                 ipathend = d;
3537
3538 #ifdef ARG_ZERO_IS_SCRIPT
3539                 if (ipathend > ipath) {
3540                     /*
3541                      * HP-UX (at least) sets argv[0] to the script name,
3542                      * which makes $^X incorrect.  And Digital UNIX and Linux,
3543                      * at least, set argv[0] to the basename of the Perl
3544                      * interpreter. So, having found "#!", we'll set it right.
3545                      */
3546                     SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3547                                                     SVt_PV)); /* $^X */
3548                     assert(SvPOK(x) || SvGMAGICAL(x));
3549                     if (sv_eq(x, CopFILESV(PL_curcop))) {
3550                         sv_setpvn(x, ipath, ipathend - ipath);
3551                         SvSETMAGIC(x);
3552                     }
3553                     else {
3554                         STRLEN blen;
3555                         STRLEN llen;
3556                         const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3557                         const char * const lstart = SvPV_const(x,llen);
3558                         if (llen < blen) {
3559                             bstart += blen - llen;
3560                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3561                                 sv_setpvn(x, ipath, ipathend - ipath);
3562                                 SvSETMAGIC(x);
3563                             }
3564                         }
3565                     }
3566                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
3567                 }
3568 #endif /* ARG_ZERO_IS_SCRIPT */
3569
3570                 /*
3571                  * Look for options.
3572                  */
3573                 d = instr(s,"perl -");
3574                 if (!d) {
3575                     d = instr(s,"perl");
3576 #if defined(DOSISH)
3577                     /* avoid getting into infinite loops when shebang
3578                      * line contains "Perl" rather than "perl" */
3579                     if (!d) {
3580                         for (d = ipathend-4; d >= ipath; --d) {
3581                             if ((*d == 'p' || *d == 'P')
3582                                 && !ibcmp(d, "perl", 4))
3583                             {
3584                                 break;
3585                             }
3586                         }
3587                         if (d < ipath)
3588                             d = NULL;
3589                     }
3590 #endif
3591                 }
3592 #ifdef ALTERNATE_SHEBANG
3593                 /*
3594                  * If the ALTERNATE_SHEBANG on this system starts with a
3595                  * character that can be part of a Perl expression, then if
3596                  * we see it but not "perl", we're probably looking at the
3597                  * start of Perl code, not a request to hand off to some
3598                  * other interpreter.  Similarly, if "perl" is there, but
3599                  * not in the first 'word' of the line, we assume the line
3600                  * contains the start of the Perl program.
3601                  */
3602                 if (d && *s != '#') {
3603                     const char *c = ipath;
3604                     while (*c && !strchr("; \t\r\n\f\v#", *c))
3605                         c++;
3606                     if (c < d)
3607                         d = NULL;       /* "perl" not in first word; ignore */
3608                     else
3609                         *s = '#';       /* Don't try to parse shebang line */
3610                 }
3611 #endif /* ALTERNATE_SHEBANG */
3612 #ifndef MACOS_TRADITIONAL
3613                 if (!d &&
3614                     *s == '#' &&
3615                     ipathend > ipath &&
3616                     !PL_minus_c &&
3617                     !instr(s,"indir") &&
3618                     instr(PL_origargv[0],"perl"))
3619                 {
3620                     dVAR;
3621                     char **newargv;
3622
3623                     *ipathend = '\0';
3624                     s = ipathend + 1;
3625                     while (s < PL_bufend && isSPACE(*s))
3626                         s++;
3627                     if (s < PL_bufend) {
3628                         Newxz(newargv,PL_origargc+3,char*);
3629                         newargv[1] = s;
3630                         while (s < PL_bufend && !isSPACE(*s))
3631                             s++;
3632                         *s = '\0';
3633                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3634                     }
3635                     else
3636                         newargv = PL_origargv;
3637                     newargv[0] = ipath;
3638                     PERL_FPU_PRE_EXEC
3639                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3640                     PERL_FPU_POST_EXEC
3641                     Perl_croak(aTHX_ "Can't exec %s", ipath);
3642                 }
3643 #endif
3644                 if (d) {
3645                     while (*d && !isSPACE(*d)) d++;
3646                     while (SPACE_OR_TAB(*d)) d++;
3647
3648                     if (*d++ == '-') {
3649                         const bool switches_done = PL_doswitches;
3650                         const U32 oldpdb = PL_perldb;
3651                         const bool oldn = PL_minus_n;
3652                         const bool oldp = PL_minus_p;
3653
3654                         do {
3655                             if (*d == 'M' || *d == 'm' || *d == 'C') {
3656                                 const char * const m = d;
3657                                 while (*d && !isSPACE(*d))
3658                                     d++;
3659                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3660                                       (int)(d - m), m);
3661                             }
3662                             d = moreswitches(d);
3663                         } while (d);
3664                         if (PL_doswitches && !switches_done) {
3665                             int argc = PL_origargc;
3666                             char **argv = PL_origargv;
3667                             do {
3668                                 argc--,argv++;
3669                             } while (argc && argv[0][0] == '-' && argv[0][1]);
3670                             init_argv_symbols(argc,argv);
3671                         }
3672                         if ((PERLDB_LINE && !oldpdb) ||
3673                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
3674                               /* if we have already added "LINE: while (<>) {",
3675                                  we must not do it again */
3676                         {
3677                             sv_setpvn(PL_linestr, "", 0);
3678                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3679                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3680                             PL_last_lop = PL_last_uni = NULL;
3681                             PL_preambled = FALSE;
3682                             if (PERLDB_LINE)
3683                                 (void)gv_fetchfile(PL_origfilename);
3684                             goto retry;
3685                         }
3686                     }
3687                 }
3688             }
3689         }
3690         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3691             PL_bufptr = s;
3692             PL_lex_state = LEX_FORMLINE;
3693             return yylex();
3694         }
3695         goto retry;
3696     case '\r':
3697 #ifdef PERL_STRICT_CR
3698         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3699         Perl_croak(aTHX_
3700       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3701 #endif
3702     case ' ': case '\t': case '\f': case 013:
3703 #ifdef MACOS_TRADITIONAL
3704     case '\312':
3705 #endif
3706 #ifdef PERL_MAD
3707         PL_realtokenstart = -1;
3708         s = SKIPSPACE0(s);
3709 #else
3710         s++;
3711 #endif
3712         goto retry;
3713     case '#':
3714     case '\n':
3715 #ifdef PERL_MAD
3716         PL_realtokenstart = -1;
3717         if (PL_madskills)
3718             PL_faketokens = 0;
3719 #endif
3720         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3721             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3722                 /* handle eval qq[#line 1 "foo"\n ...] */
3723                 CopLINE_dec(PL_curcop);
3724                 incline(s);
3725             }
3726             if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
3727                 s = SKIPSPACE0(s);
3728                 if (!PL_in_eval || PL_rsfp)
3729                     incline(s);
3730             }
3731             else {
3732                 d = s;
3733                 while (d < PL_bufend && *d != '\n')
3734                     d++;
3735                 if (d < PL_bufend)
3736                     d++;
3737                 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3738                   Perl_croak(aTHX_ "panic: input overflow");
3739 #ifdef PERL_MAD
3740                 if (PL_madskills)
3741                     PL_thiswhite = newSVpvn(s, d - s);
3742 #endif
3743                 s = d;
3744                 incline(s);
3745             }
3746             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3747                 PL_bufptr = s;
3748                 PL_lex_state = LEX_FORMLINE;
3749                 return yylex();
3750             }
3751         }
3752         else {
3753 #ifdef PERL_MAD
3754             if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
3755                 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
3756                     PL_faketokens = 0;
3757                     s = SKIPSPACE0(s);
3758                     TOKEN(PEG); /* make sure any #! line is accessible */
3759                 }
3760                 s = SKIPSPACE0(s);
3761             }
3762             else {
3763 /*              if (PL_madskills && PL_lex_formbrack) { */
3764                     d = s;
3765                     while (d < PL_bufend && *d != '\n')
3766                         d++;
3767                     if (d < PL_bufend)
3768                         d++;
3769                     else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3770                       Perl_croak(aTHX_ "panic: input overflow");
3771                     if (PL_madskills && CopLINE(PL_curcop) >= 1) {
3772                         if (!PL_thiswhite)
3773                             PL_thiswhite = newSVpvn("",0);
3774                         if (CopLINE(PL_curcop) == 1) {
3775                             sv_setpvn(PL_thiswhite, "", 0);
3776                             PL_faketokens = 0;
3777                         }
3778                         sv_catpvn(PL_thiswhite, s, d - s);
3779                     }
3780                     s = d;
3781 /*              }
3782                 *s = '\0';
3783                 PL_bufend = s; */
3784             }
3785 #else
3786             *s = '\0';
3787             PL_bufend = s;
3788 #endif
3789         }
3790         goto retry;
3791     case '-':
3792         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
3793             I32 ftst = 0;
3794             char tmp;
3795
3796             s++;
3797             PL_bufptr = s;
3798             tmp = *s++;
3799
3800             while (s < PL_bufend && SPACE_OR_TAB(*s))
3801                 s++;
3802
3803             if (strnEQ(s,"=>",2)) {
3804                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
3805                 DEBUG_T( { S_printbuf(aTHX_
3806                         "### Saw unary minus before =>, forcing word %s\n", s);
3807                 } );
3808                 OPERATOR('-');          /* unary minus */
3809             }
3810             PL_last_uni = PL_oldbufptr;
3811             switch (tmp) {
3812             case 'r': ftst = OP_FTEREAD;        break;
3813             case 'w': ftst = OP_FTEWRITE;       break;
3814             case 'x': ftst = OP_FTEEXEC;        break;
3815             case 'o': ftst = OP_FTEOWNED;       break;
3816             case 'R': ftst = OP_FTRREAD;        break;
3817             case 'W': ftst = OP_FTRWRITE;       break;
3818             case 'X': ftst = OP_FTREXEC;        break;
3819             case 'O': ftst = OP_FTROWNED;       break;
3820             case 'e': ftst = OP_FTIS;           break;
3821             case 'z': ftst = OP_FTZERO;         break;
3822             case 's': ftst = OP_FTSIZE;         break;
3823             case 'f': ftst = OP_FTFILE;         break;
3824             case 'd': ftst = OP_FTDIR;          break;
3825             case 'l': ftst = OP_FTLINK;         break;
3826             case 'p': ftst = OP_FTPIPE;         break;
3827             case 'S': ftst = OP_FTSOCK;         break;
3828             case 'u': ftst = OP_FTSUID;         break;
3829             case 'g': ftst = OP_FTSGID;         break;
3830             case 'k': ftst = OP_FTSVTX;         break;
3831             case 'b': ftst = OP_FTBLK;          break;
3832             case 'c': ftst = OP_FTCHR;          break;
3833             case 't': ftst = OP_FTTTY;          break;
3834             case 'T': ftst = OP_FTTEXT;         break;
3835             case 'B': ftst = OP_FTBINARY;       break;
3836             case 'M': case 'A': case 'C':
3837                 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
3838                 switch (tmp) {
3839                 case 'M': ftst = OP_FTMTIME;    break;
3840                 case 'A': ftst = OP_FTATIME;    break;
3841                 case 'C': ftst = OP_FTCTIME;    break;
3842                 default:                        break;
3843                 }
3844                 break;
3845             default:
3846                 break;
3847             }
3848             if (ftst) {
3849                 PL_last_lop_op = (OPCODE)ftst;
3850                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3851                         "### Saw file test %c\n", (int)tmp);
3852                 } );
3853                 FTST(ftst);
3854             }
3855             else {
3856                 /* Assume it was a minus followed by a one-letter named
3857                  * subroutine call (or a -bareword), then. */
3858                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3859                         "### '-%c' looked like a file test but was not\n",
3860                         (int) tmp);
3861                 } );
3862                 s = --PL_bufptr;
3863             }
3864         }
3865         {
3866             const char tmp = *s++;
3867             if (*s == tmp) {
3868                 s++;
3869                 if (PL_expect == XOPERATOR)
3870                     TERM(POSTDEC);
3871                 else
3872                     OPERATOR(PREDEC);
3873             }
3874             else if (*s == '>') {
3875                 s++;
3876                 s = SKIPSPACE1(s);
3877                 if (isIDFIRST_lazy_if(s,UTF)) {
3878                     s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3879                     TOKEN(ARROW);
3880                 }
3881                 else if (*s == '$')
3882                     OPERATOR(ARROW);
3883                 else
3884                     TERM(ARROW);
3885             }
3886             if (PL_expect == XOPERATOR)
3887                 Aop(OP_SUBTRACT);
3888             else {
3889                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3890                     check_uni();
3891                 OPERATOR('-');          /* unary minus */
3892             }
3893         }
3894
3895     case '+':
3896         {
3897             const char tmp = *s++;
3898             if (*s == tmp) {
3899                 s++;
3900                 if (PL_expect == XOPERATOR)
3901                     TERM(POSTINC);
3902                 else
3903                     OPERATOR(PREINC);
3904             }
3905             if (PL_expect == XOPERATOR)
3906                 Aop(OP_ADD);
3907             else {
3908                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3909                     check_uni();
3910                 OPERATOR('+');
3911             }
3912         }
3913
3914     case '*':
3915         if (PL_expect != XOPERATOR) {
3916             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3917             PL_expect = XOPERATOR;
3918             force_ident(PL_tokenbuf, '*');
3919             if (!*PL_tokenbuf)
3920                 PREREF('*');
3921             TERM('*');
3922         }
3923         s++;
3924         if (*s == '*') {
3925             s++;
3926             PWop(OP_POW);
3927         }
3928         Mop(OP_MULTIPLY);
3929
3930     case '%':
3931         if (PL_expect == XOPERATOR) {
3932             ++s;
3933             Mop(OP_MODULO);
3934         }
3935         PL_tokenbuf[0] = '%';
3936         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3937         if (!PL_tokenbuf[1]) {
3938             PREREF('%');
3939         }
3940         PL_pending_ident = '%';
3941         TERM('%');
3942
3943     case '^':
3944         s++;
3945         BOop(OP_BIT_XOR);
3946     case '[':
3947         PL_lex_brackets++;
3948         /* FALL THROUGH */
3949     case '~':
3950         if (s[1] == '~'
3951         && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)
3952         && FEATURE_IS_ENABLED("~~"))
3953         {
3954             s += 2;
3955             Eop(OP_SMARTMATCH);
3956         }
3957     case ',':
3958         {
3959             const char tmp = *s++;
3960             OPERATOR(tmp);
3961         }
3962     case ':':
3963         if (s[1] == ':') {
3964             len = 0;
3965             goto just_a_word_zero_gv;
3966         }
3967         s++;
3968         switch (PL_expect) {
3969             OP *attrs;
3970 #ifdef PERL_MAD
3971             I32 stuffstart;
3972 #endif
3973         case XOPERATOR:
3974             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3975                 break;
3976             PL_bufptr = s;      /* update in case we back off */
3977             goto grabattrs;
3978         case XATTRBLOCK:
3979             PL_expect = XBLOCK;
3980             goto grabattrs;
3981         case XATTRTERM:
3982             PL_expect = XTERMBLOCK;
3983          grabattrs:
3984 #ifdef PERL_MAD
3985             stuffstart = s - SvPVX(PL_linestr) - 1;
3986 #endif
3987             s = PEEKSPACE(s);
3988             attrs = NULL;
3989             while (isIDFIRST_lazy_if(s,UTF)) {
3990                 I32 tmp;
3991                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3992                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3993                     if (tmp < 0) tmp = -tmp;
3994                     switch (tmp) {
3995                     case KEY_or:
3996                     case KEY_and:
3997                     case KEY_err:
3998                     case KEY_for:
3999                     case KEY_unless:
4000                     case KEY_if:
4001                     case KEY_while:
4002                     case KEY_until:
4003                         goto got_attrs;
4004                     default:
4005                         break;
4006                     }
4007                 }
4008                 if (*d == '(') {
4009                     d = scan_str(d,TRUE,TRUE);
4010                     if (!d) {
4011                         /* MUST advance bufptr here to avoid bogus
4012                            "at end of line" context messages from yyerror().
4013                          */
4014                         PL_bufptr = s + len;
4015                         yyerror("Unterminated attribute parameter in attribute list");
4016                         if (attrs)
4017                             op_free(attrs);
4018                         return REPORT(0);       /* EOF indicator */
4019                     }
4020                 }
4021                 if (PL_lex_stuff) {
4022                     SV *sv = newSVpvn(s, len);
4023                     sv_catsv(sv, PL_lex_stuff);
4024                     attrs = append_elem(OP_LIST, attrs,
4025                                         newSVOP(OP_CONST, 0, sv));
4026                     SvREFCNT_dec(PL_lex_stuff);
4027                     PL_lex_stuff = NULL;
4028                 }
4029                 else {
4030                     if (len == 6 && strnEQ(s, "unique", len)) {
4031                         if (PL_in_my == KEY_our) {
4032 #ifdef USE_ITHREADS
4033                             GvUNIQUE_on(cGVOPx_gv(yylval.opval));
4034 #else
4035                             /* skip to avoid loading attributes.pm */
4036 #endif
4037                             deprecate(":unique");
4038                         }
4039                         else
4040                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4041                     }
4042
4043                     /* NOTE: any CV attrs applied here need to be part of
4044                        the CVf_BUILTIN_ATTRS define in cv.h! */
4045                     else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
4046                         CvLVALUE_on(PL_compcv);
4047                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
4048                         CvLOCKED_on(PL_compcv);
4049                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
4050                         CvMETHOD_on(PL_compcv);
4051                     else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
4052                         CvASSERTION_on(PL_compcv);
4053                     /* After we've set the flags, it could be argued that
4054                        we don't need to do the attributes.pm-based setting
4055                        process, and shouldn't bother appending recognized
4056                        flags.  To experiment with that, uncomment the
4057                        following "else".  (Note that's already been
4058                        uncommented.  That keeps the above-applied built-in
4059                        attributes from being intercepted (and possibly
4060                        rejected) by a package's attribute routines, but is
4061                        justified by the performance win for the common case
4062                        of applying only built-in attributes.) */
4063                     else
4064                         attrs = append_elem(OP_LIST, attrs,
4065                                             newSVOP(OP_CONST, 0,
4066                                                     newSVpvn(s, len)));
4067                 }
4068                 s = PEEKSPACE(d);
4069                 if (*s == ':' && s[1] != ':')
4070                     s = PEEKSPACE(s+1);
4071                 else if (s == d)
4072                     break;      /* require real whitespace or :'s */
4073                 /* XXX losing whitespace on sequential attributes here */
4074             }
4075             {
4076                 const char tmp
4077                     = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4078                 if (*s != ';' && *s != '}' && *s != tmp
4079                     && (tmp != '=' || *s != ')')) {
4080                     const char q = ((*s == '\'') ? '"' : '\'');
4081                     /* If here for an expression, and parsed no attrs, back
4082                        off. */
4083                     if (tmp == '=' && !attrs) {
4084                         s = PL_bufptr;
4085                         break;
4086                     }
4087                     /* MUST advance bufptr here to avoid bogus "at end of line"
4088                        context messages from yyerror().
4089                     */
4090                     PL_bufptr = s;
4091                     yyerror( *s
4092                              ? Perl_form(aTHX_ "Invalid separator character "
4093                                          "%c%c%c in attribute list", q, *s, q)
4094                              : "Unterminated attribute list" );
4095                     if (attrs)
4096                         op_free(attrs);
4097                     OPERATOR(':');
4098                 }
4099             }
4100         got_attrs:
4101             if (attrs) {
4102                 start_force(PL_curforce);
4103                 NEXTVAL_NEXTTOKE.opval = attrs;
4104                 CURMAD('_', PL_nextwhite);
4105                 force_next(THING);
4106             }
4107 #ifdef PERL_MAD
4108             if (PL_madskills) {
4109                 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4110                                      (s - SvPVX(PL_linestr)) - stuffstart);
4111             }
4112 #endif
4113             TOKEN(COLONATTR);
4114         }
4115         OPERATOR(':');
4116     case '(':
4117         s++;
4118         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4119             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
4120         else
4121             PL_expect = XTERM;
4122         s = SKIPSPACE1(s);
4123         TOKEN('(');
4124     case ';':
4125         CLINE;
4126         {
4127             const char tmp = *s++;
4128             OPERATOR(tmp);
4129         }
4130     case ')':
4131         {
4132             const char tmp = *s++;
4133             s = SKIPSPACE1(s);
4134             if (*s == '{')
4135                 PREBLOCK(tmp);
4136             TERM(tmp);
4137         }
4138     case ']':
4139         s++;
4140         if (PL_lex_brackets <= 0)
4141             yyerror("Unmatched right square bracket");
4142         else
4143             --PL_lex_brackets;
4144         if (PL_lex_state == LEX_INTERPNORMAL) {
4145             if (PL_lex_brackets == 0) {
4146                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
4147                     PL_lex_state = LEX_INTERPEND;
4148             }
4149         }
4150         TERM(']');
4151     case '{':
4152       leftbracket:
4153         s++;
4154         if (PL_lex_brackets > 100) {
4155             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4156         }
4157         switch (PL_expect) {
4158         case XTERM:
4159             if (PL_lex_formbrack) {
4160                 s--;
4161                 PRETERMBLOCK(DO);
4162             }
4163             if (PL_oldoldbufptr == PL_last_lop)
4164                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4165             else
4166                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4167             OPERATOR(HASHBRACK);
4168         case XOPERATOR:
4169             while (s < PL_bufend && SPACE_OR_TAB(*s))
4170                 s++;
4171             d = s;
4172             PL_tokenbuf[0] = '\0';
4173             if (d < PL_bufend && *d == '-') {
4174                 PL_tokenbuf[0] = '-';
4175                 d++;
4176                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4177                     d++;
4178             }
4179             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4180                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4181                               FALSE, &len);
4182                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4183                     d++;
4184                 if (*d == '}') {
4185                     const char minus = (PL_tokenbuf[0] == '-');
4186                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4187                     if (minus)
4188                         force_next('-');
4189                 }
4190             }
4191             /* FALL THROUGH */
4192         case XATTRBLOCK:
4193         case XBLOCK:
4194             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4195             PL_expect = XSTATE;
4196             break;
4197         case XATTRTERM:
4198         case XTERMBLOCK:
4199             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4200             PL_expect = XSTATE;
4201             break;
4202         default: {
4203                 const char *t;
4204                 if (PL_oldoldbufptr == PL_last_lop)
4205                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4206                 else
4207                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4208                 s = SKIPSPACE1(s);
4209                 if (*s == '}') {
4210                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4211                         PL_expect = XTERM;
4212                         /* This hack is to get the ${} in the message. */
4213                         PL_bufptr = s+1;
4214                         yyerror("syntax error");
4215                         break;
4216                     }
4217                     OPERATOR(HASHBRACK);
4218                 }
4219                 /* This hack serves to disambiguate a pair of curlies
4220                  * as being a block or an anon hash.  Normally, expectation
4221                  * determines that, but in cases where we're not in a
4222                  * position to expect anything in particular (like inside
4223                  * eval"") we have to resolve the ambiguity.  This code
4224                  * covers the case where the first term in the curlies is a
4225                  * quoted string.  Most other cases need to be explicitly
4226                  * disambiguated by prepending a "+" before the opening
4227                  * curly in order to force resolution as an anon hash.
4228                  *
4229                  * XXX should probably propagate the outer expectation
4230                  * into eval"" to rely less on this hack, but that could
4231                  * potentially break current behavior of eval"".
4232                  * GSAR 97-07-21
4233                  */
4234                 t = s;
4235                 if (*s == '\'' || *s == '"' || *s == '`') {
4236                     /* common case: get past first string, handling escapes */
4237                     for (t++; t < PL_bufend && *t != *s;)
4238                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
4239                             t++;
4240                     t++;
4241                 }
4242                 else if (*s == 'q') {
4243                     if (++t < PL_bufend
4244                         && (!isALNUM(*t)
4245                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4246                                 && !isALNUM(*t))))
4247                     {
4248                         /* skip q//-like construct */
4249                         const char *tmps;
4250                         char open, close, term;
4251                         I32 brackets = 1;
4252
4253                         while (t < PL_bufend && isSPACE(*t))
4254                             t++;
4255                         /* check for q => */
4256                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4257                             OPERATOR(HASHBRACK);
4258                         }
4259                         term = *t;
4260                         open = term;
4261                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4262                             term = tmps[5];
4263                         close = term;
4264                         if (open == close)
4265                             for (t++; t < PL_bufend; t++) {
4266                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4267                                     t++;
4268                                 else if (*t == open)
4269                                     break;
4270                             }
4271                         else {
4272                             for (t++; t < PL_bufend; t++) {
4273                                 if (*t == '\\' && t+1 < PL_bufend)
4274                                     t++;
4275                                 else if (*t == close && --brackets <= 0)
4276                                     break;
4277                                 else if (*t == open)
4278                                     brackets++;
4279                             }
4280                         }
4281                         t++;
4282                     }
4283                     else
4284                         /* skip plain q word */
4285                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4286                              t += UTF8SKIP(t);
4287                 }
4288                 else if (isALNUM_lazy_if(t,UTF)) {
4289                     t += UTF8SKIP(t);
4290                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4291                          t += UTF8SKIP(t);
4292                 }
4293                 while (t < PL_bufend && isSPACE(*t))
4294                     t++;
4295                 /* if comma follows first term, call it an anon hash */
4296                 /* XXX it could be a comma expression with loop modifiers */
4297                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4298                                    || (*t == '=' && t[1] == '>')))
4299                     OPERATOR(HASHBRACK);
4300                 if (PL_expect == XREF)
4301                     PL_expect = XTERM;
4302                 else {
4303                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4304                     PL_expect = XSTATE;
4305                 }
4306             }
4307             break;
4308         }
4309         yylval.ival = CopLINE(PL_curcop);
4310         if (isSPACE(*s) || *s == '#')
4311             PL_copline = NOLINE;   /* invalidate current command line number */
4312         TOKEN('{');
4313     case '}':
4314       rightbracket:
4315         s++;
4316         if (PL_lex_brackets <= 0)
4317             yyerror("Unmatched right curly bracket");
4318         else
4319             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4320         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4321             PL_lex_formbrack = 0;
4322         if (PL_lex_state == LEX_INTERPNORMAL) {
4323             if (PL_lex_brackets == 0) {
4324                 if (PL_expect & XFAKEBRACK) {
4325                     PL_expect &= XENUMMASK;
4326                     PL_lex_state = LEX_INTERPEND;
4327                     PL_bufptr = s;
4328 #if 0
4329                     if (PL_madskills) {
4330                         if (!PL_thiswhite)
4331                             PL_thiswhite = newSVpvn("",0);
4332                         sv_catpvn(PL_thiswhite,"}",1);
4333                     }
4334 #endif
4335                     return yylex();     /* ignore fake brackets */
4336                 }
4337                 if (*s == '-' && s[1] == '>')
4338                     PL_lex_state = LEX_INTERPENDMAYBE;
4339                 else if (*s != '[' && *s != '{')
4340                     PL_lex_state = LEX_INTERPEND;
4341             }
4342         }
4343         if (PL_expect & XFAKEBRACK) {
4344             PL_expect &= XENUMMASK;
4345             PL_bufptr = s;
4346             return yylex();             /* ignore fake brackets */
4347         }
4348         start_force(PL_curforce);
4349         if (PL_madskills) {
4350             curmad('X', newSVpvn(s-1,1));
4351             CURMAD('_', PL_thiswhite);
4352         }
4353         force_next('}');
4354 #ifdef PERL_MAD
4355         if (!PL_thistoken)
4356             PL_thistoken = newSVpvn("",0);
4357 #endif
4358         TOKEN(';');
4359     case '&':
4360         s++;
4361         if (*s++ == '&')
4362             AOPERATOR(ANDAND);
4363         s--;
4364         if (PL_expect == XOPERATOR) {
4365             if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4366                 && isIDFIRST_lazy_if(s,UTF))
4367             {
4368                 CopLINE_dec(PL_curcop);
4369                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4370                 CopLINE_inc(PL_curcop);
4371             }
4372             BAop(OP_BIT_AND);
4373         }
4374
4375         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4376         if (*PL_tokenbuf) {
4377             PL_expect = XOPERATOR;
4378             force_ident(PL_tokenbuf, '&');
4379         }
4380         else
4381             PREREF('&');
4382         yylval.ival = (OPpENTERSUB_AMPER<<8);
4383         TERM('&');
4384
4385     case '|':
4386         s++;
4387         if (*s++ == '|')
4388             AOPERATOR(OROR);
4389         s--;
4390         BOop(OP_BIT_OR);
4391     case '=':
4392         s++;
4393         {
4394             const char tmp = *s++;
4395             if (tmp == '=')
4396                 Eop(OP_EQ);
4397             if (tmp == '>')
4398                 OPERATOR(',');
4399             if (tmp == '~')
4400                 PMop(OP_MATCH);
4401             if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4402                 && strchr("+-*/%.^&|<",tmp))
4403                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4404                             "Reversed %c= operator",(int)tmp);
4405             s--;
4406             if (PL_expect == XSTATE && isALPHA(tmp) &&
4407                 (s == PL_linestart+1 || s[-2] == '\n') )
4408                 {
4409                     if (PL_in_eval && !PL_rsfp) {
4410                         d = PL_bufend;
4411                         while (s < d) {
4412                             if (*s++ == '\n') {
4413                                 incline(s);
4414                                 if (strnEQ(s,"=cut",4)) {
4415                                     s = strchr(s,'\n');
4416                                     if (s)
4417                                         s++;
4418                                     else
4419                                         s = d;
4420                                     incline(s);
4421                                     goto retry;
4422                                 }
4423                             }
4424                         }
4425                         goto retry;
4426                     }
4427 #ifdef PERL_MAD
4428                     if (PL_madskills) {
4429                         if (!PL_thiswhite)
4430                             PL_thiswhite = newSVpvn("",0);
4431                         sv_catpvn(PL_thiswhite, PL_linestart,
4432                                   PL_bufend - PL_linestart);
4433                     }
4434 #endif
4435                     s = PL_bufend;
4436                     PL_doextract = TRUE;
4437                     goto retry;
4438                 }
4439         }
4440         if (PL_lex_brackets < PL_lex_formbrack) {
4441             const char *t;
4442 #ifdef PERL_STRICT_CR
4443             for (t = s; SPACE_OR_TAB(*t); t++) ;
4444 #else
4445             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
4446 #endif
4447             if (*t == '\n' || *t == '#') {
4448                 s--;
4449                 PL_expect = XBLOCK;
4450                 goto leftbracket;
4451             }
4452         }
4453         yylval.ival = 0;
4454         OPERATOR(ASSIGNOP);
4455     case '!':
4456         s++;
4457         {
4458             const char tmp = *s++;
4459             if (tmp == '=') {
4460                 /* was this !=~ where !~ was meant?
4461                  * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4462
4463                 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4464                     const char *t = s+1;
4465
4466                     while (t < PL_bufend && isSPACE(*t))
4467                         ++t;
4468
4469                     if (*t == '/' || *t == '?' ||
4470                         ((*t == 'm' || *t == 's' || *t == 'y')
4471                          && !isALNUM(t[1])) ||
4472                         (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4473                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4474                                     "!=~ should be !~");
4475                 }
4476                 Eop(OP_NE);
4477             }
4478             if (tmp == '~')
4479                 PMop(OP_NOT);
4480         }
4481         s--;
4482         OPERATOR('!');
4483     case '<':
4484         if (PL_expect != XOPERATOR) {
4485             if (s[1] != '<' && !strchr(s,'>'))
4486                 check_uni();
4487             if (s[1] == '<')
4488                 s = scan_heredoc(s);
4489             else
4490                 s = scan_inputsymbol(s);
4491             TERM(sublex_start());
4492         }
4493         s++;
4494         {
4495             char tmp = *s++;
4496             if (tmp == '<')
4497                 SHop(OP_LEFT_SHIFT);
4498             if (tmp == '=') {
4499                 tmp = *s++;
4500                 if (tmp == '>')
4501                     Eop(OP_NCMP);
4502                 s--;
4503                 Rop(OP_LE);
4504             }
4505         }
4506         s--;
4507         Rop(OP_LT);
4508     case '>':
4509         s++;
4510         {
4511             const char tmp = *s++;
4512             if (tmp == '>')
4513                 SHop(OP_RIGHT_SHIFT);
4514             else if (tmp == '=')
4515                 Rop(OP_GE);
4516         }
4517         s--;
4518         Rop(OP_GT);
4519
4520     case '$':
4521         CLINE;
4522
4523         if (PL_expect == XOPERATOR) {
4524             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4525                 PL_expect = XTERM;
4526                 deprecate_old(commaless_variable_list);
4527                 return REPORT(','); /* grandfather non-comma-format format */
4528             }
4529         }
4530
4531         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4532             PL_tokenbuf[0] = '@';
4533             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4534                            sizeof PL_tokenbuf - 1, FALSE);
4535             if (PL_expect == XOPERATOR)
4536                 no_op("Array length", s);
4537             if (!PL_tokenbuf[1])
4538                 PREREF(DOLSHARP);
4539             PL_expect = XOPERATOR;
4540             PL_pending_ident = '#';
4541             TOKEN(DOLSHARP);
4542         }
4543
4544         PL_tokenbuf[0] = '$';
4545         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4546                        sizeof PL_tokenbuf - 1, FALSE);
4547         if (PL_expect == XOPERATOR)
4548             no_op("Scalar", s);
4549         if (!PL_tokenbuf[1]) {
4550             if (s == PL_bufend)
4551                 yyerror("Final $ should be \\$ or $name");
4552             PREREF('$');
4553         }
4554
4555         /* This kludge not intended to be bulletproof. */
4556         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4557             yylval.opval = newSVOP(OP_CONST, 0,
4558                                    newSViv(CopARYBASE_get(&PL_compiling)));
4559             yylval.opval->op_private = OPpCONST_ARYBASE;
4560             TERM(THING);
4561         }
4562
4563         d = s;
4564         {
4565             const char tmp = *s;
4566             if (PL_lex_state == LEX_NORMAL)
4567                 s = SKIPSPACE1(s);
4568
4569             if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4570                 && intuit_more(s)) {
4571                 if (*s == '[') {
4572                     PL_tokenbuf[0] = '@';
4573                     if (ckWARN(WARN_SYNTAX)) {
4574                         char *t;
4575                         for(t = s + 1;
4576                             isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
4577                             t++) ;
4578                         if (*t++ == ',') {
4579                             PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4580                             while (t < PL_bufend && *t != ']')
4581                                 t++;
4582                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4583                                         "Multidimensional syntax %.*s not supported",
4584                                     (int)((t - PL_bufptr) + 1), PL_bufptr);
4585                         }
4586                     }
4587                 }
4588                 else if (*s == '{') {
4589                     char *t;
4590                     PL_tokenbuf[0] = '%';
4591                     if (strEQ(PL_tokenbuf+1, "SIG")  && ckWARN(WARN_SYNTAX)
4592                         && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4593                         {
4594                             char tmpbuf[sizeof PL_tokenbuf];
4595                             for (t++; isSPACE(*t); t++) ;
4596                             if (isIDFIRST_lazy_if(t,UTF)) {
4597                                 STRLEN dummylen;
4598                                 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4599                                               &dummylen);
4600                                 for (; isSPACE(*t); t++) ;
4601                                 if (*t == ';' && get_cv(tmpbuf, FALSE))
4602                                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4603                                                 "You need to quote \"%s\"",
4604                                                 tmpbuf);
4605                             }
4606                         }
4607                 }
4608             }
4609
4610             PL_expect = XOPERATOR;
4611             if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4612                 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4613                 if (!islop || PL_last_lop_op == OP_GREPSTART)
4614                     PL_expect = XOPERATOR;
4615                 else if (strchr("$@\"'`q", *s))
4616                     PL_expect = XTERM;          /* e.g. print $fh "foo" */
4617                 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4618                     PL_expect = XTERM;          /* e.g. print $fh &sub */
4619                 else if (isIDFIRST_lazy_if(s,UTF)) {
4620                     char tmpbuf[sizeof PL_tokenbuf];
4621                     int t2;
4622                     scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4623                     if ((t2 = keyword(tmpbuf, len))) {
4624                         /* binary operators exclude handle interpretations */
4625                         switch (t2) {
4626                         case -KEY_x:
4627                         case -KEY_eq:
4628                         case -KEY_ne:
4629                         case -KEY_gt:
4630                         case -KEY_lt:
4631                         case -KEY_ge:
4632                         case -KEY_le:
4633                         case -KEY_cmp:
4634                             break;
4635                         default:
4636                             PL_expect = XTERM;  /* e.g. print $fh length() */
4637                             break;
4638                         }
4639                     }
4640                     else {
4641                         PL_expect = XTERM;      /* e.g. print $fh subr() */
4642                     }
4643                 }
4644                 else if (isDIGIT(*s))
4645                     PL_expect = XTERM;          /* e.g. print $fh 3 */
4646                 else if (*s == '.' && isDIGIT(s[1]))
4647                     PL_expect = XTERM;          /* e.g. print $fh .3 */
4648                 else if ((*s == '?' || *s == '-' || *s == '+')
4649                          && !isSPACE(s[1]) && s[1] != '=')
4650                     PL_expect = XTERM;          /* e.g. print $fh -1 */
4651                 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
4652                          && s[1] != '/')
4653                     PL_expect = XTERM;          /* e.g. print $fh /.../
4654                                                    XXX except DORDOR operator
4655                                                 */
4656                 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
4657                          && s[2] != '=')
4658                     PL_expect = XTERM;          /* print $fh <<"EOF" */
4659             }
4660         }
4661         PL_pending_ident = '$';
4662         TOKEN('$');
4663
4664     case '@':
4665         if (PL_expect == XOPERATOR)
4666             no_op("Array", s);
4667         PL_tokenbuf[0] = '@';
4668         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
4669         if (!PL_tokenbuf[1]) {
4670             PREREF('@');
4671         }
4672         if (PL_lex_state == LEX_NORMAL)
4673             s = SKIPSPACE1(s);
4674         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
4675             if (*s == '{')
4676                 PL_tokenbuf[0] = '%';
4677
4678             /* Warn about @ where they meant $. */
4679             if (*s == '[' || *s == '{') {
4680                 if (ckWARN(WARN_SYNTAX)) {
4681                     const char *t = s + 1;
4682                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
4683                         t++;
4684                     if (*t == '}' || *t == ']') {
4685                         t++;
4686                         PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4687                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4688                             "Scalar value %.*s better written as $%.*s",
4689                             (int)(t-PL_bufptr), PL_bufptr,
4690                             (int)(t-PL_bufptr-1), PL_bufptr+1);
4691                     }
4692                 }
4693             }
4694         }
4695         PL_pending_ident = '@';
4696         TERM('@');
4697
4698      case '/':                  /* may be division, defined-or, or pattern */
4699         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
4700             s += 2;
4701             AOPERATOR(DORDOR);
4702         }
4703      case '?':                  /* may either be conditional or pattern */
4704          if(PL_expect == XOPERATOR) {
4705              char tmp = *s++;
4706              if(tmp == '?') {
4707                   OPERATOR('?');
4708              }
4709              else {
4710                  tmp = *s++;
4711                  if(tmp == '/') {
4712                      /* A // operator. */
4713                     AOPERATOR(DORDOR);
4714                  }
4715                  else {
4716                      s--;
4717                      Mop(OP_DIVIDE);
4718                  }
4719              }
4720          }
4721          else {
4722              /* Disable warning on "study /blah/" */
4723              if (PL_oldoldbufptr == PL_last_uni
4724               && (*PL_last_uni != 's' || s - PL_last_uni < 5
4725                   || memNE(PL_last_uni, "study", 5)
4726                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
4727               ))
4728                  check_uni();
4729              s = scan_pat(s,OP_MATCH);
4730              TERM(sublex_start());
4731          }
4732
4733     case '.':
4734         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
4735 #ifdef PERL_STRICT_CR
4736             && s[1] == '\n'
4737 #else
4738             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
4739 #endif
4740             && (s == PL_linestart || s[-1] == '\n') )
4741         {
4742             PL_lex_formbrack = 0;
4743             PL_expect = XSTATE;
4744             goto rightbracket;
4745         }
4746         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
4747             char tmp = *s++;
4748             if (*s == tmp) {
4749                 s++;
4750                 if (*s == tmp) {
4751                     s++;
4752                     yylval.ival = OPf_SPECIAL;
4753                 }
4754                 else
4755                     yylval.ival = 0;
4756                 OPERATOR(DOTDOT);
4757             }
4758             if (PL_expect != XOPERATOR)
4759                 check_uni();
4760             Aop(OP_CONCAT);
4761         }
4762         /* FALL THROUGH */
4763     case '0': case '1': case '2': case '3': case '4':
4764     case '5': case '6': case '7': case '8': case '9':
4765         s = scan_num(s, &yylval);
4766         DEBUG_T( { S_printbuf(aTHX_ "### Saw number in %s\n", s); } );
4767         if (PL_expect == XOPERATOR)
4768             no_op("Number",s);
4769         TERM(THING);
4770
4771     case '\'':
4772         s = scan_str(s,!!PL_madskills,FALSE);
4773         DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
4774         if (PL_expect == XOPERATOR) {
4775             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4776                 PL_expect = XTERM;
4777                 deprecate_old(commaless_variable_list);
4778                 return REPORT(','); /* grandfather non-comma-format format */
4779             }
4780             else
4781                 no_op("String",s);
4782         }
4783         if (!s)
4784             missingterm(NULL);
4785         yylval.ival = OP_CONST;
4786         TERM(sublex_start());
4787
4788     case '"':
4789         s = scan_str(s,!!PL_madskills,FALSE);
4790         DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
4791         if (PL_expect == XOPERATOR) {
4792             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4793                 PL_expect = XTERM;
4794                 deprecate_old(commaless_variable_list);
4795                 return REPORT(','); /* grandfather non-comma-format format */
4796             }
4797             else
4798                 no_op("String",s);
4799         }
4800         if (!s)
4801             missingterm(NULL);
4802         yylval.ival = OP_CONST;
4803         /* FIXME. I think that this can be const if char *d is replaced by
4804            more localised variables.  */
4805         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
4806             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
4807                 yylval.ival = OP_STRINGIFY;
4808                 break;
4809             }
4810         }
4811         TERM(sublex_start());
4812
4813     case '`':
4814         s = scan_str(s,!!PL_madskills,FALSE);
4815         DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } );
4816         if (PL_expect == XOPERATOR)
4817             no_op("Backticks",s);
4818         if (!s)
4819             missingterm(NULL);
4820         yylval.ival = OP_BACKTICK;
4821         set_csh();
4822         TERM(sublex_start());
4823
4824     case '\\':
4825         s++;
4826         if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
4827             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
4828                         *s, *s);
4829         if (PL_expect == XOPERATOR)
4830             no_op("Backslash",s);
4831         OPERATOR(REFGEN);
4832
4833     case 'v':
4834         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
4835             char *start = s + 2;
4836             while (isDIGIT(*start) || *start == '_')
4837                 start++;
4838             if (*start == '.' && isDIGIT(start[1])) {
4839                 s = scan_num(s, &yylval);
4840                 TERM(THING);
4841             }
4842             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
4843             else if (!isALPHA(*start) && (PL_expect == XTERM
4844                         || PL_expect == XREF || PL_expect == XSTATE
4845                         || PL_expect == XTERMORDORDOR)) {
4846                 /* XXX Use gv_fetchpvn rather than stomping on a const string */
4847                 const char c = *start;
4848                 GV *gv;
4849                 *start = '\0';
4850                 gv = gv_fetchpv(s, 0, SVt_PVCV);
4851                 *start = c;
4852                 if (!gv) {
4853                     s = scan_num(s, &yylval);
4854                     TERM(THING);
4855                 }
4856             }
4857         }
4858         goto keylookup;
4859     case 'x':
4860         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
4861             s++;
4862             Mop(OP_REPEAT);
4863         }
4864         goto keylookup;
4865
4866     case '_':
4867     case 'a': case 'A':
4868     case 'b': case 'B':
4869     case 'c': case 'C':
4870     case 'd': case 'D':
4871     case 'e': case 'E':
4872     case 'f': case 'F':
4873     case 'g': case 'G':
4874     case 'h': case 'H':
4875     case 'i': case 'I':
4876     case 'j': case 'J':
4877     case 'k': case 'K':
4878     case 'l': case 'L':
4879     case 'm': case 'M':
4880     case 'n': case 'N':
4881     case 'o': case 'O':
4882     case 'p': case 'P':
4883     case 'q': case 'Q':
4884     case 'r': case 'R':
4885     case 's': case 'S':
4886     case 't': case 'T':
4887     case 'u': case 'U':
4888               case 'V':
4889     case 'w': case 'W':
4890               case 'X':
4891     case 'y': case 'Y':
4892     case 'z': case 'Z':
4893
4894       keylookup: {
4895         I32 tmp;
4896         I32 orig_keyword = 0;
4897         GV *gv = NULL;
4898         GV **gvp = NULL;
4899
4900         PL_bufptr = s;
4901         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4902
4903         /* Some keywords can be followed by any delimiter, including ':' */
4904         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
4905                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
4906                              (PL_tokenbuf[0] == 'q' &&
4907                               strchr("qwxr", PL_tokenbuf[1])))));
4908
4909         /* x::* is just a word, unless x is "CORE" */
4910         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4911             goto just_a_word;
4912
4913         d = s;
4914         while (d < PL_bufend && isSPACE(*d))
4915                 d++;    /* no comments skipped here, or s### is misparsed */
4916
4917         /* Is this a label? */
4918         if (!tmp && PL_expect == XSTATE
4919               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4920             s = d + 1;
4921             yylval.pval = savepv(PL_tokenbuf);
4922             CLINE;
4923             TOKEN(LABEL);
4924         }
4925
4926         /* Check for keywords */
4927         tmp = keyword(PL_tokenbuf, len);
4928
4929         /* Is this a word before a => operator? */
4930         if (*d == '=' && d[1] == '>') {
4931             CLINE;
4932             yylval.opval
4933                 = (OP*)newSVOP(OP_CONST, 0,
4934                                S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
4935             yylval.opval->op_private = OPpCONST_BARE;
4936             TERM(WORD);
4937         }
4938
4939         if (tmp < 0) {                  /* second-class keyword? */
4940             GV *ogv = NULL;     /* override (winner) */
4941             GV *hgv = NULL;     /* hidden (loser) */
4942             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4943                 CV *cv;
4944                 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
4945                     (cv = GvCVu(gv)))
4946                 {
4947                     if (GvIMPORTED_CV(gv))
4948                         ogv = gv;
4949                     else if (! CvMETHOD(cv))
4950                         hgv = gv;
4951                 }
4952                 if (!ogv &&
4953                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4954                     (gv = *gvp) != (GV*)&PL_sv_undef &&
4955                     GvCVu(gv) && GvIMPORTED_CV(gv))
4956                 {
4957                     ogv = gv;
4958                 }
4959             }
4960             if (ogv) {
4961                 orig_keyword = tmp;
4962                 tmp = 0;                /* overridden by import or by GLOBAL */
4963             }
4964             else if (gv && !gvp
4965                      && -tmp==KEY_lock  /* XXX generalizable kludge */
4966                      && GvCVu(gv)
4967                      && !hv_fetchs(GvHVn(PL_incgv), "Thread.pm", FALSE))
4968             {
4969                 tmp = 0;                /* any sub overrides "weak" keyword */
4970             }
4971             else {                      /* no override */
4972                 tmp = -tmp;
4973                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4974                     Perl_warner(aTHX_ packWARN(WARN_MISC),
4975                             "dump() better written as CORE::dump()");
4976                 }
4977                 gv = NULL;
4978                 gvp = 0;
4979                 if (hgv && tmp != KEY_x && tmp != KEY_CORE
4980                         && ckWARN(WARN_AMBIGUOUS))      /* never ambiguous */
4981                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4982                         "Ambiguous call resolved as CORE::%s(), %s",
4983                          GvENAME(hgv), "qualify as such or use &");
4984             }
4985         }
4986
4987       reserved_word:
4988         switch (tmp) {
4989
4990         default:                        /* not a keyword */
4991             /* Trade off - by using this evil construction we can pull the
4992                variable gv into the block labelled keylookup. If not, then
4993                we have to give it function scope so that the goto from the
4994                earlier ':' case doesn't bypass the initialisation.  */
4995             if (0) {
4996             just_a_word_zero_gv:
4997                 gv = NULL;
4998                 gvp = NULL;
4999                 orig_keyword = 0;
5000             }
5001           just_a_word: {
5002                 SV *sv;
5003                 int pkgname = 0;
5004                 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5005                 CV *cv;
5006 #ifdef PERL_MAD
5007                 SV *nextPL_nextwhite = 0;
5008 #endif
5009
5010
5011                 /* Get the rest if it looks like a package qualifier */
5012
5013                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5014                     STRLEN morelen;
5015                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5016                                   TRUE, &morelen);
5017                     if (!morelen)
5018                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5019                                 *s == '\'' ? "'" : "::");
5020                     len += morelen;
5021                     pkgname = 1;
5022                 }
5023
5024                 if (PL_expect == XOPERATOR) {
5025                     if (PL_bufptr == PL_linestart) {
5026                         CopLINE_dec(PL_curcop);
5027                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
5028                         CopLINE_inc(PL_curcop);
5029                     }
5030                     else
5031                         no_op("Bareword",s);
5032                 }
5033
5034                 /* Look for a subroutine with this name in current package,
5035                    unless name is "Foo::", in which case Foo is a bearword
5036                    (and a package name). */
5037
5038                 if (len > 2 && !PL_madskills &&
5039                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5040                 {
5041                     if (ckWARN(WARN_BAREWORD)
5042                         && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5043                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5044                             "Bareword \"%s\" refers to nonexistent package",
5045                              PL_tokenbuf);
5046                     len -= 2;
5047                     PL_tokenbuf[len] = '\0';
5048                     gv = NULL;
5049                     gvp = 0;
5050                 }
5051                 else {
5052                     if (!gv) {
5053                         /* Mustn't actually add anything to a symbol table.
5054                            But also don't want to "initialise" any placeholder
5055                            constants that might already be there into full
5056                            blown PVGVs with attached PVCV.  */
5057                         gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5058                                                GV_NOADD_NOINIT, SVt_PVCV);
5059                     }
5060                     len = 0;
5061                 }
5062
5063                 /* if we saw a global override before, get the right name */
5064
5065                 if (gvp) {
5066                     sv = newSVpvs("CORE::GLOBAL::");
5067                     sv_catpv(sv,PL_tokenbuf);
5068                 }
5069                 else {
5070                     /* If len is 0, newSVpv does strlen(), which is correct.
5071                        If len is non-zero, then it will be the true length,
5072                        and so the scalar will be created correctly.  */
5073                     sv = newSVpv(PL_tokenbuf,len);
5074                 }
5075 #ifdef PERL_MAD
5076                 if (PL_madskills && !PL_thistoken) {
5077                     char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5078                     PL_thistoken = newSVpv(start,s - start);
5079                     PL_realtokenstart = s - SvPVX(PL_linestr);
5080                 }
5081 #endif
5082
5083                 /* Presume this is going to be a bareword of some sort. */
5084
5085                 CLINE;
5086                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5087                 yylval.opval->op_private = OPpCONST_BARE;
5088                 /* UTF-8 package name? */
5089                 if (UTF && !IN_BYTES &&
5090                     is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5091                     SvUTF8_on(sv);
5092
5093                 /* And if "Foo::", then that's what it certainly is. */
5094
5095                 if (len)
5096                     goto safe_bareword;
5097
5098                 /* Do the explicit type check so that we don't need to force
5099                    the initialisation of the symbol table to have a real GV.
5100                    Beware - gv may not really be a PVGV, cv may not really be
5101                    a PVCV, (because of the space optimisations that gv_init
5102                    understands) But they're true if for this symbol there is
5103                    respectively a typeglob and a subroutine.
5104                 */
5105                 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5106                     /* Real typeglob, so get the real subroutine: */
5107                            ? GvCVu(gv)
5108                     /* A proxy for a subroutine in this package? */
5109                            : SvOK(gv) ? (CV *) gv : NULL)
5110                     : NULL;
5111
5112                 /* See if it's the indirect object for a list operator. */
5113
5114                 if (PL_oldoldbufptr &&
5115                     PL_oldoldbufptr < PL_bufptr &&
5116                     (PL_oldoldbufptr == PL_last_lop
5117                      || PL_oldoldbufptr == PL_last_uni) &&
5118                     /* NO SKIPSPACE BEFORE HERE! */
5119                     (PL_expect == XREF ||
5120                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5121                 {
5122                     bool immediate_paren = *s == '(';
5123
5124                     /* (Now we can afford to cross potential line boundary.) */
5125                     s = SKIPSPACE2(s,nextPL_nextwhite);
5126 #ifdef PERL_MAD
5127                     PL_nextwhite = nextPL_nextwhite;    /* assume no & deception */
5128 #endif
5129
5130                     /* Two barewords in a row may indicate method call. */
5131
5132                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5133                         (tmp = intuit_method(s, gv, cv)))
5134                         return REPORT(tmp);
5135
5136                     /* If not a declared subroutine, it's an indirect object. */
5137                     /* (But it's an indir obj regardless for sort.) */
5138                     /* Also, if "_" follows a filetest operator, it's a bareword */
5139
5140                     if (
5141                         ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5142                          ((!gv || !cv) &&
5143                         (PL_last_lop_op != OP_MAPSTART &&
5144                          PL_last_lop_op != OP_GREPSTART))))
5145                        || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5146                             && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5147                        )
5148                     {
5149                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5150                         goto bareword;
5151                     }
5152                 }
5153
5154                 PL_expect = XOPERATOR;
5155 #ifdef PERL_MAD
5156                 if (isSPACE(*s))
5157                     s = SKIPSPACE2(s,nextPL_nextwhite);
5158                 PL_nextwhite = nextPL_nextwhite;
5159 #else
5160                 s = skipspace(s);
5161 #endif
5162
5163                 /* Is this a word before a => operator? */
5164                 if (*s == '=' && s[1] == '>' && !pkgname) {
5165                     CLINE;
5166                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
5167                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5168                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
5169                     TERM(WORD);
5170                 }
5171
5172                 /* If followed by a paren, it's certainly a subroutine. */
5173                 if (*s == '(') {
5174                     CLINE;
5175                     if (cv) {
5176                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
5177                         if (*d == ')' && (sv = gv_const_sv(gv))) {
5178                             s = d + 1;
5179 #ifdef PERL_MAD
5180                             if (PL_madskills) {
5181                                 char *par = SvPVX(PL_linestr) + PL_realtokenstart;
5182                                 sv_catpvn(PL_thistoken, par, s - par);
5183                                 if (PL_nextwhite) {
5184                                     sv_free(PL_nextwhite);
5185                                     PL_nextwhite = 0;
5186                                 }
5187                             }
5188 #endif
5189                             goto its_constant;
5190                         }
5191                     }
5192 #ifdef PERL_MAD
5193                     if (PL_madskills) {
5194                         PL_nextwhite = PL_thiswhite;
5195                         PL_thiswhite = 0;
5196                     }
5197                     start_force(PL_curforce);
5198 #endif
5199                     NEXTVAL_NEXTTOKE.opval = yylval.opval;
5200                     PL_expect = XOPERATOR;
5201 #ifdef PERL_MAD
5202                     if (PL_madskills) {
5203                         PL_nextwhite = nextPL_nextwhite;
5204                         curmad('X', PL_thistoken);
5205                         PL_thistoken = newSVpvn("",0);
5206                     }
5207 #endif
5208                     force_next(WORD);
5209                     yylval.ival = 0;
5210                     TOKEN('&');
5211                 }
5212
5213                 /* If followed by var or block, call it a method (unless sub) */
5214
5215                 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5216                     PL_last_lop = PL_oldbufptr;
5217                     PL_last_lop_op = OP_METHOD;
5218                     PREBLOCK(METHOD);
5219                 }
5220
5221                 /* If followed by a bareword, see if it looks like indir obj. */
5222
5223                 if (!orig_keyword
5224                         && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5225                         && (tmp = intuit_method(s, gv, cv)))
5226                     return REPORT(tmp);
5227
5228                 /* Not a method, so call it a subroutine (if defined) */
5229
5230                 if (cv) {
5231                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
5232                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5233                                 "Ambiguous use of -%s resolved as -&%s()",
5234                                 PL_tokenbuf, PL_tokenbuf);
5235                     /* Check for a constant sub */
5236                     if ((sv = gv_const_sv(gv))) {
5237                   its_constant:
5238                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
5239                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5240                         yylval.opval->op_private = 0;
5241                         TOKEN(WORD);
5242                     }
5243
5244                     /* Resolve to GV now. */
5245                     if (SvTYPE(gv) != SVt_PVGV) {
5246                         gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5247                         assert (SvTYPE(gv) == SVt_PVGV);
5248                         /* cv must have been some sort of placeholder, so
5249                            now needs replacing with a real code reference.  */
5250                         cv = GvCV(gv);
5251                     }
5252
5253                     op_free(yylval.opval);
5254                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5255                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5256                     PL_last_lop = PL_oldbufptr;
5257                     PL_last_lop_op = OP_ENTERSUB;
5258                     /* Is there a prototype? */
5259                     if (
5260 #ifdef PERL_MAD
5261                         cv &&
5262 #endif
5263                         SvPOK(cv)) {
5264                         STRLEN protolen;
5265                         const char *proto = SvPV_const((SV*)cv, protolen);
5266                         if (!protolen)
5267                             TERM(FUNC0SUB);
5268                         if (*proto == '$' && proto[1] == '\0')
5269                             OPERATOR(UNIOPSUB);
5270                         while (*proto == ';')
5271                             proto++;
5272                         if (*proto == '&' && *s == '{') {
5273                             sv_setpv(PL_subname, PL_curstash ?
5274                                         "__ANON__" : "__ANON__::__ANON__");
5275                             PREBLOCK(LSTOPSUB);
5276                         }
5277                     }
5278 #ifdef PERL_MAD
5279                     {
5280                         if (PL_madskills) {
5281                             PL_nextwhite = PL_thiswhite;
5282                             PL_thiswhite = 0;
5283                         }
5284                         start_force(PL_curforce);
5285                         NEXTVAL_NEXTTOKE.opval = yylval.opval;
5286                         PL_expect = XTERM;
5287                         if (PL_madskills) {
5288                             PL_nextwhite = nextPL_nextwhite;
5289                             curmad('X', PL_thistoken);
5290                             PL_thistoken = newSVpvn("",0);
5291                         }
5292                         force_next(WORD);
5293                         TOKEN(NOAMP);
5294                     }
5295                 }
5296
5297                 /* Guess harder when madskills require "best effort". */
5298                 if (PL_madskills && (!gv || !GvCVu(gv))) {
5299                     int probable_sub = 0;
5300                     if (strchr("\"'`$@%0123456789!*+{[<", *s))
5301                         probable_sub = 1;
5302                     else if (isALPHA(*s)) {
5303                         char tmpbuf[1024];
5304                         STRLEN tmplen;
5305                         d = s;
5306                         d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5307                         if (!keyword(tmpbuf,tmplen))
5308                             probable_sub = 1;
5309                         else {
5310                             while (d < PL_bufend && isSPACE(*d))
5311                                 d++;
5312                             if (*d == '=' && d[1] == '>')
5313                                 probable_sub = 1;
5314                         }
5315                     }
5316                     if (probable_sub) {
5317                         gv = gv_fetchpv(PL_tokenbuf, TRUE, SVt_PVCV);
5318                         op_free(yylval.opval);
5319                         yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5320                         yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5321                         PL_last_lop = PL_oldbufptr;
5322                         PL_last_lop_op = OP_ENTERSUB;
5323                         PL_nextwhite = PL_thiswhite;
5324                         PL_thiswhite = 0;
5325                         start_force(PL_curforce);
5326                         NEXTVAL_NEXTTOKE.opval = yylval.opval;
5327                         PL_expect = XTERM;
5328                         PL_nextwhite = nextPL_nextwhite;
5329                         curmad('X', PL_thistoken);
5330                         PL_thistoken = newSVpvn("",0);
5331                         force_next(WORD);
5332                         TOKEN(NOAMP);
5333                     }
5334 #else
5335                     NEXTVAL_NEXTTOKE.opval = yylval.opval;
5336                     PL_expect = XTERM;
5337                     force_next(WORD);
5338                     TOKEN(NOAMP);
5339 #endif
5340                 }
5341
5342                 /* Call it a bare word */
5343
5344                 if (PL_hints & HINT_STRICT_SUBS)
5345                     yylval.opval->op_private |= OPpCONST_STRICT;
5346                 else {
5347                 bareword:
5348                     if (lastchar != '-') {
5349                         if (ckWARN(WARN_RESERVED)) {
5350                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
5351                             if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
5352                                 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5353                                        PL_tokenbuf);
5354                         }
5355                     }
5356                 }
5357
5358             safe_bareword:
5359                 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
5360                     && ckWARN_d(WARN_AMBIGUOUS)) {
5361                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5362                         "Operator or semicolon missing before %c%s",
5363                         lastchar, PL_tokenbuf);
5364                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5365                         "Ambiguous use of %c resolved as operator %c",
5366                         lastchar, lastchar);
5367                 }
5368                 TOKEN(WORD);
5369             }
5370
5371         case KEY___FILE__:
5372             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5373                                         newSVpv(CopFILE(PL_curcop),0));
5374             TERM(THING);
5375
5376         case KEY___LINE__:
5377             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5378                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5379             TERM(THING);
5380
5381         case KEY___PACKAGE__:
5382             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5383                                         (PL_curstash
5384                                          ? newSVhek(HvNAME_HEK(PL_curstash))
5385                                          : &PL_sv_undef));
5386             TERM(THING);
5387
5388         case KEY___DATA__:
5389         case KEY___END__: {
5390             GV *gv;
5391             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5392                 const char *pname = "main";
5393                 if (PL_tokenbuf[2] == 'D')
5394                     pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5395                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5396                                 SVt_PVIO);
5397                 GvMULTI_on(gv);
5398                 if (!GvIO(gv))
5399                     GvIOp(gv) = newIO();
5400                 IoIFP(GvIOp(gv)) = PL_rsfp;
5401 #if defined(HAS_FCNTL) && defined(F_SETFD)
5402                 {
5403                     const int fd = PerlIO_fileno(PL_rsfp);
5404                     fcntl(fd,F_SETFD,fd >= 3);
5405                 }
5406 #endif
5407                 /* Mark this internal pseudo-handle as clean */
5408                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5409                 if (PL_preprocess)
5410                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
5411                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5412                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5413                 else
5414                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5415 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5416                 /* if the script was opened in binmode, we need to revert
5417                  * it to text mode for compatibility; but only iff it has CRs
5418                  * XXX this is a questionable hack at best. */
5419                 if (PL_bufend-PL_bufptr > 2
5420                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5421                 {
5422                     Off_t loc = 0;
5423                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5424                         loc = PerlIO_tell(PL_rsfp);
5425                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
5426                     }
5427 #ifdef NETWARE
5428                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5429 #else
5430                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5431 #endif  /* NETWARE */
5432 #ifdef PERLIO_IS_STDIO /* really? */
5433 #  if defined(__BORLANDC__)
5434                         /* XXX see note in do_binmode() */
5435                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5436 #  endif
5437 #endif
5438                         if (loc > 0)
5439                             PerlIO_seek(PL_rsfp, loc, 0);
5440                     }
5441                 }
5442 #endif
5443 #ifdef PERLIO_LAYERS
5444                 if (!IN_BYTES) {
5445                     if (UTF)
5446                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5447                     else if (PL_encoding) {
5448                         SV *name;
5449                         dSP;
5450                         ENTER;
5451                         SAVETMPS;
5452                         PUSHMARK(sp);
5453                         EXTEND(SP, 1);
5454                         XPUSHs(PL_encoding);
5455                         PUTBACK;
5456                         call_method("name", G_SCALAR);
5457                         SPAGAIN;
5458                         name = POPs;
5459                         PUTBACK;
5460                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5461                                             Perl_form(aTHX_ ":encoding(%"SVf")",
5462                                                       name));
5463                         FREETMPS;
5464                         LEAVE;
5465                     }
5466                 }
5467 #endif
5468 #ifdef PERL_MAD
5469                 if (PL_madskills) {
5470                     if (PL_realtokenstart >= 0) {
5471                         char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5472                         if (!PL_endwhite)
5473                             PL_endwhite = newSVpvn("",0);
5474                         sv_catsv(PL_endwhite, PL_thiswhite);
5475                         PL_thiswhite = 0;
5476                         sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5477                         PL_realtokenstart = -1;
5478                     }
5479                     while ((s = filter_gets(PL_endwhite, PL_rsfp,
5480                                  SvCUR(PL_endwhite))) != Nullch) ;
5481                 }
5482 #endif
5483                 PL_rsfp = NULL;
5484             }
5485             goto fake_eof;
5486         }
5487
5488         case KEY_AUTOLOAD:
5489         case KEY_DESTROY:
5490         case KEY_BEGIN:
5491         case KEY_CHECK:
5492         case KEY_INIT:
5493         case KEY_END:
5494             if (PL_expect == XSTATE) {
5495                 s = PL_bufptr;
5496                 goto really_sub;
5497             }
5498             goto just_a_word;
5499
5500         case KEY_CORE:
5501             if (*s == ':' && s[1] == ':') {
5502                 s += 2;
5503                 d = s;
5504                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5505                 if (!(tmp = keyword(PL_tokenbuf, len)))
5506                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5507                 if (tmp < 0)
5508                     tmp = -tmp;
5509                 else if (tmp == KEY_require || tmp == KEY_do)
5510                     /* that's a way to remember we saw "CORE::" */
5511                     orig_keyword = tmp;
5512                 goto reserved_word;
5513             }
5514             goto just_a_word;
5515
5516         case KEY_abs:
5517             UNI(OP_ABS);
5518
5519         case KEY_alarm:
5520             UNI(OP_ALARM);
5521
5522         case KEY_accept:
5523             LOP(OP_ACCEPT,XTERM);
5524
5525         case KEY_and:
5526             OPERATOR(ANDOP);
5527
5528         case KEY_atan2:
5529             LOP(OP_ATAN2,XTERM);
5530
5531         case KEY_bind:
5532             LOP(OP_BIND,XTERM);
5533
5534         case KEY_binmode:
5535             LOP(OP_BINMODE,XTERM);
5536
5537         case KEY_bless:
5538             LOP(OP_BLESS,XTERM);
5539
5540         case KEY_break:
5541             FUN0(OP_BREAK);
5542
5543         case KEY_chop:
5544             UNI(OP_CHOP);
5545
5546         case KEY_continue:
5547             /* When 'use switch' is in effect, continue has a dual
5548                life as a control operator. */
5549             {
5550                 if (!FEATURE_IS_ENABLED("switch"))
5551                     PREBLOCK(CONTINUE);
5552                 else {
5553                     /* We have to disambiguate the two senses of
5554                       "continue". If the next token is a '{' then
5555                       treat it as the start of a continue block;
5556                       otherwise treat it as a control operator.
5557                      */
5558                     s = skipspace(s);
5559                     if (*s == '{')
5560             PREBLOCK(CONTINUE);
5561                     else
5562                         FUN0(OP_CONTINUE);
5563                 }
5564             }
5565
5566         case KEY_chdir:
5567             /* may use HOME */
5568             (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5569             UNI(OP_CHDIR);
5570
5571         case KEY_close:
5572             UNI(OP_CLOSE);
5573
5574         case KEY_closedir:
5575             UNI(OP_CLOSEDIR);
5576
5577         case KEY_cmp:
5578             Eop(OP_SCMP);
5579
5580         case KEY_caller:
5581             UNI(OP_CALLER);
5582
5583         case KEY_crypt:
5584 #ifdef FCRYPT
5585             if (!PL_cryptseen) {
5586                 PL_cryptseen = TRUE;
5587                 init_des();
5588             }
5589 #endif
5590             LOP(OP_CRYPT,XTERM);
5591
5592         case KEY_chmod:
5593             LOP(OP_CHMOD,XTERM);
5594
5595         case KEY_chown:
5596             LOP(OP_CHOWN,XTERM);
5597
5598         case KEY_connect:
5599             LOP(OP_CONNECT,XTERM);
5600
5601         case KEY_chr:
5602             UNI(OP_CHR);
5603
5604         case KEY_cos:
5605             UNI(OP_COS);
5606
5607         case KEY_chroot:
5608             UNI(OP_CHROOT);
5609
5610         case KEY_default:
5611             PREBLOCK(DEFAULT);
5612
5613         case KEY_do:
5614             s = SKIPSPACE1(s);
5615             if (*s == '{')
5616                 PRETERMBLOCK(DO);
5617             if (*s != '\'')
5618                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5619             if (orig_keyword == KEY_do) {
5620                 orig_keyword = 0;
5621                 yylval.ival = 1;
5622             }
5623             else
5624                 yylval.ival = 0;
5625             OPERATOR(DO);
5626
5627         case KEY_die:
5628             PL_hints |= HINT_BLOCK_SCOPE;
5629             LOP(OP_DIE,XTERM);
5630
5631         case KEY_defined:
5632             UNI(OP_DEFINED);
5633
5634         case KEY_delete:
5635             UNI(OP_DELETE);
5636
5637         case KEY_dbmopen:
5638             gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
5639             LOP(OP_DBMOPEN,XTERM);
5640
5641         case KEY_dbmclose:
5642             UNI(OP_DBMCLOSE);
5643
5644         case KEY_dump:
5645             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5646             LOOPX(OP_DUMP);
5647
5648         case KEY_else:
5649             PREBLOCK(ELSE);
5650
5651         case KEY_elsif:
5652             yylval.ival = CopLINE(PL_curcop);
5653             OPERATOR(ELSIF);
5654
5655         case KEY_eq:
5656             Eop(OP_SEQ);
5657
5658         case KEY_exists:
5659             UNI(OP_EXISTS);
5660
5661         case KEY_exit:
5662             if (PL_madskills)
5663                 UNI(OP_INT);
5664             UNI(OP_EXIT);
5665
5666         case KEY_eval:
5667             s = SKIPSPACE1(s);
5668             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
5669             UNIBRACK(OP_ENTEREVAL);
5670
5671         case KEY_eof:
5672             UNI(OP_EOF);
5673
5674         case KEY_err:
5675             OPERATOR(DOROP);
5676
5677         case KEY_exp:
5678             UNI(OP_EXP);
5679
5680         case KEY_each:
5681             UNI(OP_EACH);
5682
5683         case KEY_exec:
5684             set_csh();
5685             LOP(OP_EXEC,XREF);
5686
5687         case KEY_endhostent:
5688             FUN0(OP_EHOSTENT);
5689
5690         case KEY_endnetent:
5691             FUN0(OP_ENETENT);
5692
5693         case KEY_endservent:
5694             FUN0(OP_ESERVENT);
5695
5696         case KEY_endprotoent:
5697             FUN0(OP_EPROTOENT);
5698
5699         case KEY_endpwent:
5700             FUN0(OP_EPWENT);
5701
5702         case KEY_endgrent:
5703             FUN0(OP_EGRENT);
5704
5705         case KEY_for:
5706         case KEY_foreach:
5707             yylval.ival = CopLINE(PL_curcop);
5708             s = SKIPSPACE1(s);
5709             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
5710                 char *p = s;
5711 #ifdef PERL_MAD
5712                 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
5713 #endif
5714
5715                 if ((PL_bufend - p) >= 3 &&
5716                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
5717                     p += 2;
5718                 else if ((PL_bufend - p) >= 4 &&
5719                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
5720                     p += 3;
5721                 p = PEEKSPACE(p);
5722                 if (isIDFIRST_lazy_if(p,UTF)) {
5723                     p = scan_ident(p, PL_bufend,
5724                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5725                     p = PEEKSPACE(p);
5726                 }
5727                 if (*p != '$')
5728                     Perl_croak(aTHX_ "Missing $ on loop variable");
5729 #ifdef PERL_MAD
5730                 s = SvPVX(PL_linestr) + soff;
5731 #endif
5732             }
5733             OPERATOR(FOR);
5734
5735         case KEY_formline:
5736             LOP(OP_FORMLINE,XTERM);
5737
5738         case KEY_fork:
5739             FUN0(OP_FORK);
5740
5741         case KEY_fcntl:
5742             LOP(OP_FCNTL,XTERM);
5743
5744         case KEY_fileno:
5745             UNI(OP_FILENO);
5746
5747         case KEY_flock:
5748             LOP(OP_FLOCK,XTERM);
5749
5750         case KEY_gt:
5751             Rop(OP_SGT);
5752
5753         case KEY_ge:
5754             Rop(OP_SGE);
5755
5756         case KEY_grep:
5757             LOP(OP_GREPSTART, XREF);
5758
5759         case KEY_goto:
5760             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5761             LOOPX(OP_GOTO);
5762
5763         case KEY_gmtime:
5764             UNI(OP_GMTIME);
5765
5766         case KEY_getc:
5767             UNIDOR(OP_GETC);
5768
5769         case KEY_getppid:
5770             FUN0(OP_GETPPID);
5771
5772         case KEY_getpgrp:
5773             UNI(OP_GETPGRP);
5774
5775         case KEY_getpriority:
5776             LOP(OP_GETPRIORITY,XTERM);
5777
5778         case KEY_getprotobyname:
5779             UNI(OP_GPBYNAME);
5780
5781         case KEY_getprotobynumber:
5782             LOP(OP_GPBYNUMBER,XTERM);
5783
5784         case KEY_getprotoent:
5785             FUN0(OP_GPROTOENT);
5786
5787         case KEY_getpwent:
5788             FUN0(OP_GPWENT);
5789
5790         case KEY_getpwnam:
5791             UNI(OP_GPWNAM);
5792
5793         case KEY_getpwuid:
5794             UNI(OP_GPWUID);
5795
5796         case KEY_getpeername:
5797             UNI(OP_GETPEERNAME);
5798
5799         case KEY_gethostbyname:
5800             UNI(OP_GHBYNAME);
5801
5802         case KEY_gethostbyaddr:
5803             LOP(OP_GHBYADDR,XTERM);
5804
5805         case KEY_gethostent:
5806             FUN0(OP_GHOSTENT);
5807
5808         case KEY_getnetbyname:
5809             UNI(OP_GNBYNAME);
5810
5811         case KEY_getnetbyaddr:
5812             LOP(OP_GNBYADDR,XTERM);
5813
5814         case KEY_getnetent:
5815             FUN0(OP_GNETENT);
5816
5817         case KEY_getservbyname:
5818             LOP(OP_GSBYNAME,XTERM);
5819
5820         case KEY_getservbyport:
5821             LOP(OP_GSBYPORT,XTERM);
5822
5823         case KEY_getservent:
5824             FUN0(OP_GSERVENT);
5825
5826         case KEY_getsockname:
5827             UNI(OP_GETSOCKNAME);
5828
5829         case KEY_getsockopt:
5830             LOP(OP_GSOCKOPT,XTERM);
5831
5832         case KEY_getgrent:
5833             FUN0(OP_GGRENT);
5834
5835         case KEY_getgrnam:
5836             UNI(OP_GGRNAM);
5837
5838         case KEY_getgrgid:
5839             UNI(OP_GGRGID);
5840
5841         case KEY_getlogin:
5842             FUN0(OP_GETLOGIN);
5843
5844         case KEY_given:
5845             yylval.ival = CopLINE(PL_curcop);
5846             OPERATOR(GIVEN);
5847
5848         case KEY_glob:
5849             set_csh();
5850             LOP(OP_GLOB,XTERM);
5851
5852         case KEY_hex:
5853             UNI(OP_HEX);
5854
5855         case KEY_if:
5856             yylval.ival = CopLINE(PL_curcop);
5857             OPERATOR(IF);
5858
5859         case KEY_index:
5860             LOP(OP_INDEX,XTERM);
5861
5862         case KEY_int:
5863             UNI(OP_INT);
5864
5865         case KEY_ioctl:
5866             LOP(OP_IOCTL,XTERM);
5867
5868         case KEY_join:
5869             LOP(OP_JOIN,XTERM);
5870
5871         case KEY_keys:
5872             UNI(OP_KEYS);
5873
5874         case KEY_kill:
5875             LOP(OP_KILL,XTERM);
5876
5877         case KEY_last:
5878             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5879             LOOPX(OP_LAST);
5880
5881         case KEY_lc:
5882             UNI(OP_LC);
5883
5884         case KEY_lcfirst:
5885             UNI(OP_LCFIRST);
5886
5887         case KEY_local:
5888             yylval.ival = 0;
5889             OPERATOR(LOCAL);
5890
5891         case KEY_length:
5892             UNI(OP_LENGTH);
5893
5894         case KEY_lt:
5895             Rop(OP_SLT);
5896
5897         case KEY_le:
5898             Rop(OP_SLE);
5899
5900         case KEY_localtime:
5901             UNI(OP_LOCALTIME);
5902
5903         case KEY_log:
5904             UNI(OP_LOG);
5905
5906         case KEY_link:
5907             LOP(OP_LINK,XTERM);
5908
5909         case KEY_listen:
5910             LOP(OP_LISTEN,XTERM);
5911
5912         case KEY_lock:
5913             UNI(OP_LOCK);
5914
5915         case KEY_lstat:
5916             UNI(OP_LSTAT);
5917
5918         case KEY_m:
5919             s = scan_pat(s,OP_MATCH);
5920             TERM(sublex_start());
5921
5922         case KEY_map:
5923             LOP(OP_MAPSTART, XREF);
5924
5925         case KEY_mkdir:
5926             LOP(OP_MKDIR,XTERM);
5927
5928         case KEY_msgctl:
5929             LOP(OP_MSGCTL,XTERM);
5930
5931         case KEY_msgget:
5932             LOP(OP_MSGGET,XTERM);
5933
5934         case KEY_msgrcv:
5935             LOP(OP_MSGRCV,XTERM);
5936
5937         case KEY_msgsnd:
5938             LOP(OP_MSGSND,XTERM);
5939
5940         case KEY_our:
5941         case KEY_my:
5942             PL_in_my = tmp;
5943             s = SKIPSPACE1(s);
5944             if (isIDFIRST_lazy_if(s,UTF)) {
5945 #ifdef PERL_MAD
5946                 char* start = s;
5947 #endif
5948                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
5949                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
5950                     goto really_sub;
5951                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
5952                 if (!PL_in_my_stash) {
5953                     char tmpbuf[1024];
5954                     PL_bufptr = s;
5955                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
5956                     yyerror(tmpbuf);
5957                 }
5958 #ifdef PERL_MAD
5959                 if (PL_madskills) {     /* just add type to declarator token */
5960                     sv_catsv(PL_thistoken, PL_nextwhite);
5961                     PL_nextwhite = 0;
5962                     sv_catpvn(PL_thistoken, start, s - start);
5963                 }
5964 #endif
5965             }
5966             yylval.ival = 1;
5967             OPERATOR(MY);
5968
5969         case KEY_next:
5970             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5971             LOOPX(OP_NEXT);
5972
5973         case KEY_ne:
5974             Eop(OP_SNE);
5975
5976         case KEY_no:
5977             s = tokenize_use(0, s);
5978             OPERATOR(USE);
5979
5980         case KEY_not:
5981             if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
5982                 FUN1(OP_NOT);
5983             else
5984                 OPERATOR(NOTOP);
5985
5986         case KEY_open:
5987             s = SKIPSPACE1(s);
5988             if (isIDFIRST_lazy_if(s,UTF)) {
5989                 const char *t;
5990                 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
5991                 for (t=d; *t && isSPACE(*t); t++) ;
5992                 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
5993                     /* [perl #16184] */
5994                     && !(t[0] == '=' && t[1] == '>')
5995                 ) {
5996                     int parms_len = (int)(d-s);
5997                     Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5998                            "Precedence problem: open %.*s should be open(%.*s)",
5999                             parms_len, s, parms_len, s);
6000                 }
6001             }
6002             LOP(OP_OPEN,XTERM);
6003
6004         case KEY_or:
6005             yylval.ival = OP_OR;
6006             OPERATOR(OROP);
6007
6008         case KEY_ord:
6009             UNI(OP_ORD);
6010
6011         case KEY_oct:
6012             UNI(OP_OCT);
6013
6014         case KEY_opendir:
6015             LOP(OP_OPEN_DIR,XTERM);
6016
6017         case KEY_print:
6018             checkcomma(s,PL_tokenbuf,"filehandle");
6019             LOP(OP_PRINT,XREF);
6020
6021         case KEY_printf:
6022             checkcomma(s,PL_tokenbuf,"filehandle");
6023             LOP(OP_PRTF,XREF);
6024
6025         case KEY_prototype:
6026             UNI(OP_PROTOTYPE);
6027
6028         case KEY_push:
6029             LOP(OP_PUSH,XTERM);
6030
6031         case KEY_pop:
6032             UNIDOR(OP_POP);
6033
6034         case KEY_pos:
6035             UNIDOR(OP_POS);
6036
6037         case KEY_pack:
6038             LOP(OP_PACK,XTERM);
6039
6040         case KEY_package:
6041             s = force_word(s,WORD,FALSE,TRUE,FALSE);
6042             OPERATOR(PACKAGE);
6043
6044         case KEY_pipe:
6045             LOP(OP_PIPE_OP,XTERM);
6046
6047         case KEY_q:
6048             s = scan_str(s,!!PL_madskills,FALSE);
6049             if (!s)
6050                 missingterm(NULL);
6051             yylval.ival = OP_CONST;
6052             TERM(sublex_start());
6053
6054         case KEY_quotemeta:
6055             UNI(OP_QUOTEMETA);
6056
6057         case KEY_qw:
6058             s = scan_str(s,!!PL_madskills,FALSE);
6059             if (!s)
6060                 missingterm(NULL);
6061             PL_expect = XOPERATOR;
6062             force_next(')');
6063             if (SvCUR(PL_lex_stuff)) {
6064                 OP *words = NULL;
6065                 int warned = 0;
6066                 d = SvPV_force(PL_lex_stuff, len);
6067                 while (len) {
6068                     for (; isSPACE(*d) && len; --len, ++d)
6069                         /**/;
6070                     if (len) {
6071                         SV *sv;
6072                         const char *b = d;
6073                         if (!warned && ckWARN(WARN_QW)) {
6074                             for (; !isSPACE(*d) && len; --len, ++d) {
6075                                 if (*d == ',') {
6076                                     Perl_warner(aTHX_ packWARN(WARN_QW),
6077                                         "Possible attempt to separate words with commas");
6078                                     ++warned;
6079                                 }
6080                                 else if (*d == '#') {
6081                                     Perl_warner(aTHX_ packWARN(WARN_QW),
6082                                         "Possible attempt to put comments in qw() list");
6083                                     ++warned;
6084                                 }
6085                             }
6086                         }
6087                         else {
6088                             for (; !isSPACE(*d) && len; --len, ++d)
6089                                 /**/;
6090                         }
6091                         sv = newSVpvn(b, d-b);
6092                         if (DO_UTF8(PL_lex_stuff))
6093                             SvUTF8_on(sv);
6094                         words = append_elem(OP_LIST, words,
6095                                             newSVOP(OP_CONST, 0, tokeq(sv)));
6096                     }
6097                 }
6098                 if (words) {
6099                     start_force(PL_curforce);
6100                     NEXTVAL_NEXTTOKE.opval = words;
6101                     force_next(THING);
6102                 }
6103             }
6104             if (PL_lex_stuff) {
6105                 SvREFCNT_dec(PL_lex_stuff);
6106                 PL_lex_stuff = NULL;
6107             }
6108             PL_expect = XTERM;
6109             TOKEN('(');
6110
6111         case KEY_qq:
6112             s = scan_str(s,!!PL_madskills,FALSE);
6113             if (!s)
6114                 missingterm(NULL);
6115             yylval.ival = OP_STRINGIFY;
6116             if (SvIVX(PL_lex_stuff) == '\'')
6117                 SvIV_set(PL_lex_stuff, 0);      /* qq'$foo' should intepolate */
6118             TERM(sublex_start());
6119
6120         case KEY_qr:
6121             s = scan_pat(s,OP_QR);
6122             TERM(sublex_start());
6123
6124         case KEY_qx:
6125             s = scan_str(s,!!PL_madskills,FALSE);
6126             if (!s)
6127                 missingterm(NULL);
6128             yylval.ival = OP_BACKTICK;
6129             set_csh();
6130             TERM(sublex_start());
6131
6132         case KEY_return:
6133             OLDLOP(OP_RETURN);
6134
6135         case KEY_require:
6136             s = SKIPSPACE1(s);
6137             if (isDIGIT(*s)) {
6138                 s = force_version(s, FALSE);
6139             }
6140             else if (*s != 'v' || !isDIGIT(s[1])
6141                     || (s = force_version(s, TRUE), *s == 'v'))
6142             {
6143                 *PL_tokenbuf = '\0';
6144                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6145                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6146                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
6147                 else if (*s == '<')
6148                     yyerror("<> should be quotes");
6149             }
6150             if (orig_keyword == KEY_require) {
6151                 orig_keyword = 0;
6152                 yylval.ival = 1;
6153             }
6154             else
6155                 yylval.ival = 0;
6156             PL_expect = XTERM;
6157             PL_bufptr = s;
6158             PL_last_uni = PL_oldbufptr;
6159             PL_last_lop_op = OP_REQUIRE;
6160             s = skipspace(s);
6161             return REPORT( (int)REQUIRE );
6162
6163         case KEY_reset:
6164             UNI(OP_RESET);
6165
6166         case KEY_redo:
6167             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6168             LOOPX(OP_REDO);
6169
6170         case KEY_rename:
6171             LOP(OP_RENAME,XTERM);
6172
6173         case KEY_rand:
6174             UNI(OP_RAND);
6175
6176         case KEY_rmdir:
6177             UNI(OP_RMDIR);
6178
6179         case KEY_rindex:
6180             LOP(OP_RINDEX,XTERM);
6181
6182         case KEY_read:
6183             LOP(OP_READ,XTERM);
6184
6185         case KEY_readdir:
6186             UNI(OP_READDIR);
6187
6188         case KEY_readline:
6189             set_csh();
6190             UNIDOR(OP_READLINE);
6191
6192         case KEY_readpipe:
6193             set_csh();
6194             UNI(OP_BACKTICK);
6195
6196         case KEY_rewinddir:
6197             UNI(OP_REWINDDIR);
6198
6199         case KEY_recv:
6200             LOP(OP_RECV,XTERM);
6201
6202         case KEY_reverse:
6203             LOP(OP_REVERSE,XTERM);
6204
6205         case KEY_readlink:
6206             UNIDOR(OP_READLINK);
6207
6208         case KEY_ref:
6209             UNI(OP_REF);
6210
6211         case KEY_s:
6212             s = scan_subst(s);
6213             if (yylval.opval)
6214                 TERM(sublex_start());
6215             else
6216                 TOKEN(1);       /* force error */
6217
6218         case KEY_say:
6219             checkcomma(s,PL_tokenbuf,"filehandle");
6220             LOP(OP_SAY,XREF);
6221
6222         case KEY_chomp:
6223             UNI(OP_CHOMP);
6224
6225         case KEY_scalar:
6226             UNI(OP_SCALAR);
6227
6228         case KEY_select:
6229             LOP(OP_SELECT,XTERM);
6230
6231         case KEY_seek:
6232             LOP(OP_SEEK,XTERM);
6233
6234         case KEY_semctl:
6235             LOP(OP_SEMCTL,XTERM);
6236
6237         case KEY_semget:
6238             LOP(OP_SEMGET,XTERM);
6239
6240         case KEY_semop:
6241             LOP(OP_SEMOP,XTERM);
6242
6243         case KEY_send:
6244             LOP(OP_SEND,XTERM);
6245
6246         case KEY_setpgrp:
6247             LOP(OP_SETPGRP,XTERM);
6248
6249         case KEY_setpriority:
6250             LOP(OP_SETPRIORITY,XTERM);
6251
6252         case KEY_sethostent:
6253             UNI(OP_SHOSTENT);
6254
6255         case KEY_setnetent:
6256             UNI(OP_SNETENT);
6257
6258         case KEY_setservent:
6259             UNI(OP_SSERVENT);
6260
6261         case KEY_setprotoent:
6262             UNI(OP_SPROTOENT);
6263
6264         case KEY_setpwent:
6265             FUN0(OP_SPWENT);
6266
6267         case KEY_setgrent:
6268             FUN0(OP_SGRENT);
6269
6270         case KEY_seekdir:
6271             LOP(OP_SEEKDIR,XTERM);
6272
6273         case KEY_setsockopt:
6274             LOP(OP_SSOCKOPT,XTERM);
6275
6276         case KEY_shift:
6277             UNIDOR(OP_SHIFT);
6278
6279         case KEY_shmctl:
6280             LOP(OP_SHMCTL,XTERM);
6281
6282         case KEY_shmget:
6283             LOP(OP_SHMGET,XTERM);
6284
6285         case KEY_shmread:
6286             LOP(OP_SHMREAD,XTERM);
6287
6288         case KEY_shmwrite:
6289             LOP(OP_SHMWRITE,XTERM);
6290
6291         case KEY_shutdown:
6292             LOP(OP_SHUTDOWN,XTERM);
6293
6294         case KEY_sin:
6295             UNI(OP_SIN);
6296
6297         case KEY_sleep:
6298             UNI(OP_SLEEP);
6299
6300         case KEY_socket:
6301             LOP(OP_SOCKET,XTERM);
6302
6303         case KEY_socketpair:
6304             LOP(OP_SOCKPAIR,XTERM);
6305
6306         case KEY_sort:
6307             checkcomma(s,PL_tokenbuf,"subroutine name");
6308             s = SKIPSPACE1(s);
6309             if (*s == ';' || *s == ')')         /* probably a close */
6310                 Perl_croak(aTHX_ "sort is now a reserved word");
6311             PL_expect = XTERM;
6312             s = force_word(s,WORD,TRUE,TRUE,FALSE);
6313             LOP(OP_SORT,XREF);
6314
6315         case KEY_split:
6316             LOP(OP_SPLIT,XTERM);
6317
6318         case KEY_sprintf:
6319             LOP(OP_SPRINTF,XTERM);
6320
6321         case KEY_splice:
6322             LOP(OP_SPLICE,XTERM);
6323
6324         case KEY_sqrt:
6325             UNI(OP_SQRT);
6326
6327         case KEY_srand:
6328             UNI(OP_SRAND);
6329
6330         case KEY_stat:
6331             UNI(OP_STAT);
6332
6333         case KEY_study:
6334             UNI(OP_STUDY);
6335
6336         case KEY_substr:
6337             LOP(OP_SUBSTR,XTERM);
6338
6339         case KEY_format:
6340         case KEY_sub:
6341           really_sub:
6342             {
6343                 char tmpbuf[sizeof PL_tokenbuf];
6344                 SSize_t tboffset = 0;
6345                 expectation attrful;
6346                 bool have_name, have_proto, bad_proto;
6347                 const int key = tmp;
6348
6349 #ifdef PERL_MAD
6350                 SV *tmpwhite = 0;
6351
6352                 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6353                 SV *subtoken = newSVpvn(tstart, s - tstart);
6354                 PL_thistoken = 0;
6355
6356                 d = s;
6357                 s = SKIPSPACE2(s,tmpwhite);
6358 #else
6359                 s = skipspace(s);
6360 #endif
6361
6362                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6363                     (*s == ':' && s[1] == ':'))
6364                 {
6365 #ifdef PERL_MAD
6366                     SV *nametoke;
6367 #endif
6368
6369                     PL_expect = XBLOCK;
6370                     attrful = XATTRBLOCK;
6371                     /* remember buffer pos'n for later force_word */
6372                     tboffset = s - PL_oldbufptr;
6373                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6374 #ifdef PERL_MAD
6375                     if (PL_madskills)
6376                         nametoke = newSVpvn(s, d - s);
6377 #endif
6378                     if (strchr(tmpbuf, ':'))
6379                         sv_setpv(PL_subname, tmpbuf);
6380                     else {
6381                         sv_setsv(PL_subname,PL_curstname);
6382                         sv_catpvs(PL_subname,"::");
6383                         sv_catpvn(PL_subname,tmpbuf,len);
6384                     }
6385                     have_name = TRUE;
6386
6387 #ifdef PERL_MAD
6388
6389                     start_force(0);
6390                     CURMAD('X', nametoke);
6391                     CURMAD('_', tmpwhite);
6392                     (void) force_word(PL_oldbufptr + tboffset, WORD,
6393                                       FALSE, TRUE, TRUE);
6394
6395                     s = SKIPSPACE2(d,tmpwhite);
6396 #else
6397                     s = skipspace(d);
6398 #endif
6399                 }
6400                 else {
6401                     if (key == KEY_my)
6402                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
6403                     PL_expect = XTERMBLOCK;
6404                     attrful = XATTRTERM;
6405                     sv_setpvn(PL_subname,"?",1);
6406                     have_name = FALSE;
6407                 }
6408
6409                 if (key == KEY_format) {
6410                     if (*s == '=')
6411                         PL_lex_formbrack = PL_lex_brackets + 1;
6412 #ifdef PERL_MAD
6413                     PL_thistoken = subtoken;
6414                     s = d;
6415 #else
6416                     if (have_name)
6417                         (void) force_word(PL_oldbufptr + tboffset, WORD,
6418                                           FALSE, TRUE, TRUE);
6419 #endif
6420                     OPERATOR(FORMAT);
6421                 }
6422
6423                 /* Look for a prototype */
6424                 if (*s == '(') {
6425                     char *p;
6426
6427                     s = scan_str(s,!!PL_madskills,FALSE);
6428                     if (!s)
6429                         Perl_croak(aTHX_ "Prototype not terminated");
6430                     /* strip spaces and check for bad characters */
6431                     d = SvPVX(PL_lex_stuff);
6432                     tmp = 0;
6433                     bad_proto = FALSE;
6434                     for (p = d; *p; ++p) {
6435                         if (!isSPACE(*p)) {
6436                             d[tmp++] = *p;
6437                             if (!strchr("$@%*;[]&\\", *p))
6438                                 bad_proto = TRUE;
6439                         }
6440                     }
6441                     d[tmp] = '\0';
6442                     if (bad_proto && ckWARN(WARN_SYNTAX))
6443                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6444                                     "Illegal character in prototype for %"SVf" : %s",
6445                                     PL_subname, d);
6446                     SvCUR_set(PL_lex_stuff, tmp);
6447                     have_proto = TRUE;
6448
6449 #ifdef PERL_MAD
6450                     start_force(0);
6451                     CURMAD('q', PL_thisopen);
6452                     CURMAD('_', tmpwhite);
6453                     CURMAD('=', PL_thisstuff);
6454                     CURMAD('Q', PL_thisclose);
6455                     NEXTVAL_NEXTTOKE.opval =
6456                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6457                     PL_lex_stuff = Nullsv;
6458                     force_next(THING);
6459
6460                     s = SKIPSPACE2(s,tmpwhite);
6461 #else
6462                     s = skipspace(s);
6463 #endif
6464                 }
6465                 else
6466                     have_proto = FALSE;
6467
6468                 if (*s == ':' && s[1] != ':')
6469                     PL_expect = attrful;
6470                 else if (*s != '{' && key == KEY_sub) {
6471                     if (!have_name)
6472                         Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6473                     else if (*s != ';')
6474                         Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
6475                 }
6476
6477 #ifdef PERL_MAD
6478                 start_force(0);
6479                 if (tmpwhite) {
6480                     if (PL_madskills)
6481                         curmad('^', newSVpvn("",0));
6482                     CURMAD('_', tmpwhite);
6483                 }
6484                 force_next(0);
6485
6486                 PL_thistoken = subtoken;
6487 #else
6488                 if (have_proto) {
6489                     NEXTVAL_NEXTTOKE.opval =
6490                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6491                     PL_lex_stuff = NULL;
6492                     force_next(THING);
6493                 }
6494 #endif
6495                 if (!have_name) {
6496                     sv_setpv(PL_subname,
6497                         PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
6498                     TOKEN(ANONSUB);
6499                 }
6500 #ifndef PERL_MAD
6501                 (void) force_word(PL_oldbufptr + tboffset, WORD,
6502                                   FALSE, TRUE, TRUE);
6503 #endif
6504                 if (key == KEY_my)
6505                     TOKEN(MYSUB);
6506                 TOKEN(SUB);
6507             }
6508
6509         case KEY_system:
6510             set_csh();
6511             LOP(OP_SYSTEM,XREF);
6512
6513         case KEY_symlink:
6514             LOP(OP_SYMLINK,XTERM);
6515
6516         case KEY_syscall:
6517             LOP(OP_SYSCALL,XTERM);
6518
6519         case KEY_sysopen:
6520             LOP(OP_SYSOPEN,XTERM);
6521
6522         case KEY_sysseek:
6523             LOP(OP_SYSSEEK,XTERM);
6524
6525         case KEY_sysread:
6526             LOP(OP_SYSREAD,XTERM);
6527
6528         case KEY_syswrite:
6529             LOP(OP_SYSWRITE,XTERM);
6530
6531         case KEY_tr:
6532             s = scan_trans(s);
6533             TERM(sublex_start());
6534
6535         case KEY_tell:
6536             UNI(OP_TELL);
6537
6538         case KEY_telldir:
6539             UNI(OP_TELLDIR);
6540
6541         case KEY_tie:
6542             LOP(OP_TIE,XTERM);
6543
6544         case KEY_tied:
6545             UNI(OP_TIED);
6546
6547         case KEY_time:
6548             FUN0(OP_TIME);
6549
6550         case KEY_times:
6551             FUN0(OP_TMS);
6552
6553         case KEY_truncate:
6554             LOP(OP_TRUNCATE,XTERM);
6555
6556         case KEY_uc:
6557             UNI(OP_UC);
6558
6559         case KEY_ucfirst:
6560             UNI(OP_UCFIRST);
6561
6562         case KEY_untie:
6563             UNI(OP_UNTIE);
6564
6565         case KEY_until:
6566             yylval.ival = CopLINE(PL_curcop);
6567             OPERATOR(UNTIL);
6568
6569         case KEY_unless:
6570             yylval.ival = CopLINE(PL_curcop);
6571             OPERATOR(UNLESS);
6572
6573         case KEY_unlink:
6574             LOP(OP_UNLINK,XTERM);
6575
6576         case KEY_undef:
6577             UNIDOR(OP_UNDEF);
6578
6579         case KEY_unpack:
6580             LOP(OP_UNPACK,XTERM);
6581
6582         case KEY_utime:
6583             LOP(OP_UTIME,XTERM);
6584
6585         case KEY_umask:
6586             UNIDOR(OP_UMASK);
6587
6588         case KEY_unshift:
6589             LOP(OP_UNSHIFT,XTERM);
6590
6591         case KEY_use:
6592             s = tokenize_use(1, s);
6593             OPERATOR(USE);
6594
6595         case KEY_values:
6596             UNI(OP_VALUES);
6597
6598         case KEY_vec:
6599             LOP(OP_VEC,XTERM);
6600
6601         case KEY_when:
6602             yylval.ival = CopLINE(PL_curcop);
6603             OPERATOR(WHEN);
6604
6605         case KEY_while:
6606             yylval.ival = CopLINE(PL_curcop);
6607             OPERATOR(WHILE);
6608
6609         case KEY_warn:
6610             PL_hints |= HINT_BLOCK_SCOPE;
6611             LOP(OP_WARN,XTERM);
6612
6613         case KEY_wait:
6614             FUN0(OP_WAIT);
6615
6616         case KEY_waitpid:
6617             LOP(OP_WAITPID,XTERM);
6618
6619         case KEY_wantarray:
6620             FUN0(OP_WANTARRAY);
6621
6622         case KEY_write:
6623 #ifdef EBCDIC
6624         {
6625             char ctl_l[2];
6626             ctl_l[0] = toCTRL('L');
6627             ctl_l[1] = '\0';
6628             gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
6629         }
6630 #else
6631             /* Make sure $^L is defined */
6632             gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
6633 #endif
6634             UNI(OP_ENTERWRITE);
6635
6636         case KEY_x:
6637             if (PL_expect == XOPERATOR)
6638                 Mop(OP_REPEAT);
6639             check_uni();
6640             goto just_a_word;
6641
6642         case KEY_xor:
6643             yylval.ival = OP_XOR;
6644             OPERATOR(OROP);
6645
6646         case KEY_y:
6647             s = scan_trans(s);
6648             TERM(sublex_start());
6649         }
6650     }}
6651 }
6652 #ifdef __SC__
6653 #pragma segment Main
6654 #endif
6655
6656 static int
6657 S_pending_ident(pTHX)
6658 {
6659     dVAR;
6660     register char *d;
6661     register I32 tmp = 0;
6662     /* pit holds the identifier we read and pending_ident is reset */
6663     char pit = PL_pending_ident;
6664     PL_pending_ident = 0;
6665
6666     /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
6667     DEBUG_T({ PerlIO_printf(Perl_debug_log,
6668           "### Pending identifier '%s'\n", PL_tokenbuf); });
6669
6670     /* if we're in a my(), we can't allow dynamics here.
6671        $foo'bar has already been turned into $foo::bar, so
6672        just check for colons.
6673
6674        if it's a legal name, the OP is a PADANY.
6675     */
6676     if (PL_in_my) {
6677         if (PL_in_my == KEY_our) {      /* "our" is merely analogous to "my" */
6678             if (strchr(PL_tokenbuf,':'))
6679                 yyerror(Perl_form(aTHX_ "No package name allowed for "
6680                                   "variable %s in \"our\"",
6681                                   PL_tokenbuf));
6682             tmp = allocmy(PL_tokenbuf);
6683         }
6684         else {
6685             if (strchr(PL_tokenbuf,':'))
6686                 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
6687
6688             yylval.opval = newOP(OP_PADANY, 0);
6689             yylval.opval->op_targ = allocmy(PL_tokenbuf);
6690             return PRIVATEREF;
6691         }
6692     }
6693
6694     /*
6695        build the ops for accesses to a my() variable.
6696
6697        Deny my($a) or my($b) in a sort block, *if* $a or $b is
6698        then used in a comparison.  This catches most, but not
6699        all cases.  For instance, it catches
6700            sort { my($a); $a <=> $b }
6701        but not
6702            sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
6703        (although why you'd do that is anyone's guess).
6704     */
6705
6706     if (!strchr(PL_tokenbuf,':')) {
6707         if (!PL_in_my)
6708             tmp = pad_findmy(PL_tokenbuf);
6709         if (tmp != NOT_IN_PAD) {
6710             /* might be an "our" variable" */
6711             if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
6712                 /* build ops for a bareword */
6713                 HV *  const stash = PAD_COMPNAME_OURSTASH(tmp);
6714                 HEK * const stashname = HvNAME_HEK(stash);
6715                 SV *  const sym = newSVhek(stashname);
6716                 sv_catpvs(sym, "::");
6717                 sv_catpv(sym, PL_tokenbuf+1);
6718                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
6719                 yylval.opval->op_private = OPpCONST_ENTERED;
6720                 gv_fetchsv(sym,
6721                     (PL_in_eval
6722                         ? (GV_ADDMULTI | GV_ADDINEVAL)
6723                         : GV_ADDMULTI
6724                     ),
6725                     ((PL_tokenbuf[0] == '$') ? SVt_PV
6726                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
6727                      : SVt_PVHV));
6728                 return WORD;
6729             }
6730
6731             /* if it's a sort block and they're naming $a or $b */
6732             if (PL_last_lop_op == OP_SORT &&
6733                 PL_tokenbuf[0] == '$' &&
6734                 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
6735                 && !PL_tokenbuf[2])
6736             {
6737                 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
6738                      d < PL_bufend && *d != '\n';
6739                      d++)
6740                 {
6741                     if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
6742                         Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
6743                               PL_tokenbuf);
6744                     }
6745                 }
6746             }
6747
6748             yylval.opval = newOP(OP_PADANY, 0);
6749             yylval.opval->op_targ = tmp;
6750             return PRIVATEREF;
6751         }
6752     }
6753
6754     /*
6755        Whine if they've said @foo in a doublequoted string,
6756        and @foo isn't a variable we can find in the symbol
6757        table.
6758     */
6759     if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
6760         GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
6761         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
6762              && ckWARN(WARN_AMBIGUOUS))
6763         {
6764             /* Downgraded from fatal to warning 20000522 mjd */
6765             Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6766                         "Possible unintended interpolation of %s in string",
6767                          PL_tokenbuf);
6768         }
6769     }
6770
6771     /* build ops for a bareword */
6772     yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
6773     yylval.opval->op_private = OPpCONST_ENTERED;
6774     gv_fetchpv(
6775             PL_tokenbuf+1,
6776             /* If the identifier refers to a stash, don't autovivify it.
6777              * Change 24660 had the side effect of causing symbol table
6778              * hashes to always be defined, even if they were freshly
6779              * created and the only reference in the entire program was
6780              * the single statement with the defined %foo::bar:: test.
6781              * It appears that all code in the wild doing this actually
6782              * wants to know whether sub-packages have been loaded, so
6783              * by avoiding auto-vivifying symbol tables, we ensure that
6784              * defined %foo::bar:: continues to be false, and the existing
6785              * tests still give the expected answers, even though what
6786              * they're actually testing has now changed subtly.
6787              */
6788             (*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'
6789              ? 0
6790              : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
6791             ((PL_tokenbuf[0] == '$') ? SVt_PV
6792              : (PL_tokenbuf[0] == '@') ? SVt_PVAV
6793              : SVt_PVHV));
6794     return WORD;
6795 }
6796
6797 /*
6798  *  The following code was generated by perl_keyword.pl.
6799  */
6800
6801 I32
6802 Perl_keyword (pTHX_ const char *name, I32 len)
6803 {
6804   dVAR;
6805   switch (len)
6806   {
6807     case 1: /* 5 tokens of length 1 */
6808       switch (name[0])
6809       {
6810         case 'm':
6811           {                                       /* m          */
6812             return KEY_m;
6813           }
6814
6815         case 'q':
6816           {                                       /* q          */
6817             return KEY_q;
6818           }
6819
6820         case 's':
6821           {                                       /* s          */
6822             return KEY_s;
6823           }
6824
6825         case 'x':
6826           {                                       /* x          */
6827             return -KEY_x;
6828           }
6829
6830         case 'y':
6831           {                                       /* y          */
6832             return KEY_y;
6833           }
6834
6835         default:
6836           goto unknown;
6837       }
6838
6839     case 2: /* 18 tokens of length 2 */
6840       switch (name[0])
6841       {
6842         case 'd':
6843           if (name[1] == 'o')
6844           {                                       /* do         */
6845             return KEY_do;
6846           }
6847
6848           goto unknown;
6849
6850         case 'e':
6851           if (name[1] == 'q')
6852           {                                       /* eq         */
6853             return -KEY_eq;
6854           }
6855
6856           goto unknown;
6857
6858         case 'g':
6859           switch (name[1])
6860           {
6861             case 'e':
6862               {                                   /* ge         */
6863                 return -KEY_ge;
6864               }
6865
6866             case 't':
6867               {                                   /* gt         */
6868                 return -KEY_gt;
6869               }
6870
6871             default:
6872               goto unknown;
6873           }
6874
6875         case 'i':
6876           if (name[1] == 'f')
6877           {                                       /* if         */
6878             return KEY_if;
6879           }
6880
6881           goto unknown;
6882
6883         case 'l':
6884           switch (name[1])
6885           {
6886             case 'c':
6887               {                                   /* lc         */
6888                 return -KEY_lc;
6889               }
6890
6891             case 'e':
6892               {                                   /* le         */
6893                 return -KEY_le;
6894               }
6895
6896             case 't':
6897               {                                   /* lt         */
6898                 return -KEY_lt;
6899               }
6900
6901             default:
6902               goto unknown;
6903           }
6904
6905         case 'm':
6906           if (name[1] == 'y')
6907           {                                       /* my         */
6908             return KEY_my;
6909           }
6910
6911           goto unknown;
6912
6913         case 'n':
6914           switch (name[1])
6915           {
6916             case 'e':
6917               {                                   /* ne         */
6918                 return -KEY_ne;
6919               }
6920
6921             case 'o':
6922               {                                   /* no         */
6923                 return KEY_no;
6924               }
6925
6926             default:
6927               goto unknown;
6928           }
6929
6930         case 'o':
6931           if (name[1] == 'r')
6932           {                                       /* or         */
6933             return -KEY_or;
6934           }
6935
6936           goto unknown;
6937
6938         case 'q':
6939           switch (name[1])
6940           {
6941             case 'q':
6942               {                                   /* qq         */
6943                 return KEY_qq;
6944               }
6945
6946             case 'r':
6947               {                                   /* qr         */
6948                 return KEY_qr;
6949               }
6950
6951             case 'w':
6952               {                                   /* qw         */
6953                 return KEY_qw;
6954               }
6955
6956             case 'x':
6957               {                                   /* qx         */
6958                 return KEY_qx;
6959               }
6960
6961             default:
6962               goto unknown;
6963           }
6964
6965         case 't':
6966           if (name[1] == 'r')
6967           {                                       /* tr         */
6968             return KEY_tr;
6969           }
6970
6971           goto unknown;
6972
6973         case 'u':
6974           if (name[1] == 'c')
6975           {                                       /* uc         */
6976             return -KEY_uc;
6977           }
6978
6979           goto unknown;
6980
6981         default:
6982           goto unknown;
6983       }
6984
6985     case 3: /* 29 tokens of length 3 */
6986       switch (name[0])
6987       {
6988         case 'E':
6989           if (name[1] == 'N' &&
6990               name[2] == 'D')
6991           {                                       /* END        */
6992             return KEY_END;
6993           }
6994
6995           goto unknown;
6996
6997         case 'a':
6998           switch (name[1])
6999           {
7000             case 'b':
7001               if (name[2] == 's')
7002               {                                   /* abs        */
7003                 return -KEY_abs;
7004               }
7005
7006               goto unknown;
7007
7008             case 'n':
7009               if (name[2] == 'd')
7010               {                                   /* and        */
7011                 return -KEY_and;
7012               }
7013
7014               goto unknown;
7015
7016             default:
7017               goto unknown;
7018           }
7019
7020         case 'c':
7021           switch (name[1])
7022           {
7023             case 'h':
7024               if (name[2] == 'r')
7025               {                                   /* chr        */
7026                 return -KEY_chr;
7027               }
7028
7029               goto unknown;
7030
7031             case 'm':
7032               if (name[2] == 'p')
7033               {                                   /* cmp        */
7034                 return -KEY_cmp;
7035               }
7036
7037               goto unknown;
7038
7039             case 'o':
7040               if (name[2] == 's')
7041               {                                   /* cos        */
7042                 return -KEY_cos;
7043               }
7044
7045               goto unknown;
7046
7047             default:
7048               goto unknown;
7049           }
7050
7051         case 'd':
7052           if (name[1] == 'i' &&
7053               name[2] == 'e')
7054           {                                       /* die        */
7055             return -KEY_die;
7056           }
7057
7058           goto unknown;
7059
7060         case 'e':
7061           switch (name[1])
7062           {
7063             case 'o':
7064               if (name[2] == 'f')
7065               {                                   /* eof        */
7066                 return -KEY_eof;
7067               }
7068
7069               goto unknown;
7070
7071             case 'r':
7072               if (name[2] == 'r')
7073               {                                   /* err        */
7074                 return (FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
7075               }
7076
7077               goto unknown;
7078
7079             case 'x':
7080               if (name[2] == 'p')
7081               {                                   /* exp        */
7082                 return -KEY_exp;
7083               }
7084
7085               goto unknown;
7086
7087             default:
7088               goto unknown;
7089           }
7090
7091         case 'f':
7092           if (name[1] == 'o' &&
7093               name[2] == 'r')
7094           {                                       /* for        */
7095             return KEY_for;
7096           }
7097
7098           goto unknown;
7099
7100         case 'h':
7101           if (name[1] == 'e' &&
7102               name[2] == 'x')
7103           {                                       /* hex        */
7104             return -KEY_hex;
7105           }
7106
7107           goto unknown;
7108
7109         case 'i':
7110           if (name[1] == 'n' &&
7111               name[2] == 't')
7112           {                                       /* int        */
7113             return -KEY_int;
7114           }
7115
7116           goto unknown;
7117
7118         case 'l':
7119           if (name[1] == 'o' &&
7120               name[2] == 'g')
7121           {                                       /* log        */
7122             return -KEY_log;
7123           }
7124
7125           goto unknown;
7126
7127         case 'm':
7128           if (name[1] == 'a' &&
7129               name[2] == 'p')
7130           {                                       /* map        */
7131             return KEY_map;
7132           }
7133
7134           goto unknown;
7135
7136         case 'n':
7137           if (name[1] == 'o' &&
7138               name[2] == 't')
7139           {                                       /* not        */
7140             return -KEY_not;
7141           }
7142
7143           goto unknown;
7144
7145         case 'o':
7146           switch (name[1])
7147           {
7148             case 'c':
7149               if (name[2] == 't')
7150               {                                   /* oct        */
7151                 return -KEY_oct;
7152               }
7153
7154               goto unknown;
7155
7156             case 'r':
7157               if (name[2] == 'd')
7158               {                                   /* ord        */
7159                 return -KEY_ord;
7160               }
7161
7162               goto unknown;
7163
7164             case 'u':
7165               if (name[2] == 'r')
7166               {                                   /* our        */
7167                 return KEY_our;
7168               }
7169
7170               goto unknown;
7171
7172             default:
7173               goto unknown;
7174           }
7175
7176         case 'p':
7177           if (name[1] == 'o')
7178           {
7179             switch (name[2])
7180             {
7181               case 'p':
7182                 {                                 /* pop        */
7183                   return -KEY_pop;
7184                 }
7185
7186               case 's':
7187                 {                                 /* pos        */
7188                   return KEY_pos;
7189                 }
7190
7191               default:
7192                 goto unknown;
7193             }
7194           }
7195
7196           goto unknown;
7197
7198         case 'r':
7199           if (name[1] == 'e' &&
7200               name[2] == 'f')
7201           {                                       /* ref        */
7202             return -KEY_ref;
7203           }
7204
7205           goto unknown;
7206
7207         case 's':
7208           switch (name[1])
7209           {
7210             case 'a':
7211               if (name[2] == 'y')
7212               {                                   /* say        */
7213                 return (FEATURE_IS_ENABLED("say") ? -KEY_say : 0);
7214               }
7215
7216               goto unknown;
7217
7218             case 'i':
7219               if (name[2] == 'n')
7220               {                                   /* sin        */
7221                 return -KEY_sin;
7222               }
7223
7224               goto unknown;
7225
7226             case 'u':
7227               if (name[2] == 'b')
7228               {                                   /* sub        */
7229                 return KEY_sub;
7230               }
7231
7232               goto unknown;
7233
7234             default:
7235               goto unknown;
7236           }
7237
7238         case 't':
7239           if (name[1] == 'i' &&
7240               name[2] == 'e')
7241           {                                       /* tie        */
7242             return KEY_tie;
7243           }
7244
7245           goto unknown;
7246
7247         case 'u':
7248           if (name[1] == 's' &&
7249               name[2] == 'e')
7250           {                                       /* use        */
7251             return KEY_use;
7252           }
7253
7254           goto unknown;
7255
7256         case 'v':
7257           if (name[1] == 'e' &&
7258               name[2] == 'c')
7259           {                                       /* vec        */
7260             return -KEY_vec;
7261           }
7262
7263           goto unknown;
7264
7265         case 'x':
7266           if (name[1] == 'o' &&
7267               name[2] == 'r')
7268           {                                       /* xor        */
7269             return -KEY_xor;
7270           }
7271
7272           goto unknown;
7273
7274         default:
7275           goto unknown;
7276       }
7277
7278     case 4: /* 41 tokens of length 4 */
7279       switch (name[0])
7280       {
7281         case 'C':
7282           if (name[1] == 'O' &&
7283               name[2] == 'R' &&
7284               name[3] == 'E')
7285           {                                       /* CORE       */
7286             return -KEY_CORE;
7287           }
7288
7289           goto unknown;
7290
7291         case 'I':
7292           if (name[1] == 'N' &&
7293               name[2] == 'I' &&
7294               name[3] == 'T')
7295           {                                       /* INIT       */
7296             return KEY_INIT;
7297           }
7298
7299           goto unknown;
7300
7301         case 'b':
7302           if (name[1] == 'i' &&
7303               name[2] == 'n' &&
7304               name[3] == 'd')
7305           {                                       /* bind       */
7306             return -KEY_bind;
7307           }
7308
7309           goto unknown;
7310
7311         case 'c':
7312           if (name[1] == 'h' &&
7313               name[2] == 'o' &&
7314               name[3] == 'p')
7315           {                                       /* chop       */
7316             return -KEY_chop;
7317           }
7318
7319           goto unknown;
7320
7321         case 'd':
7322           if (name[1] == 'u' &&
7323               name[2] == 'm' &&
7324               name[3] == 'p')
7325           {                                       /* dump       */
7326             return -KEY_dump;
7327           }
7328
7329           goto unknown;
7330
7331         case 'e':
7332           switch (name[1])
7333           {
7334             case 'a':
7335               if (name[2] == 'c' &&
7336                   name[3] == 'h')
7337               {                                   /* each       */
7338                 return -KEY_each;
7339               }
7340
7341               goto unknown;
7342
7343             case 'l':
7344               if (name[2] == 's' &&
7345                   name[3] == 'e')
7346               {                                   /* else       */
7347                 return KEY_else;
7348               }
7349
7350               goto unknown;
7351
7352             case 'v':
7353               if (name[2] == 'a' &&
7354                   name[3] == 'l')
7355               {                                   /* eval       */
7356                 return KEY_eval;
7357               }
7358
7359               goto unknown;
7360
7361             case 'x':
7362               switch (name[2])
7363               {
7364                 case 'e':
7365                   if (name[3] == 'c')
7366                   {                               /* exec       */
7367                     return -KEY_exec;
7368                   }
7369
7370                   goto unknown;
7371
7372                 case 'i':
7373                   if (name[3] == 't')
7374                   {                               /* exit       */
7375                     return -KEY_exit;
7376                   }
7377
7378                   goto unknown;
7379
7380                 default:
7381                   goto unknown;
7382               }
7383
7384             default:
7385               goto unknown;
7386           }
7387
7388         case 'f':
7389           if (name[1] == 'o' &&
7390               name[2] == 'r' &&
7391               name[3] == 'k')
7392           {                                       /* fork       */
7393             return -KEY_fork;
7394           }
7395
7396           goto unknown;
7397
7398         case 'g':
7399           switch (name[1])
7400           {
7401             case 'e':
7402               if (name[2] == 't' &&
7403                   name[3] == 'c')
7404               {                                   /* getc       */
7405                 return -KEY_getc;
7406               }
7407
7408               goto unknown;
7409
7410             case 'l':
7411               if (name[2] == 'o' &&
7412                   name[3] == 'b')
7413               {                                   /* glob       */
7414                 return KEY_glob;
7415               }
7416
7417               goto unknown;
7418
7419             case 'o':
7420               if (name[2] == 't' &&
7421                   name[3] == 'o')
7422               {                                   /* goto       */
7423                 return KEY_goto;
7424               }
7425
7426               goto unknown;
7427
7428             case 'r':
7429               if (name[2] == 'e' &&
7430                   name[3] == 'p')
7431               {                                   /* grep       */
7432                 return KEY_grep;
7433               }
7434
7435               goto unknown;
7436
7437             default:
7438               goto unknown;
7439           }
7440
7441         case 'j':
7442           if (name[1] == 'o' &&
7443               name[2] == 'i' &&
7444               name[3] == 'n')
7445           {                                       /* join       */
7446             return -KEY_join;
7447           }
7448
7449           goto unknown;
7450
7451         case 'k':
7452           switch (name[1])
7453           {
7454             case 'e':
7455               if (name[2] == 'y' &&
7456                   name[3] == 's')
7457               {                                   /* keys       */
7458                 return -KEY_keys;
7459               }
7460
7461               goto unknown;
7462
7463             case 'i':
7464               if (name[2] == 'l' &&
7465                   name[3] == 'l')
7466               {                                   /* kill       */
7467                 return -KEY_kill;
7468               }
7469
7470               goto unknown;
7471
7472             default:
7473               goto unknown;
7474           }
7475
7476         case 'l':
7477           switch (name[1])
7478           {
7479             case 'a':
7480               if (name[2] == 's' &&
7481                   name[3] == 't')
7482               {                                   /* last       */
7483                 return KEY_last;
7484               }
7485
7486               goto unknown;
7487
7488             case 'i':
7489               if (name[2] == 'n' &&
7490                   name[3] == 'k')
7491               {                                   /* link       */
7492                 return -KEY_link;
7493               }
7494
7495               goto unknown;
7496
7497             case 'o':
7498               if (name[2] == 'c' &&
7499                   name[3] == 'k')
7500               {                                   /* lock       */
7501                 return -KEY_lock;
7502               }
7503
7504               goto unknown;
7505
7506             default:
7507               goto unknown;
7508           }
7509
7510         case 'n':
7511           if (name[1] == 'e' &&
7512               name[2] == 'x' &&
7513               name[3] == 't')
7514           {                                       /* next       */
7515             return KEY_next;
7516           }
7517
7518           goto unknown;
7519
7520         case 'o':
7521           if (name[1] == 'p' &&
7522               name[2] == 'e' &&
7523               name[3] == 'n')
7524           {                                       /* open       */
7525             return -KEY_open;
7526           }
7527
7528           goto unknown;
7529
7530         case 'p':
7531           switch (name[1])
7532           {
7533             case 'a':
7534               if (name[2] == 'c' &&
7535                   name[3] == 'k')
7536               {                                   /* pack       */
7537                 return -KEY_pack;
7538               }
7539
7540               goto unknown;
7541
7542             case 'i':
7543               if (name[2] == 'p' &&
7544                   name[3] == 'e')
7545               {                                   /* pipe       */
7546                 return -KEY_pipe;
7547               }
7548
7549               goto unknown;
7550
7551             case 'u':
7552               if (name[2] == 's' &&
7553                   name[3] == 'h')
7554               {                                   /* push       */
7555                 return -KEY_push;
7556               }
7557
7558               goto unknown;
7559
7560             default:
7561               goto unknown;
7562           }
7563
7564         case 'r':
7565           switch (name[1])
7566           {
7567             case 'a':
7568               if (name[2] == 'n' &&
7569                   name[3] == 'd')
7570               {                                   /* rand       */
7571                 return -KEY_rand;
7572               }
7573
7574               goto unknown;
7575
7576             case 'e':
7577               switch (name[2])
7578               {
7579                 case 'a':
7580                   if (name[3] == 'd')
7581                   {                               /* read       */
7582                     return -KEY_read;
7583                   }
7584
7585                   goto unknown;
7586
7587                 case 'c':
7588                   if (name[3] == 'v')
7589                   {                               /* recv       */
7590                     return -KEY_recv;
7591                   }
7592
7593                   goto unknown;
7594
7595                 case 'd':
7596                   if (name[3] == 'o')
7597                   {                               /* redo       */
7598                     return KEY_redo;
7599                   }
7600
7601                   goto unknown;
7602
7603                 default:
7604                   goto unknown;
7605               }
7606
7607             default:
7608               goto unknown;
7609           }
7610
7611         case 's':
7612           switch (name[1])
7613           {
7614             case 'e':
7615               switch (name[2])
7616               {
7617                 case 'e':
7618                   if (name[3] == 'k')
7619                   {                               /* seek       */
7620                     return -KEY_seek;
7621                   }
7622
7623                   goto unknown;
7624
7625                 case 'n':
7626                   if (name[3] == 'd')
7627                   {                               /* send       */
7628                     return -KEY_send;
7629                   }
7630
7631                   goto unknown;
7632
7633                 default:
7634                   goto unknown;
7635               }
7636
7637             case 'o':
7638               if (name[2] == 'r' &&
7639                   name[3] == 't')
7640               {                                   /* sort       */
7641                 return KEY_sort;
7642               }
7643
7644               goto unknown;
7645
7646             case 'q':
7647               if (name[2] == 'r' &&
7648                   name[3] == 't')
7649               {                                   /* sqrt       */
7650                 return -KEY_sqrt;
7651               }
7652
7653               goto unknown;
7654
7655             case 't':
7656               if (name[2] == 'a' &&
7657                   name[3] == 't')
7658               {                                   /* stat       */
7659                 return -KEY_stat;
7660               }
7661
7662               goto unknown;
7663
7664             default:
7665               goto unknown;
7666           }
7667
7668         case 't':
7669           switch (name[1])
7670           {
7671             case 'e':
7672               if (name[2] == 'l' &&
7673                   name[3] == 'l')
7674               {                                   /* tell       */
7675                 return -KEY_tell;
7676               }
7677
7678               goto unknown;
7679
7680             case 'i':
7681               switch (name[2])
7682               {
7683                 case 'e':
7684                   if (name[3] == 'd')
7685                   {                               /* tied       */
7686                     return KEY_tied;
7687                   }
7688
7689                   goto unknown;
7690
7691                 case 'm':
7692                   if (name[3] == 'e')
7693                   {                               /* time       */
7694                     return -KEY_time;
7695                   }
7696
7697                   goto unknown;
7698
7699                 default:
7700                   goto unknown;
7701               }
7702
7703             default:
7704               goto unknown;
7705           }
7706
7707         case 'w':
7708           switch (name[1])
7709           {
7710             case 'a':
7711             switch (name[2])
7712             {
7713               case 'i':
7714                 if (name[3] == 't')
7715                 {                                 /* wait       */
7716                   return -KEY_wait;
7717                 }
7718
7719                 goto unknown;
7720
7721               case 'r':
7722                 if (name[3] == 'n')
7723                 {                                 /* warn       */
7724                   return -KEY_warn;
7725                 }
7726
7727                 goto unknown;
7728
7729               default:
7730                 goto unknown;
7731             }
7732
7733             case 'h':
7734               if (name[2] == 'e' &&
7735                   name[3] == 'n')
7736               {                                   /* when       */
7737                 return (FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
7738           }
7739
7740           goto unknown;
7741
7742         default:
7743           goto unknown;
7744       }
7745
7746         default:
7747           goto unknown;
7748       }
7749
7750     case 5: /* 38 tokens of length 5 */
7751       switch (name[0])
7752       {
7753         case 'B':
7754           if (name[1] == 'E' &&
7755               name[2] == 'G' &&
7756               name[3] == 'I' &&
7757               name[4] == 'N')
7758           {                                       /* BEGIN      */
7759             return KEY_BEGIN;
7760           }
7761
7762           goto unknown;
7763
7764         case 'C':
7765           if (name[1] == 'H' &&
7766               name[2] == 'E' &&
7767               name[3] == 'C' &&
7768               name[4] == 'K')
7769           {                                       /* CHECK      */
7770             return KEY_CHECK;
7771           }
7772
7773           goto unknown;
7774
7775         case 'a':
7776           switch (name[1])
7777           {
7778             case 'l':
7779               if (name[2] == 'a' &&
7780                   name[3] == 'r' &&
7781                   name[4] == 'm')
7782               {                                   /* alarm      */
7783                 return -KEY_alarm;
7784               }
7785
7786               goto unknown;
7787
7788             case 't':
7789               if (name[2] == 'a' &&
7790                   name[3] == 'n' &&
7791                   name[4] == '2')
7792               {                                   /* atan2      */
7793                 return -KEY_atan2;
7794               }
7795
7796               goto unknown;
7797
7798             default:
7799               goto unknown;
7800           }
7801
7802         case 'b':
7803           switch (name[1])
7804           {
7805             case 'l':
7806               if (name[2] == 'e' &&
7807               name[3] == 's' &&
7808               name[4] == 's')
7809           {                                       /* bless      */
7810             return -KEY_bless;
7811           }
7812
7813           goto unknown;
7814
7815             case 'r':
7816               if (name[2] == 'e' &&
7817                   name[3] == 'a' &&
7818                   name[4] == 'k')
7819               {                                   /* break      */
7820                 return (FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
7821               }
7822
7823               goto unknown;
7824
7825             default:
7826               goto unknown;
7827           }
7828
7829         case 'c':
7830           switch (name[1])
7831           {
7832             case 'h':
7833               switch (name[2])
7834               {
7835                 case 'd':
7836                   if (name[3] == 'i' &&
7837                       name[4] == 'r')
7838                   {                               /* chdir      */
7839                     return -KEY_chdir;
7840                   }
7841
7842                   goto unknown;
7843
7844                 case 'm':
7845                   if (name[3] == 'o' &&
7846                       name[4] == 'd')
7847                   {                               /* chmod      */
7848                     return -KEY_chmod;
7849                   }
7850
7851                   goto unknown;
7852
7853                 case 'o':
7854                   switch (name[3])
7855                   {
7856                     case 'm':
7857                       if (name[4] == 'p')
7858                       {                           /* chomp      */
7859                         return -KEY_chomp;
7860                       }
7861
7862                       goto unknown;
7863
7864                     case 'w':
7865                       if (name[4] == 'n')
7866                       {                           /* chown      */
7867                         return -KEY_chown;
7868                       }
7869
7870                       goto unknown;
7871
7872                     default:
7873                       goto unknown;
7874                   }
7875
7876                 default:
7877                   goto unknown;
7878               }
7879
7880             case 'l':
7881               if (name[2] == 'o' &&
7882                   name[3] == 's' &&
7883                   name[4] == 'e')
7884               {                                   /* close      */
7885                 return -KEY_close;
7886               }
7887
7888               goto unknown;
7889
7890             case 'r':
7891               if (name[2] == 'y' &&
7892                   name[3] == 'p' &&
7893                   name[4] == 't')
7894               {                                   /* crypt      */
7895                 return -KEY_crypt;
7896               }
7897
7898               goto unknown;
7899
7900             default:
7901               goto unknown;
7902           }
7903
7904         case 'e':
7905           if (name[1] == 'l' &&
7906               name[2] == 's' &&
7907               name[3] == 'i' &&
7908               name[4] == 'f')
7909           {                                       /* elsif      */
7910             return KEY_elsif;
7911           }
7912
7913           goto unknown;
7914
7915         case 'f':
7916           switch (name[1])
7917           {
7918             case 'c':
7919               if (name[2] == 'n' &&
7920                   name[3] == 't' &&
7921                   name[4] == 'l')
7922               {                                   /* fcntl      */
7923                 return -KEY_fcntl;
7924               }
7925
7926               goto unknown;
7927
7928             case 'l':
7929               if (name[2] == 'o' &&
7930                   name[3] == 'c' &&
7931                   name[4] == 'k')
7932               {                                   /* flock      */
7933                 return -KEY_flock;
7934               }
7935
7936               goto unknown;
7937
7938             default:
7939               goto unknown;
7940           }
7941
7942         case 'g':
7943           if (name[1] == 'i' &&
7944               name[2] == 'v' &&
7945               name[3] == 'e' &&
7946               name[4] == 'n')
7947           {                                       /* given      */
7948             return (FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
7949           }
7950
7951           goto unknown;
7952
7953         case 'i':
7954           switch (name[1])
7955           {
7956             case 'n':
7957               if (name[2] == 'd' &&
7958                   name[3] == 'e' &&
7959                   name[4] == 'x')
7960               {                                   /* index      */
7961                 return -KEY_index;
7962               }
7963
7964               goto unknown;
7965
7966             case 'o':
7967               if (name[2] == 'c' &&
7968                   name[3] == 't' &&
7969                   name[4] == 'l')
7970               {                                   /* ioctl      */
7971                 return -KEY_ioctl;
7972               }
7973
7974               goto unknown;
7975
7976             default:
7977               goto unknown;
7978           }
7979
7980         case 'l':
7981           switch (name[1])
7982           {
7983             case 'o':
7984               if (name[2] == 'c' &&
7985                   name[3] == 'a' &&
7986                   name[4] == 'l')
7987               {                                   /* local      */
7988                 return KEY_local;
7989               }
7990
7991               goto unknown;
7992
7993             case 's':
7994               if (name[2] == 't' &&
7995                   name[3] == 'a' &&
7996                   name[4] == 't')
7997               {                                   /* lstat      */
7998                 return -KEY_lstat;
7999               }
8000
8001               goto unknown;
8002
8003             default:
8004               goto unknown;
8005           }
8006
8007         case 'm':
8008           if (name[1] == 'k' &&
8009               name[2] == 'd' &&
8010               name[3] == 'i' &&
8011               name[4] == 'r')
8012           {                                       /* mkdir      */
8013             return -KEY_mkdir;
8014           }
8015
8016           goto unknown;
8017
8018         case 'p':
8019           if (name[1] == 'r' &&
8020               name[2] == 'i' &&
8021               name[3] == 'n' &&
8022               name[4] == 't')
8023           {                                       /* print      */
8024             return KEY_print;
8025           }
8026
8027           goto unknown;
8028
8029         case 'r':
8030           switch (name[1])
8031           {
8032             case 'e':
8033               if (name[2] == 's' &&
8034                   name[3] == 'e' &&
8035                   name[4] == 't')
8036               {                                   /* reset      */
8037                 return -KEY_reset;
8038               }
8039
8040               goto unknown;
8041
8042             case 'm':
8043               if (name[2] == 'd' &&
8044                   name[3] == 'i' &&
8045                   name[4] == 'r')
8046               {                                   /* rmdir      */
8047                 return -KEY_rmdir;
8048               }
8049
8050               goto unknown;
8051
8052             default:
8053               goto unknown;
8054           }
8055
8056         case 's':
8057           switch (name[1])
8058           {
8059             case 'e':
8060               if (name[2] == 'm' &&
8061                   name[3] == 'o' &&
8062                   name[4] == 'p')
8063               {                                   /* semop      */
8064                 return -KEY_semop;
8065               }
8066
8067               goto unknown;
8068
8069             case 'h':
8070               if (name[2] == 'i' &&
8071                   name[3] == 'f' &&
8072                   name[4] == 't')
8073               {                                   /* shift      */
8074                 return -KEY_shift;
8075               }
8076
8077               goto unknown;
8078
8079             case 'l':
8080               if (name[2] == 'e' &&
8081                   name[3] == 'e' &&
8082                   name[4] == 'p')
8083               {                                   /* sleep      */
8084                 return -KEY_sleep;
8085               }
8086
8087               goto unknown;
8088
8089             case 'p':
8090               if (name[2] == 'l' &&
8091                   name[3] == 'i' &&
8092                   name[4] == 't')
8093               {                                   /* split      */
8094                 return KEY_split;
8095               }
8096
8097               goto unknown;
8098
8099             case 'r':
8100               if (name[2] == 'a' &&
8101                   name[3] == 'n' &&
8102                   name[4] == 'd')
8103               {                                   /* srand      */
8104                 return -KEY_srand;
8105               }
8106
8107               goto unknown;
8108
8109             case 't':
8110               if (name[2] == 'u' &&
8111                   name[3] == 'd' &&
8112                   name[4] == 'y')
8113               {                                   /* study      */
8114                 return KEY_study;
8115               }
8116
8117               goto unknown;
8118
8119             default:
8120               goto unknown;
8121           }
8122
8123         case 't':
8124           if (name[1] == 'i' &&
8125               name[2] == 'm' &&
8126               name[3] == 'e' &&
8127               name[4] == 's')
8128           {                                       /* times      */
8129             return -KEY_times;
8130           }
8131
8132           goto unknown;
8133
8134         case 'u':
8135           switch (name[1])
8136           {
8137             case 'm':
8138               if (name[2] == 'a' &&
8139                   name[3] == 's' &&
8140                   name[4] == 'k')
8141               {                                   /* umask      */
8142                 return -KEY_umask;
8143               }
8144
8145               goto unknown;
8146
8147             case 'n':
8148               switch (name[2])
8149               {
8150                 case 'd':
8151                   if (name[3] == 'e' &&
8152                       name[4] == 'f')
8153                   {                               /* undef      */
8154                     return KEY_undef;
8155                   }
8156
8157                   goto unknown;
8158
8159                 case 't':
8160                   if (name[3] == 'i')
8161                   {
8162                     switch (name[4])
8163                     {
8164                       case 'e':
8165                         {                         /* untie      */
8166                           return KEY_untie;
8167                         }
8168
8169                       case 'l':
8170                         {                         /* until      */
8171                           return KEY_until;
8172                         }
8173
8174                       default:
8175                         goto unknown;
8176                     }
8177                   }
8178
8179                   goto unknown;
8180
8181                 default:
8182                   goto unknown;
8183               }
8184
8185             case 't':
8186               if (name[2] == 'i' &&
8187                   name[3] == 'm' &&
8188                   name[4] == 'e')
8189               {                                   /* utime      */
8190                 return -KEY_utime;
8191               }
8192
8193               goto unknown;
8194
8195             default:
8196               goto unknown;
8197           }
8198
8199         case 'w':
8200           switch (name[1])
8201           {
8202             case 'h':
8203               if (name[2] == 'i' &&
8204                   name[3] == 'l' &&
8205                   name[4] == 'e')
8206               {                                   /* while      */
8207                 return KEY_while;
8208               }
8209
8210               goto unknown;
8211
8212             case 'r':
8213               if (name[2] == 'i' &&
8214                   name[3] == 't' &&
8215                   name[4] == 'e')
8216               {                                   /* write      */
8217                 return -KEY_write;
8218               }
8219
8220               goto unknown;
8221
8222             default:
8223               goto unknown;
8224           }
8225
8226         default:
8227           goto unknown;
8228       }
8229
8230     case 6: /* 33 tokens of length 6 */
8231       switch (name[0])
8232       {
8233         case 'a':
8234           if (name[1] == 'c' &&
8235               name[2] == 'c' &&
8236               name[3] == 'e' &&
8237               name[4] == 'p' &&
8238               name[5] == 't')
8239           {                                       /* accept     */
8240             return -KEY_accept;
8241           }
8242
8243           goto unknown;
8244
8245         case 'c':
8246           switch (name[1])
8247           {
8248             case 'a':
8249               if (name[2] == 'l' &&
8250                   name[3] == 'l' &&
8251                   name[4] == 'e' &&
8252                   name[5] == 'r')
8253               {                                   /* caller     */
8254                 return -KEY_caller;
8255               }
8256
8257               goto unknown;
8258
8259             case 'h':
8260               if (name[2] == 'r' &&
8261                   name[3] == 'o' &&
8262                   name[4] == 'o' &&
8263                   name[5] == 't')
8264               {                                   /* chroot     */
8265                 return -KEY_chroot;
8266               }
8267
8268               goto unknown;
8269
8270             default:
8271               goto unknown;
8272           }
8273
8274         case 'd':
8275           if (name[1] == 'e' &&
8276               name[2] == 'l' &&
8277               name[3] == 'e' &&
8278               name[4] == 't' &&
8279               name[5] == 'e')
8280           {                                       /* delete     */
8281             return KEY_delete;
8282           }
8283
8284           goto unknown;
8285
8286         case 'e':
8287           switch (name[1])
8288           {
8289             case 'l':
8290               if (name[2] == 's' &&
8291                   name[3] == 'e' &&
8292                   name[4] == 'i' &&
8293                   name[5] == 'f')
8294               {                                   /* elseif     */
8295                 if(ckWARN_d(WARN_SYNTAX))
8296                   Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8297               }
8298
8299               goto unknown;
8300
8301             case 'x':
8302               if (name[2] == 'i' &&
8303                   name[3] == 's' &&
8304                   name[4] == 't' &&
8305                   name[5] == 's')
8306               {                                   /* exists     */
8307                 return KEY_exists;
8308               }
8309
8310               goto unknown;
8311
8312             default:
8313               goto unknown;
8314           }
8315
8316         case 'f':
8317           switch (name[1])
8318           {
8319             case 'i':
8320               if (name[2] == 'l' &&
8321                   name[3] == 'e' &&
8322                   name[4] == 'n' &&
8323                   name[5] == 'o')
8324               {                                   /* fileno     */
8325                 return -KEY_fileno;
8326               }
8327
8328               goto unknown;
8329
8330             case 'o':
8331               if (name[2] == 'r' &&
8332                   name[3] == 'm' &&
8333                   name[4] == 'a' &&
8334                   name[5] == 't')
8335               {                                   /* format     */
8336                 return KEY_format;
8337               }
8338
8339               goto unknown;
8340
8341             default:
8342               goto unknown;
8343           }
8344
8345         case 'g':
8346           if (name[1] == 'm' &&
8347               name[2] == 't' &&
8348               name[3] == 'i' &&
8349               name[4] == 'm' &&
8350               name[5] == 'e')
8351           {                                       /* gmtime     */
8352             return -KEY_gmtime;
8353           }
8354
8355           goto unknown;
8356
8357         case 'l':
8358           switch (name[1])
8359           {
8360             case 'e':
8361               if (name[2] == 'n' &&
8362                   name[3] == 'g' &&
8363                   name[4] == 't' &&
8364                   name[5] == 'h')
8365               {                                   /* length     */
8366                 return -KEY_length;
8367               }
8368
8369               goto unknown;
8370
8371             case 'i':
8372               if (name[2] == 's' &&
8373                   name[3] == 't' &&
8374                   name[4] == 'e' &&
8375                   name[5] == 'n')
8376               {                                   /* listen     */
8377                 return -KEY_listen;
8378               }
8379
8380               goto unknown;
8381
8382             default:
8383               goto unknown;
8384           }
8385
8386         case 'm':
8387           if (name[1] == 's' &&
8388               name[2] == 'g')
8389           {
8390             switch (name[3])
8391             {
8392               case 'c':
8393                 if (name[4] == 't' &&
8394                     name[5] == 'l')
8395                 {                                 /* msgctl     */
8396                   return -KEY_msgctl;
8397                 }
8398
8399                 goto unknown;
8400
8401               case 'g':
8402                 if (name[4] == 'e' &&
8403                     name[5] == 't')
8404                 {                                 /* msgget     */
8405                   return -KEY_msgget;
8406                 }
8407
8408                 goto unknown;
8409
8410               case 'r':
8411                 if (name[4] == 'c' &&
8412                     name[5] == 'v')
8413                 {                                 /* msgrcv     */
8414                   return -KEY_msgrcv;
8415                 }
8416
8417                 goto unknown;
8418
8419               case 's':
8420                 if (name[4] == 'n' &&
8421                     name[5] == 'd')
8422                 {                                 /* msgsnd     */
8423                   return -KEY_msgsnd;
8424                 }
8425
8426                 goto unknown;
8427
8428               default:
8429                 goto unknown;
8430             }
8431           }
8432
8433           goto unknown;
8434
8435         case 'p':
8436           if (name[1] == 'r' &&
8437               name[2] == 'i' &&
8438               name[3] == 'n' &&
8439               name[4] == 't' &&
8440               name[5] == 'f')
8441           {                                       /* printf     */
8442             return KEY_printf;
8443           }
8444
8445           goto unknown;
8446
8447         case 'r':
8448           switch (name[1])
8449           {
8450             case 'e':
8451               switch (name[2])
8452               {
8453                 case 'n':
8454                   if (name[3] == 'a' &&
8455                       name[4] == 'm' &&
8456                       name[5] == 'e')
8457                   {                               /* rename     */
8458                     return -KEY_rename;
8459                   }
8460
8461                   goto unknown;
8462
8463                 case 't':
8464                   if (name[3] == 'u' &&
8465                       name[4] == 'r' &&
8466                       name[5] == 'n')
8467                   {                               /* return     */
8468                     return KEY_return;
8469                   }
8470
8471                   goto unknown;
8472
8473                 default:
8474                   goto unknown;
8475               }
8476
8477             case 'i':
8478               if (name[2] == 'n' &&
8479                   name[3] == 'd' &&
8480                   name[4] == 'e' &&
8481                   name[5] == 'x')
8482               {                                   /* rindex     */
8483                 return -KEY_rindex;
8484               }
8485
8486               goto unknown;
8487
8488             default:
8489               goto unknown;
8490           }
8491
8492         case 's':
8493           switch (name[1])
8494           {
8495             case 'c':
8496               if (name[2] == 'a' &&
8497                   name[3] == 'l' &&
8498                   name[4] == 'a' &&
8499                   name[5] == 'r')
8500               {                                   /* scalar     */
8501                 return KEY_scalar;
8502               }
8503
8504               goto unknown;
8505
8506             case 'e':
8507               switch (name[2])
8508               {
8509                 case 'l':
8510                   if (name[3] == 'e' &&
8511                       name[4] == 'c' &&
8512                       name[5] == 't')
8513                   {                               /* select     */
8514                     return -KEY_select;
8515                   }
8516
8517                   goto unknown;
8518
8519                 case 'm':
8520                   switch (name[3])
8521                   {
8522                     case 'c':
8523                       if (name[4] == 't' &&
8524                           name[5] == 'l')
8525                       {                           /* semctl     */
8526                         return -KEY_semctl;
8527                       }
8528
8529                       goto unknown;
8530
8531                     case 'g':
8532                       if (name[4] == 'e' &&
8533                           name[5] == 't')
8534                       {                           /* semget     */
8535                         return -KEY_semget;
8536                       }
8537
8538                       goto unknown;
8539
8540                     default:
8541                       goto unknown;
8542                   }
8543
8544                 default:
8545                   goto unknown;
8546               }
8547
8548             case 'h':
8549               if (name[2] == 'm')
8550               {
8551                 switch (name[3])
8552                 {
8553                   case 'c':
8554                     if (name[4] == 't' &&
8555                         name[5] == 'l')
8556                     {                             /* shmctl     */
8557                       return -KEY_shmctl;
8558                     }
8559
8560                     goto unknown;
8561
8562                   case 'g':
8563                     if (name[4] == 'e' &&
8564                         name[5] == 't')
8565                     {                             /* shmget     */
8566                       return -KEY_shmget;
8567                     }
8568
8569                     goto unknown;
8570
8571                   default:
8572                     goto unknown;
8573                 }
8574               }
8575
8576               goto unknown;
8577
8578             case 'o':
8579               if (name[2] == 'c' &&
8580                   name[3] == 'k' &&
8581                   name[4] == 'e' &&
8582                   name[5] == 't')
8583               {                                   /* socket     */
8584                 return -KEY_socket;
8585               }
8586
8587               goto unknown;
8588
8589             case 'p':
8590               if (name[2] == 'l' &&
8591                   name[3] == 'i' &&
8592                   name[4] == 'c' &&
8593                   name[5] == 'e')
8594               {                                   /* splice     */
8595                 return -KEY_splice;
8596               }
8597
8598               goto unknown;
8599
8600             case 'u':
8601               if (name[2] == 'b' &&
8602                   name[3] == 's' &&
8603                   name[4] == 't' &&
8604                   name[5] == 'r')
8605               {                                   /* substr     */
8606                 return -KEY_substr;
8607               }
8608
8609               goto unknown;
8610
8611             case 'y':
8612               if (name[2] == 's' &&
8613                   name[3] == 't' &&
8614                   name[4] == 'e' &&
8615                   name[5] == 'm')
8616               {                                   /* system     */
8617                 return -KEY_system;
8618               }
8619
8620               goto unknown;
8621
8622             default:
8623               goto unknown;
8624           }
8625
8626         case 'u':
8627           if (name[1] == 'n')
8628           {
8629             switch (name[2])
8630             {
8631               case 'l':
8632                 switch (name[3])
8633                 {
8634                   case 'e':
8635                     if (name[4] == 's' &&
8636                         name[5] == 's')
8637                     {                             /* unless     */
8638                       return KEY_unless;
8639                     }
8640
8641                     goto unknown;
8642
8643                   case 'i':
8644                     if (name[4] == 'n' &&
8645                         name[5] == 'k')
8646                     {                             /* unlink     */
8647                       return -KEY_unlink;
8648                     }
8649
8650                     goto unknown;
8651
8652                   default:
8653                     goto unknown;
8654                 }
8655
8656               case 'p':
8657                 if (name[3] == 'a' &&
8658                     name[4] == 'c' &&
8659                     name[5] == 'k')
8660                 {                                 /* unpack     */
8661                   return -KEY_unpack;
8662                 }
8663
8664                 goto unknown;
8665
8666               default:
8667                 goto unknown;
8668             }
8669           }
8670
8671           goto unknown;
8672
8673         case 'v':
8674           if (name[1] == 'a' &&
8675               name[2] == 'l' &&
8676               name[3] == 'u' &&
8677               name[4] == 'e' &&
8678               name[5] == 's')
8679           {                                       /* values     */
8680             return -KEY_values;
8681           }
8682
8683           goto unknown;
8684
8685         default:
8686           goto unknown;
8687       }
8688
8689     case 7: /* 29 tokens of length 7 */
8690       switch (name[0])
8691       {
8692         case 'D':
8693           if (name[1] == 'E' &&
8694               name[2] == 'S' &&
8695               name[3] == 'T' &&
8696               name[4] == 'R' &&
8697               name[5] == 'O' &&
8698               name[6] == 'Y')
8699           {                                       /* DESTROY    */
8700             return KEY_DESTROY;
8701           }
8702
8703           goto unknown;
8704
8705         case '_':
8706           if (name[1] == '_' &&
8707               name[2] == 'E' &&
8708               name[3] == 'N' &&
8709               name[4] == 'D' &&
8710               name[5] == '_' &&
8711               name[6] == '_')
8712           {                                       /* __END__    */
8713             return KEY___END__;
8714           }
8715
8716           goto unknown;
8717
8718         case 'b':
8719           if (name[1] == 'i' &&
8720               name[2] == 'n' &&
8721               name[3] == 'm' &&
8722               name[4] == 'o' &&
8723               name[5] == 'd' &&
8724               name[6] == 'e')
8725           {                                       /* binmode    */
8726             return -KEY_binmode;
8727           }
8728
8729           goto unknown;
8730
8731         case 'c':
8732           if (name[1] == 'o' &&
8733               name[2] == 'n' &&
8734               name[3] == 'n' &&
8735               name[4] == 'e' &&
8736               name[5] == 'c' &&
8737               name[6] == 't')
8738           {                                       /* connect    */
8739             return -KEY_connect;
8740           }
8741
8742           goto unknown;
8743
8744         case 'd':
8745           switch (name[1])
8746           {
8747             case 'b':
8748               if (name[2] == 'm' &&
8749                   name[3] == 'o' &&
8750                   name[4] == 'p' &&
8751                   name[5] == 'e' &&
8752                   name[6] == 'n')
8753               {                                   /* dbmopen    */
8754                 return -KEY_dbmopen;
8755               }
8756
8757               goto unknown;
8758
8759             case 'e':
8760               if (name[2] == 'f')
8761               {
8762                 switch (name[3])
8763                 {
8764                   case 'a':
8765                     if (name[4] == 'u' &&
8766                         name[5] == 'l' &&
8767                         name[6] == 't')
8768                     {                             /* default    */
8769                       return (FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
8770                     }
8771
8772                     goto unknown;
8773
8774                   case 'i':
8775                     if (name[4] == 'n' &&
8776                   name[5] == 'e' &&
8777                   name[6] == 'd')
8778               {                                   /* defined    */
8779                 return KEY_defined;
8780               }
8781
8782               goto unknown;
8783
8784             default:
8785               goto unknown;
8786           }
8787               }
8788
8789               goto unknown;
8790
8791             default:
8792               goto unknown;
8793           }
8794
8795         case 'f':
8796           if (name[1] == 'o' &&
8797               name[2] == 'r' &&
8798               name[3] == 'e' &&
8799               name[4] == 'a' &&
8800               name[5] == 'c' &&
8801               name[6] == 'h')
8802           {                                       /* foreach    */
8803             return KEY_foreach;
8804           }
8805
8806           goto unknown;
8807
8808         case 'g':
8809           if (name[1] == 'e' &&
8810               name[2] == 't' &&
8811               name[3] == 'p')
8812           {
8813             switch (name[4])
8814             {
8815               case 'g':
8816                 if (name[5] == 'r' &&
8817                     name[6] == 'p')
8818                 {                                 /* getpgrp    */
8819                   return -KEY_getpgrp;
8820                 }
8821
8822                 goto unknown;
8823
8824               case 'p':
8825                 if (name[5] == 'i' &&
8826                     name[6] == 'd')
8827                 {                                 /* getppid    */
8828                   return -KEY_getppid;
8829                 }
8830
8831                 goto unknown;
8832
8833               default:
8834                 goto unknown;
8835             }
8836           }
8837
8838           goto unknown;
8839
8840         case 'l':
8841           if (name[1] == 'c' &&
8842               name[2] == 'f' &&
8843               name[3] == 'i' &&
8844               name[4] == 'r' &&
8845               name[5] == 's' &&
8846               name[6] == 't')
8847           {                                       /* lcfirst    */
8848             return -KEY_lcfirst;
8849           }
8850
8851           goto unknown;
8852
8853         case 'o':
8854           if (name[1] == 'p' &&
8855               name[2] == 'e' &&
8856               name[3] == 'n' &&
8857               name[4] == 'd' &&
8858               name[5] == 'i' &&
8859               name[6] == 'r')
8860           {                                       /* opendir    */
8861             return -KEY_opendir;
8862           }
8863
8864           goto unknown;
8865
8866         case 'p':
8867           if (name[1] == 'a' &&
8868               name[2] == 'c' &&
8869               name[3] == 'k' &&
8870               name[4] == 'a' &&
8871               name[5] == 'g' &&
8872               name[6] == 'e')
8873           {                                       /* package    */
8874             return KEY_package;
8875           }
8876
8877           goto unknown;
8878
8879         case 'r':
8880           if (name[1] == 'e')
8881           {
8882             switch (name[2])
8883             {
8884               case 'a':
8885                 if (name[3] == 'd' &&
8886                     name[4] == 'd' &&
8887                     name[5] == 'i' &&
8888                     name[6] == 'r')
8889                 {                                 /* readdir    */
8890                   return -KEY_readdir;
8891                 }
8892
8893                 goto unknown;
8894
8895               case 'q':
8896                 if (name[3] == 'u' &&
8897                     name[4] == 'i' &&
8898                     name[5] == 'r' &&
8899                     name[6] == 'e')
8900                 {                                 /* require    */
8901                   return KEY_require;
8902                 }
8903
8904                 goto unknown;
8905
8906               case 'v':
8907                 if (name[3] == 'e' &&
8908                     name[4] == 'r' &&
8909                     name[5] == 's' &&
8910                     name[6] == 'e')
8911                 {                                 /* reverse    */
8912                   return -KEY_reverse;
8913                 }
8914
8915                 goto unknown;
8916
8917               default:
8918                 goto unknown;
8919             }
8920           }
8921
8922           goto unknown;
8923
8924         case 's':
8925           switch (name[1])
8926           {
8927             case 'e':
8928               switch (name[2])
8929               {
8930                 case 'e':
8931                   if (name[3] == 'k' &&
8932                       name[4] == 'd' &&
8933                       name[5] == 'i' &&
8934                       name[6] == 'r')
8935                   {                               /* seekdir    */
8936                     return -KEY_seekdir;
8937                   }
8938
8939                   goto unknown;
8940
8941                 case 't':
8942                   if (name[3] == 'p' &&
8943                       name[4] == 'g' &&
8944                       name[5] == 'r' &&
8945                       name[6] == 'p')
8946                   {                               /* setpgrp    */
8947                     return -KEY_setpgrp;
8948                   }
8949
8950                   goto unknown;
8951
8952                 default:
8953                   goto unknown;
8954               }
8955
8956             case 'h':
8957               if (name[2] == 'm' &&
8958                   name[3] == 'r' &&
8959                   name[4] == 'e' &&
8960                   name[5] == 'a' &&
8961                   name[6] == 'd')
8962               {                                   /* shmread    */
8963                 return -KEY_shmread;
8964               }
8965
8966               goto unknown;
8967
8968             case 'p':
8969               if (name[2] == 'r' &&
8970                   name[3] == 'i' &&
8971                   name[4] == 'n' &&
8972                   name[5] == 't' &&
8973                   name[6] == 'f')
8974               {                                   /* sprintf    */
8975                 return -KEY_sprintf;
8976               }
8977
8978               goto unknown;
8979
8980             case 'y':
8981               switch (name[2])
8982               {
8983                 case 'm':
8984                   if (name[3] == 'l' &&
8985                       name[4] == 'i' &&
8986                       name[5] == 'n' &&
8987                       name[6] == 'k')
8988                   {                               /* symlink    */
8989                     return -KEY_symlink;
8990                   }
8991
8992                   goto unknown;
8993
8994                 case 's':
8995                   switch (name[3])
8996                   {
8997                     case 'c':
8998                       if (name[4] == 'a' &&
8999                           name[5] == 'l' &&
9000                           name[6] == 'l')
9001                       {                           /* syscall    */
9002                         return -KEY_syscall;
9003                       }
9004
9005                       goto unknown;
9006
9007                     case 'o':
9008                       if (name[4] == 'p' &&
9009                           name[5] == 'e' &&
9010                           name[6] == 'n')
9011                       {                           /* sysopen    */
9012                         return -KEY_sysopen;
9013                       }
9014
9015                       goto unknown;
9016
9017                     case 'r':
9018                       if (name[4] == 'e' &&
9019                           name[5] == 'a' &&
9020                           name[6] == 'd')
9021                       {                           /* sysread    */
9022                         return -KEY_sysread;
9023                       }
9024
9025                       goto unknown;
9026
9027                     case 's':
9028                       if (name[4] == 'e' &&
9029                           name[5] == 'e' &&
9030                           name[6] == 'k')
9031                       {                           /* sysseek    */
9032                         return -KEY_sysseek;
9033                       }
9034
9035                       goto unknown;
9036
9037                     default:
9038                       goto unknown;
9039                   }
9040
9041                 default:
9042                   goto unknown;
9043               }
9044
9045             default:
9046               goto unknown;
9047           }
9048
9049         case 't':
9050           if (name[1] == 'e' &&
9051               name[2] == 'l' &&
9052               name[3] == 'l' &&
9053               name[4] == 'd' &&
9054               name[5] == 'i' &&
9055               name[6] == 'r')
9056           {                                       /* telldir    */
9057             return -KEY_telldir;
9058           }
9059
9060           goto unknown;
9061
9062         case 'u':
9063           switch (name[1])
9064           {
9065             case 'c':
9066               if (name[2] == 'f' &&
9067                   name[3] == 'i' &&
9068                   name[4] == 'r' &&
9069                   name[5] == 's' &&
9070                   name[6] == 't')
9071               {                                   /* ucfirst    */
9072                 return -KEY_ucfirst;
9073               }
9074
9075               goto unknown;
9076
9077             case 'n':
9078               if (name[2] == 's' &&
9079                   name[3] == 'h' &&
9080                   name[4] == 'i' &&
9081                   name[5] == 'f' &&
9082                   name[6] == 't')
9083               {                                   /* unshift    */
9084                 return -KEY_unshift;
9085               }
9086
9087               goto unknown;
9088
9089             default:
9090               goto unknown;
9091           }
9092
9093         case 'w':
9094           if (name[1] == 'a' &&
9095               name[2] == 'i' &&
9096               name[3] == 't' &&
9097               name[4] == 'p' &&
9098               name[5] == 'i' &&
9099               name[6] == 'd')
9100           {                                       /* waitpid    */
9101             return -KEY_waitpid;
9102           }
9103
9104           goto unknown;
9105
9106         default:
9107           goto unknown;
9108       }
9109
9110     case 8: /* 26 tokens of length 8 */
9111       switch (name[0])
9112       {
9113         case 'A':
9114           if (name[1] == 'U' &&
9115               name[2] == 'T' &&
9116               name[3] == 'O' &&
9117               name[4] == 'L' &&
9118               name[5] == 'O' &&
9119               name[6] == 'A' &&
9120               name[7] == 'D')
9121           {                                       /* AUTOLOAD   */
9122             return KEY_AUTOLOAD;
9123           }
9124
9125           goto unknown;
9126
9127         case '_':
9128           if (name[1] == '_')
9129           {
9130             switch (name[2])
9131             {
9132               case 'D':
9133                 if (name[3] == 'A' &&
9134                     name[4] == 'T' &&
9135                     name[5] == 'A' &&
9136                     name[6] == '_' &&
9137                     name[7] == '_')
9138                 {                                 /* __DATA__   */
9139                   return KEY___DATA__;
9140                 }
9141
9142                 goto unknown;
9143
9144               case 'F':
9145                 if (name[3] == 'I' &&
9146                     name[4] == 'L' &&
9147                     name[5] == 'E' &&
9148                     name[6] == '_' &&
9149                     name[7] == '_')
9150                 {                                 /* __FILE__   */
9151                   return -KEY___FILE__;
9152                 }
9153
9154                 goto unknown;
9155
9156               case 'L':
9157                 if (name[3] == 'I' &&
9158                     name[4] == 'N' &&
9159                     name[5] == 'E' &&
9160                     name[6] == '_' &&
9161                     name[7] == '_')
9162                 {                                 /* __LINE__   */
9163                   return -KEY___LINE__;
9164                 }
9165
9166                 goto unknown;
9167
9168               default:
9169                 goto unknown;
9170             }
9171           }
9172
9173           goto unknown;
9174
9175         case 'c':
9176           switch (name[1])
9177           {
9178             case 'l':
9179               if (name[2] == 'o' &&
9180                   name[3] == 's' &&
9181                   name[4] == 'e' &&
9182                   name[5] == 'd' &&
9183                   name[6] == 'i' &&
9184                   name[7] == 'r')
9185               {                                   /* closedir   */
9186                 return -KEY_closedir;
9187               }
9188
9189               goto unknown;
9190
9191             case 'o':
9192               if (name[2] == 'n' &&
9193                   name[3] == 't' &&
9194                   name[4] == 'i' &&
9195                   name[5] == 'n' &&
9196                   name[6] == 'u' &&
9197                   name[7] == 'e')
9198               {                                   /* continue   */
9199                 return -KEY_continue;
9200               }
9201
9202               goto unknown;
9203
9204             default:
9205               goto unknown;
9206           }
9207
9208         case 'd':
9209           if (name[1] == 'b' &&
9210               name[2] == 'm' &&
9211               name[3] == 'c' &&
9212               name[4] == 'l' &&
9213               name[5] == 'o' &&
9214               name[6] == 's' &&
9215               name[7] == 'e')
9216           {                                       /* dbmclose   */
9217             return -KEY_dbmclose;
9218           }
9219
9220           goto unknown;
9221
9222         case 'e':
9223           if (name[1] == 'n' &&
9224               name[2] == 'd')
9225           {
9226             switch (name[3])
9227             {
9228               case 'g':
9229                 if (name[4] == 'r' &&
9230                     name[5] == 'e' &&
9231                     name[6] == 'n' &&
9232                     name[7] == 't')
9233                 {                                 /* endgrent   */
9234                   return -KEY_endgrent;
9235                 }
9236
9237                 goto unknown;
9238
9239               case 'p':
9240                 if (name[4] == 'w' &&
9241                     name[5] == 'e' &&
9242                     name[6] == 'n' &&
9243                     name[7] == 't')
9244                 {                                 /* endpwent   */
9245                   return -KEY_endpwent;
9246                 }
9247
9248                 goto unknown;
9249
9250               default:
9251                 goto unknown;
9252             }
9253           }
9254
9255           goto unknown;
9256
9257         case 'f':
9258           if (name[1] == 'o' &&
9259               name[2] == 'r' &&
9260               name[3] == 'm' &&
9261               name[4] == 'l' &&
9262               name[5] == 'i' &&
9263               name[6] == 'n' &&
9264               name[7] == 'e')
9265           {                                       /* formline   */
9266             return -KEY_formline;
9267           }
9268
9269           goto unknown;
9270
9271         case 'g':
9272           if (name[1] == 'e' &&
9273               name[2] == 't')
9274           {
9275             switch (name[3])
9276             {
9277               case 'g':
9278                 if (name[4] == 'r')
9279                 {
9280                   switch (name[5])
9281                   {
9282                     case 'e':
9283                       if (name[6] == 'n' &&
9284                           name[7] == 't')
9285                       {                           /* getgrent   */
9286                         return -KEY_getgrent;
9287                       }
9288
9289                       goto unknown;
9290
9291                     case 'g':
9292                       if (name[6] == 'i' &&
9293                           name[7] == 'd')
9294                       {                           /* getgrgid   */
9295                         return -KEY_getgrgid;
9296                       }
9297
9298                       goto unknown;
9299
9300                     case 'n':
9301                       if (name[6] == 'a' &&
9302                           name[7] == 'm')
9303                       {                           /* getgrnam   */
9304                         return -KEY_getgrnam;
9305                       }
9306
9307                       goto unknown;
9308
9309                     default:
9310                       goto unknown;
9311                   }
9312                 }
9313
9314                 goto unknown;
9315
9316               case 'l':
9317                 if (name[4] == 'o' &&
9318                     name[5] == 'g' &&
9319                     name[6] == 'i' &&
9320                     name[7] == 'n')
9321                 {                                 /* getlogin   */
9322                   return -KEY_getlogin;
9323                 }
9324
9325                 goto unknown;
9326
9327               case 'p':
9328                 if (name[4] == 'w')
9329                 {
9330                   switch (name[5])
9331                   {
9332                     case 'e':
9333                       if (name[6] == 'n' &&
9334                           name[7] == 't')
9335                       {                           /* getpwent   */
9336                         return -KEY_getpwent;
9337                       }
9338
9339                       goto unknown;
9340
9341                     case 'n':
9342                       if (name[6] == 'a' &&
9343                           name[7] == 'm')
9344                       {                           /* getpwnam   */
9345                         return -KEY_getpwnam;
9346                       }
9347
9348                       goto unknown;
9349
9350                     case 'u':
9351                       if (name[6] == 'i' &&
9352                           name[7] == 'd')
9353                       {                           /* getpwuid   */
9354                         return -KEY_getpwuid;
9355                       }
9356
9357                       goto unknown;
9358
9359                     default:
9360                       goto unknown;
9361                   }
9362                 }
9363
9364                 goto unknown;
9365
9366               default:
9367                 goto unknown;
9368             }
9369           }
9370
9371           goto unknown;
9372
9373         case 'r':
9374           if (name[1] == 'e' &&
9375               name[2] == 'a' &&
9376               name[3] == 'd')
9377           {
9378             switch (name[4])
9379             {
9380               case 'l':
9381                 if (name[5] == 'i' &&
9382                     name[6] == 'n')
9383                 {
9384                   switch (name[7])
9385                   {
9386                     case 'e':
9387                       {                           /* readline   */
9388                         return -KEY_readline;
9389                       }
9390
9391                     case 'k':
9392                       {                           /* readlink   */
9393                         return -KEY_readlink;
9394                       }
9395
9396                     default:
9397                       goto unknown;
9398                   }
9399                 }
9400
9401                 goto unknown;
9402
9403               case 'p':
9404                 if (name[5] == 'i' &&
9405                     name[6] == 'p' &&
9406                     name[7] == 'e')
9407                 {                                 /* readpipe   */
9408                   return -KEY_readpipe;
9409                 }
9410
9411                 goto unknown;
9412
9413               default:
9414                 goto unknown;
9415             }
9416           }
9417
9418           goto unknown;
9419
9420         case 's':
9421           switch (name[1])
9422           {
9423             case 'e':
9424               if (name[2] == 't')
9425               {
9426                 switch (name[3])
9427                 {
9428                   case 'g':
9429                     if (name[4] == 'r' &&
9430                         name[5] == 'e' &&
9431                         name[6] == 'n' &&
9432                         name[7] == 't')
9433                     {                             /* setgrent   */
9434                       return -KEY_setgrent;
9435                     }
9436
9437                     goto unknown;
9438
9439                   case 'p':
9440                     if (name[4] == 'w' &&
9441                         name[5] == 'e' &&
9442                         name[6] == 'n' &&
9443                         name[7] == 't')
9444                     {                             /* setpwent   */
9445                       return -KEY_setpwent;
9446                     }
9447
9448                     goto unknown;
9449
9450                   default:
9451                     goto unknown;
9452                 }
9453               }
9454
9455               goto unknown;
9456
9457             case 'h':
9458               switch (name[2])
9459               {
9460                 case 'm':
9461                   if (name[3] == 'w' &&
9462                       name[4] == 'r' &&
9463                       name[5] == 'i' &&
9464                       name[6] == 't' &&
9465                       name[7] == 'e')
9466                   {                               /* shmwrite   */
9467                     return -KEY_shmwrite;
9468                   }
9469
9470                   goto unknown;
9471
9472                 case 'u':
9473                   if (name[3] == 't' &&
9474                       name[4] == 'd' &&
9475                       name[5] == 'o' &&
9476                       name[6] == 'w' &&
9477                       name[7] == 'n')
9478                   {                               /* shutdown   */
9479                     return -KEY_shutdown;
9480                   }
9481
9482                   goto unknown;
9483
9484                 default:
9485                   goto unknown;
9486               }
9487
9488             case 'y':
9489               if (name[2] == 's' &&
9490                   name[3] == 'w' &&
9491                   name[4] == 'r' &&
9492                   name[5] == 'i' &&
9493                   name[6] == 't' &&
9494                   name[7] == 'e')
9495               {                                   /* syswrite   */
9496                 return -KEY_syswrite;
9497               }
9498
9499               goto unknown;
9500
9501             default:
9502               goto unknown;
9503           }
9504
9505         case 't':
9506           if (name[1] == 'r' &&
9507               name[2] == 'u' &&
9508               name[3] == 'n' &&
9509               name[4] == 'c' &&
9510               name[5] == 'a' &&
9511               name[6] == 't' &&
9512               name[7] == 'e')
9513           {                                       /* truncate   */
9514             return -KEY_truncate;
9515           }
9516
9517           goto unknown;
9518
9519         default:
9520           goto unknown;
9521       }
9522
9523     case 9: /* 8 tokens of length 9 */
9524       switch (name[0])
9525       {
9526         case 'e':
9527           if (name[1] == 'n' &&
9528               name[2] == 'd' &&
9529               name[3] == 'n' &&
9530               name[4] == 'e' &&
9531               name[5] == 't' &&
9532               name[6] == 'e' &&
9533               name[7] == 'n' &&
9534               name[8] == 't')
9535           {                                       /* endnetent  */
9536             return -KEY_endnetent;
9537           }
9538
9539           goto unknown;
9540
9541         case 'g':
9542           if (name[1] == 'e' &&
9543               name[2] == 't' &&
9544               name[3] == 'n' &&
9545               name[4] == 'e' &&
9546               name[5] == 't' &&
9547               name[6] == 'e' &&
9548               name[7] == 'n' &&
9549               name[8] == 't')
9550           {                                       /* getnetent  */
9551             return -KEY_getnetent;
9552           }
9553
9554           goto unknown;
9555
9556         case 'l':
9557           if (name[1] == 'o' &&
9558               name[2] == 'c' &&
9559               name[3] == 'a' &&
9560               name[4] == 'l' &&
9561               name[5] == 't' &&
9562               name[6] == 'i' &&
9563               name[7] == 'm' &&
9564               name[8] == 'e')
9565           {                                       /* localtime  */
9566             return -KEY_localtime;
9567           }
9568
9569           goto unknown;
9570
9571         case 'p':
9572           if (name[1] == 'r' &&
9573               name[2] == 'o' &&
9574               name[3] == 't' &&
9575               name[4] == 'o' &&
9576               name[5] == 't' &&
9577               name[6] == 'y' &&
9578               name[7] == 'p' &&
9579               name[8] == 'e')
9580           {                                       /* prototype  */
9581             return KEY_prototype;
9582           }
9583
9584           goto unknown;
9585
9586         case 'q':
9587           if (name[1] == 'u' &&
9588               name[2] == 'o' &&
9589               name[3] == 't' &&
9590               name[4] == 'e' &&
9591               name[5] == 'm' &&
9592               name[6] == 'e' &&
9593               name[7] == 't' &&
9594               name[8] == 'a')
9595           {                                       /* quotemeta  */
9596             return -KEY_quotemeta;
9597           }
9598
9599           goto unknown;
9600
9601         case 'r':
9602           if (name[1] == 'e' &&
9603               name[2] == 'w' &&
9604               name[3] == 'i' &&
9605               name[4] == 'n' &&
9606               name[5] == 'd' &&
9607               name[6] == 'd' &&
9608               name[7] == 'i' &&
9609               name[8] == 'r')
9610           {                                       /* rewinddir  */
9611             return -KEY_rewinddir;
9612           }
9613
9614           goto unknown;
9615
9616         case 's':
9617           if (name[1] == 'e' &&
9618               name[2] == 't' &&
9619               name[3] == 'n' &&
9620               name[4] == 'e' &&
9621               name[5] == 't' &&
9622               name[6] == 'e' &&
9623               name[7] == 'n' &&
9624               name[8] == 't')
9625           {                                       /* setnetent  */
9626             return -KEY_setnetent;
9627           }
9628
9629           goto unknown;
9630
9631         case 'w':
9632           if (name[1] == 'a' &&
9633               name[2] == 'n' &&
9634               name[3] == 't' &&
9635               name[4] == 'a' &&
9636               name[5] == 'r' &&
9637               name[6] == 'r' &&
9638               name[7] == 'a' &&
9639               name[8] == 'y')
9640           {                                       /* wantarray  */
9641             return -KEY_wantarray;
9642           }
9643
9644           goto unknown;
9645
9646         default:
9647           goto unknown;
9648       }
9649
9650     case 10: /* 9 tokens of length 10 */
9651       switch (name[0])
9652       {
9653         case 'e':
9654           if (name[1] == 'n' &&
9655               name[2] == 'd')
9656           {
9657             switch (name[3])
9658             {
9659               case 'h':
9660                 if (name[4] == 'o' &&
9661                     name[5] == 's' &&
9662                     name[6] == 't' &&
9663                     name[7] == 'e' &&
9664                     name[8] == 'n' &&
9665                     name[9] == 't')
9666                 {                                 /* endhostent */
9667                   return -KEY_endhostent;
9668                 }
9669
9670                 goto unknown;
9671
9672               case 's':
9673                 if (name[4] == 'e' &&
9674                     name[5] == 'r' &&
9675                     name[6] == 'v' &&
9676                     name[7] == 'e' &&
9677                     name[8] == 'n' &&
9678                     name[9] == 't')
9679                 {                                 /* endservent */
9680                   return -KEY_endservent;
9681                 }
9682
9683                 goto unknown;
9684
9685               default:
9686                 goto unknown;
9687             }
9688           }
9689
9690           goto unknown;
9691
9692         case 'g':
9693           if (name[1] == 'e' &&
9694               name[2] == 't')
9695           {
9696             switch (name[3])
9697             {
9698               case 'h':
9699                 if (name[4] == 'o' &&
9700                     name[5] == 's' &&
9701                     name[6] == 't' &&
9702                     name[7] == 'e' &&
9703                     name[8] == 'n' &&
9704                     name[9] == 't')
9705                 {                                 /* gethostent */
9706                   return -KEY_gethostent;
9707                 }
9708
9709                 goto unknown;
9710
9711               case 's':
9712                 switch (name[4])
9713                 {
9714                   case 'e':
9715                     if (name[5] == 'r' &&
9716                         name[6] == 'v' &&
9717                         name[7] == 'e' &&
9718                         name[8] == 'n' &&
9719                         name[9] == 't')
9720                     {                             /* getservent */
9721                       return -KEY_getservent;
9722                     }
9723
9724                     goto unknown;
9725
9726                   case 'o':
9727                     if (name[5] == 'c' &&
9728                         name[6] == 'k' &&
9729                         name[7] == 'o' &&
9730                         name[8] == 'p' &&
9731                         name[9] == 't')
9732                     {                             /* getsockopt */
9733                       return -KEY_getsockopt;
9734                     }
9735
9736                     goto unknown;
9737
9738                   default:
9739                     goto unknown;
9740                 }
9741
9742               default:
9743                 goto unknown;
9744             }
9745           }
9746
9747           goto unknown;
9748
9749         case 's':
9750           switch (name[1])
9751           {
9752             case 'e':
9753               if (name[2] == 't')
9754               {
9755                 switch (name[3])
9756                 {
9757                   case 'h':
9758                     if (name[4] == 'o' &&
9759                         name[5] == 's' &&
9760                         name[6] == 't' &&
9761                         name[7] == 'e' &&
9762                         name[8] == 'n' &&
9763                         name[9] == 't')
9764                     {                             /* sethostent */
9765                       return -KEY_sethostent;
9766                     }
9767
9768                     goto unknown;
9769
9770                   case 's':
9771                     switch (name[4])
9772                     {
9773                       case 'e':
9774                         if (name[5] == 'r' &&
9775                             name[6] == 'v' &&
9776                             name[7] == 'e' &&
9777                             name[8] == 'n' &&
9778                             name[9] == 't')
9779                         {                         /* setservent */
9780                           return -KEY_setservent;
9781                         }
9782
9783                         goto unknown;
9784
9785                       case 'o':
9786                         if (name[5] == 'c' &&
9787                             name[6] == 'k' &&
9788                             name[7] == 'o' &&
9789                             name[8] == 'p' &&
9790                             name[9] == 't')
9791                         {                         /* setsockopt */
9792                           return -KEY_setsockopt;
9793                         }
9794
9795                         goto unknown;
9796
9797                       default:
9798                         goto unknown;
9799                     }
9800
9801                   default:
9802                     goto unknown;
9803                 }
9804               }
9805
9806               goto unknown;
9807
9808             case 'o':
9809               if (name[2] == 'c' &&
9810                   name[3] == 'k' &&
9811                   name[4] == 'e' &&
9812                   name[5] == 't' &&
9813                   name[6] == 'p' &&
9814                   name[7] == 'a' &&
9815                   name[8] == 'i' &&
9816                   name[9] == 'r')
9817               {                                   /* socketpair */
9818                 return -KEY_socketpair;
9819               }
9820
9821               goto unknown;
9822
9823             default:
9824               goto unknown;
9825           }
9826
9827         default:
9828           goto unknown;
9829       }
9830
9831     case 11: /* 8 tokens of length 11 */
9832       switch (name[0])
9833       {
9834         case '_':
9835           if (name[1] == '_' &&
9836               name[2] == 'P' &&
9837               name[3] == 'A' &&
9838               name[4] == 'C' &&
9839               name[5] == 'K' &&
9840               name[6] == 'A' &&
9841               name[7] == 'G' &&
9842               name[8] == 'E' &&
9843               name[9] == '_' &&
9844               name[10] == '_')
9845           {                                       /* __PACKAGE__ */
9846             return -KEY___PACKAGE__;
9847           }
9848
9849           goto unknown;
9850
9851         case 'e':
9852           if (name[1] == 'n' &&
9853               name[2] == 'd' &&
9854               name[3] == 'p' &&
9855               name[4] == 'r' &&
9856               name[5] == 'o' &&
9857               name[6] == 't' &&
9858               name[7] == 'o' &&
9859               name[8] == 'e' &&
9860               name[9] == 'n' &&
9861               name[10] == 't')
9862           {                                       /* endprotoent */
9863             return -KEY_endprotoent;
9864           }
9865
9866           goto unknown;
9867
9868         case 'g':
9869           if (name[1] == 'e' &&
9870               name[2] == 't')
9871           {
9872             switch (name[3])
9873             {
9874               case 'p':
9875                 switch (name[4])
9876                 {
9877                   case 'e':
9878                     if (name[5] == 'e' &&
9879                         name[6] == 'r' &&
9880                         name[7] == 'n' &&
9881                         name[8] == 'a' &&
9882                         name[9] == 'm' &&
9883                         name[10] == 'e')
9884                     {                             /* getpeername */
9885                       return -KEY_getpeername;
9886                     }
9887
9888                     goto unknown;
9889
9890                   case 'r':
9891                     switch (name[5])
9892                     {
9893                       case 'i':
9894                         if (name[6] == 'o' &&
9895                             name[7] == 'r' &&
9896                             name[8] == 'i' &&
9897                             name[9] == 't' &&
9898                             name[10] == 'y')
9899                         {                         /* getpriority */
9900                           return -KEY_getpriority;
9901                         }
9902
9903                         goto unknown;
9904
9905                       case 'o':
9906                         if (name[6] == 't' &&
9907                             name[7] == 'o' &&
9908                             name[8] == 'e' &&
9909                             name[9] == 'n' &&
9910                             name[10] == 't')
9911                         {                         /* getprotoent */
9912                           return -KEY_getprotoent;
9913                         }
9914
9915                         goto unknown;
9916
9917                       default:
9918                         goto unknown;
9919                     }
9920
9921                   default:
9922                     goto unknown;
9923                 }
9924
9925               case 's':
9926                 if (name[4] == 'o' &&
9927                     name[5] == 'c' &&
9928                     name[6] == 'k' &&
9929                     name[7] == 'n' &&
9930                     name[8] == 'a' &&
9931                     name[9] == 'm' &&
9932                     name[10] == 'e')
9933                 {                                 /* getsockname */
9934                   return -KEY_getsockname;
9935                 }
9936
9937                 goto unknown;
9938
9939               default:
9940                 goto unknown;
9941             }
9942           }
9943
9944           goto unknown;
9945
9946         case 's':
9947           if (name[1] == 'e' &&
9948               name[2] == 't' &&
9949               name[3] == 'p' &&
9950               name[4] == 'r')
9951           {
9952             switch (name[5])
9953             {
9954               case 'i':
9955                 if (name[6] == 'o' &&
9956                     name[7] == 'r' &&
9957                     name[8] == 'i' &&
9958                     name[9] == 't' &&
9959                     name[10] == 'y')
9960                 {                                 /* setpriority */
9961                   return -KEY_setpriority;
9962                 }
9963
9964                 goto unknown;
9965
9966               case 'o':
9967                 if (name[6] == 't' &&
9968                     name[7] == 'o' &&
9969                     name[8] == 'e' &&
9970                     name[9] == 'n' &&
9971                     name[10] == 't')
9972                 {                                 /* setprotoent */
9973                   return -KEY_setprotoent;
9974                 }
9975
9976                 goto unknown;
9977
9978               default:
9979                 goto unknown;
9980             }
9981           }
9982
9983           goto unknown;
9984
9985         default:
9986           goto unknown;
9987       }
9988
9989     case 12: /* 2 tokens of length 12 */
9990       if (name[0] == 'g' &&
9991           name[1] == 'e' &&
9992           name[2] == 't' &&
9993           name[3] == 'n' &&
9994           name[4] == 'e' &&
9995           name[5] == 't' &&
9996           name[6] == 'b' &&
9997           name[7] == 'y')
9998       {
9999         switch (name[8])
10000         {
10001           case 'a':
10002             if (name[9] == 'd' &&
10003                 name[10] == 'd' &&
10004                 name[11] == 'r')
10005             {                                     /* getnetbyaddr */
10006               return -KEY_getnetbyaddr;
10007             }
10008
10009             goto unknown;
10010
10011           case 'n':
10012             if (name[9] == 'a' &&
10013                 name[10] == 'm' &&
10014                 name[11] == 'e')
10015             {                                     /* getnetbyname */
10016               return -KEY_getnetbyname;
10017             }
10018
10019             goto unknown;
10020
10021           default:
10022             goto unknown;
10023         }
10024       }
10025
10026       goto unknown;
10027
10028     case 13: /* 4 tokens of length 13 */
10029       if (name[0] == 'g' &&
10030           name[1] == 'e' &&
10031           name[2] == 't')
10032       {
10033         switch (name[3])
10034         {
10035           case 'h':
10036             if (name[4] == 'o' &&
10037                 name[5] == 's' &&
10038                 name[6] == 't' &&
10039                 name[7] == 'b' &&
10040                 name[8] == 'y')
10041             {
10042               switch (name[9])
10043               {
10044                 case 'a':
10045                   if (name[10] == 'd' &&
10046                       name[11] == 'd' &&
10047                       name[12] == 'r')
10048                   {                               /* gethostbyaddr */
10049                     return -KEY_gethostbyaddr;
10050                   }
10051
10052                   goto unknown;
10053
10054                 case 'n':
10055                   if (name[10] == 'a' &&
10056                       name[11] == 'm' &&
10057                       name[12] == 'e')
10058                   {                               /* gethostbyname */
10059                     return -KEY_gethostbyname;
10060                   }
10061
10062                   goto unknown;
10063
10064                 default:
10065                   goto unknown;
10066               }
10067             }
10068
10069             goto unknown;
10070
10071           case 's':
10072             if (name[4] == 'e' &&
10073                 name[5] == 'r' &&
10074                 name[6] == 'v' &&
10075                 name[7] == 'b' &&
10076                 name[8] == 'y')
10077             {
10078               switch (name[9])
10079               {
10080                 case 'n':
10081                   if (name[10] == 'a' &&
10082                       name[11] == 'm' &&
10083                       name[12] == 'e')
10084                   {                               /* getservbyname */
10085                     return -KEY_getservbyname;
10086                   }
10087
10088                   goto unknown;
10089
10090                 case 'p':
10091                   if (name[10] == 'o' &&
10092                       name[11] == 'r' &&
10093                       name[12] == 't')
10094                   {                               /* getservbyport */
10095                     return -KEY_getservbyport;
10096                   }
10097
10098                   goto unknown;
10099
10100                 default:
10101                   goto unknown;
10102               }
10103             }
10104
10105             goto unknown;
10106
10107           default:
10108             goto unknown;
10109         }
10110       }
10111
10112       goto unknown;
10113
10114     case 14: /* 1 tokens of length 14 */
10115       if (name[0] == 'g' &&
10116           name[1] == 'e' &&
10117           name[2] == 't' &&
10118           name[3] == 'p' &&
10119           name[4] == 'r' &&
10120           name[5] == 'o' &&
10121           name[6] == 't' &&
10122           name[7] == 'o' &&
10123           name[8] == 'b' &&
10124           name[9] == 'y' &&
10125           name[10] == 'n' &&
10126           name[11] == 'a' &&
10127           name[12] == 'm' &&
10128           name[13] == 'e')
10129       {                                           /* getprotobyname */
10130         return -KEY_getprotobyname;
10131       }
10132
10133       goto unknown;
10134
10135     case 16: /* 1 tokens of length 16 */
10136       if (name[0] == 'g' &&
10137           name[1] == 'e' &&
10138           name[2] == 't' &&
10139           name[3] == 'p' &&
10140           name[4] == 'r' &&
10141           name[5] == 'o' &&
10142           name[6] == 't' &&
10143           name[7] == 'o' &&
10144           name[8] == 'b' &&
10145           name[9] == 'y' &&
10146           name[10] == 'n' &&
10147           name[11] == 'u' &&
10148           name[12] == 'm' &&
10149           name[13] == 'b' &&
10150           name[14] == 'e' &&
10151           name[15] == 'r')
10152       {                                           /* getprotobynumber */
10153         return -KEY_getprotobynumber;
10154       }
10155
10156       goto unknown;
10157
10158     default:
10159       goto unknown;
10160   }
10161
10162 unknown:
10163   return 0;
10164 }
10165
10166 STATIC void
10167 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10168 {
10169     dVAR;
10170
10171     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
10172         if (ckWARN(WARN_SYNTAX)) {
10173             int level = 1;
10174             const char *w;
10175             for (w = s+2; *w && level; w++) {
10176                 if (*w == '(')
10177                     ++level;
10178                 else if (*w == ')')
10179                     --level;
10180             }
10181             while (isSPACE(*w))
10182                 ++w;
10183             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
10184                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10185                             "%s (...) interpreted as function",name);
10186         }
10187     }
10188     while (s < PL_bufend && isSPACE(*s))
10189         s++;
10190     if (*s == '(')
10191         s++;
10192     while (s < PL_bufend && isSPACE(*s))
10193         s++;
10194     if (isIDFIRST_lazy_if(s,UTF)) {
10195         const char * const w = s++;
10196         while (isALNUM_lazy_if(s,UTF))
10197             s++;
10198         while (s < PL_bufend && isSPACE(*s))
10199             s++;
10200         if (*s == ',') {
10201             GV* gv;
10202             if (keyword(w, s - w))
10203                 return;
10204
10205             gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10206             if (gv && GvCVu(gv))
10207                 return;
10208             Perl_croak(aTHX_ "No comma allowed after %s", what);
10209         }
10210     }
10211 }
10212
10213 /* Either returns sv, or mortalizes sv and returns a new SV*.
10214    Best used as sv=new_constant(..., sv, ...).
10215    If s, pv are NULL, calls subroutine with one argument,
10216    and type is used with error messages only. */
10217
10218 STATIC SV *
10219 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
10220                const char *type)
10221 {
10222     dVAR; dSP;
10223     HV * const table = GvHV(PL_hintgv);          /* ^H */
10224     SV *res;
10225     SV **cvp;
10226     SV *cv, *typesv;
10227     const char *why1 = "", *why2 = "", *why3 = "";
10228
10229     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10230         SV *msg;
10231
10232         why2 = strEQ(key,"charnames")
10233                ? "(possibly a missing \"use charnames ...\")"
10234                : "";
10235         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10236                             (type ? type: "undef"), why2);
10237
10238         /* This is convoluted and evil ("goto considered harmful")
10239          * but I do not understand the intricacies of all the different
10240          * failure modes of %^H in here.  The goal here is to make
10241          * the most probable error message user-friendly. --jhi */
10242
10243         goto msgdone;
10244
10245     report:
10246         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10247                             (type ? type: "undef"), why1, why2, why3);
10248     msgdone:
10249         yyerror(SvPVX_const(msg));
10250         SvREFCNT_dec(msg);
10251         return sv;
10252     }
10253     cvp = hv_fetch(table, key, strlen(key), FALSE);
10254     if (!cvp || !SvOK(*cvp)) {
10255         why1 = "$^H{";
10256         why2 = key;
10257         why3 = "} is not defined";
10258         goto report;
10259     }
10260     sv_2mortal(sv);                     /* Parent created it permanently */
10261     cv = *cvp;
10262     if (!pv && s)
10263         pv = sv_2mortal(newSVpvn(s, len));
10264     if (type && pv)
10265         typesv = sv_2mortal(newSVpv(type, 0));
10266     else
10267         typesv = &PL_sv_undef;
10268
10269     PUSHSTACKi(PERLSI_OVERLOAD);
10270     ENTER ;
10271     SAVETMPS;
10272
10273     PUSHMARK(SP) ;
10274     EXTEND(sp, 3);
10275     if (pv)
10276         PUSHs(pv);
10277     PUSHs(sv);
10278     if (pv)
10279         PUSHs(typesv);
10280     PUTBACK;
10281     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10282
10283     SPAGAIN ;
10284
10285     /* Check the eval first */
10286     if (!PL_in_eval && SvTRUE(ERRSV)) {
10287         sv_catpvs(ERRSV, "Propagated");
10288         yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10289         (void)POPs;
10290         res = SvREFCNT_inc_simple(sv);
10291     }
10292     else {
10293         res = POPs;
10294         SvREFCNT_inc_simple_void(res);
10295     }
10296
10297     PUTBACK ;
10298     FREETMPS ;
10299     LEAVE ;
10300     POPSTACK;
10301
10302     if (!SvOK(res)) {
10303         why1 = "Call to &{$^H{";
10304         why2 = key;
10305         why3 = "}} did not return a defined value";
10306         sv = res;
10307         goto report;
10308     }
10309
10310     return res;
10311 }
10312
10313 /* Returns a NUL terminated string, with the length of the string written to
10314    *slp
10315    */
10316 STATIC char *
10317 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10318 {
10319     dVAR;
10320     register char *d = dest;
10321     register char * const e = d + destlen - 3;  /* two-character token, ending NUL */
10322     for (;;) {
10323         if (d >= e)
10324             Perl_croak(aTHX_ ident_too_long);
10325         if (isALNUM(*s))        /* UTF handled below */
10326             *d++ = *s++;
10327         else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
10328             *d++ = ':';
10329             *d++ = ':';
10330             s++;
10331         }
10332         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
10333             *d++ = *s++;
10334             *d++ = *s++;
10335         }
10336         else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10337             char *t = s + UTF8SKIP(s);
10338             while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10339                 t += UTF8SKIP(t);
10340             if (d + (t - s) > e)
10341                 Perl_croak(aTHX_ ident_too_long);
10342             Copy(s, d, t - s, char);
10343             d += t - s;
10344             s = t;
10345         }
10346         else {
10347             *d = '\0';
10348             *slp = d - dest;
10349             return s;
10350         }
10351     }
10352 }
10353
10354 STATIC char *
10355 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10356 {
10357     dVAR;
10358     char *bracket = NULL;
10359     char funny = *s++;
10360     register char *d = dest;
10361     register char * const e = d + destlen + 3;    /* two-character token, ending NUL */
10362
10363     if (isSPACE(*s))
10364         s = PEEKSPACE(s);
10365     if (isDIGIT(*s)) {
10366         while (isDIGIT(*s)) {
10367             if (d >= e)
10368                 Perl_croak(aTHX_ ident_too_long);
10369             *d++ = *s++;
10370         }
10371     }
10372     else {
10373         for (;;) {
10374             if (d >= e)
10375                 Perl_croak(aTHX_ ident_too_long);
10376             if (isALNUM(*s))    /* UTF handled below */
10377                 *d++ = *s++;
10378             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10379                 *d++ = ':';
10380                 *d++ = ':';
10381                 s++;
10382             }
10383             else if (*s == ':' && s[1] == ':') {
10384                 *d++ = *s++;
10385                 *d++ = *s++;
10386             }
10387             else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10388                 char *t = s + UTF8SKIP(s);
10389                 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10390                     t += UTF8SKIP(t);
10391                 if (d + (t - s) > e)
10392                     Perl_croak(aTHX_ ident_too_long);
10393                 Copy(s, d, t - s, char);
10394                 d += t - s;
10395                 s = t;
10396             }
10397             else
10398                 break;
10399         }
10400     }
10401     *d = '\0';
10402     d = dest;
10403     if (*d) {
10404         if (PL_lex_state != LEX_NORMAL)
10405             PL_lex_state = LEX_INTERPENDMAYBE;
10406         return s;
10407     }
10408     if (*s == '$' && s[1] &&
10409         (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10410     {
10411         return s;
10412     }
10413     if (*s == '{') {
10414         bracket = s;
10415         s++;
10416     }
10417     else if (ck_uni)
10418         check_uni();
10419     if (s < send)
10420         *d = *s++;
10421     d[1] = '\0';
10422     if (*d == '^' && *s && isCONTROLVAR(*s)) {
10423         *d = toCTRL(*s);
10424         s++;
10425     }
10426     if (bracket) {
10427         if (isSPACE(s[-1])) {
10428             while (s < send) {
10429                 const char ch = *s++;
10430                 if (!SPACE_OR_TAB(ch)) {
10431                     *d = ch;
10432                     break;
10433                 }
10434             }
10435         }
10436         if (isIDFIRST_lazy_if(d,UTF)) {
10437             d++;
10438             if (UTF) {
10439                 char *end = s;
10440                 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10441                     end += UTF8SKIP(end);
10442                     while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10443                         end += UTF8SKIP(end);
10444                 }
10445                 Copy(s, d, end - s, char);
10446                 d += end - s;
10447                 s = end;
10448             }
10449             else {
10450                 while ((isALNUM(*s) || *s == ':') && d < e)
10451                     *d++ = *s++;
10452                 if (d >= e)
10453                     Perl_croak(aTHX_ ident_too_long);
10454             }
10455             *d = '\0';
10456             while (s < send && SPACE_OR_TAB(*s)) s++;
10457             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10458                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
10459                     const char *brack = *s == '[' ? "[...]" : "{...}";
10460                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10461                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10462                         funny, dest, brack, funny, dest, brack);
10463                 }
10464                 bracket++;
10465                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10466                 return s;
10467             }
10468         }
10469         /* Handle extended ${^Foo} variables
10470          * 1999-02-27 mjd-perl-patch@plover.com */
10471         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10472                  && isALNUM(*s))
10473         {
10474             d++;
10475             while (isALNUM(*s) && d < e) {
10476                 *d++ = *s++;
10477             }
10478             if (d >= e)
10479                 Perl_croak(aTHX_ ident_too_long);
10480             *d = '\0';
10481         }
10482         if (*s == '}') {
10483             s++;
10484             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10485                 PL_lex_state = LEX_INTERPEND;
10486                 PL_expect = XREF;
10487             }
10488             if (funny == '#')
10489                 funny = '@';
10490             if (PL_lex_state == LEX_NORMAL) {
10491                 if (ckWARN(WARN_AMBIGUOUS) &&
10492                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
10493                 {
10494                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10495                         "Ambiguous use of %c{%s} resolved to %c%s",
10496                         funny, dest, funny, dest);
10497                 }
10498             }
10499         }
10500         else {
10501             s = bracket;                /* let the parser handle it */
10502             *dest = '\0';
10503         }
10504     }
10505     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10506         PL_lex_state = LEX_INTERPEND;
10507     return s;
10508 }
10509
10510 void
10511 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10512 {
10513     PERL_UNUSED_CONTEXT;
10514     if (ch == 'i')
10515         *pmfl |= PMf_FOLD;
10516     else if (ch == 'g')
10517         *pmfl |= PMf_GLOBAL;
10518     else if (ch == 'c')
10519         *pmfl |= PMf_CONTINUE;
10520     else if (ch == 'o')
10521         *pmfl |= PMf_KEEP;
10522     else if (ch == 'm')
10523         *pmfl |= PMf_MULTILINE;
10524     else if (ch == 's')
10525         *pmfl |= PMf_SINGLELINE;
10526     else if (ch == 'x')
10527         *pmfl |= PMf_EXTENDED;
10528 }
10529
10530 STATIC char *
10531 S_scan_pat(pTHX_ char *start, I32 type)
10532 {
10533     dVAR;
10534     PMOP *pm;
10535     char *s = scan_str(start,!!PL_madskills,FALSE);
10536     const char * const valid_flags = (type == OP_QR) ? "iomsx" : "iogcmsx";
10537 #ifdef PERL_MAD
10538     char *modstart;
10539 #endif
10540
10541
10542     if (!s) {
10543         const char * const delimiter = skipspace(start);
10544         Perl_croak(aTHX_ *delimiter == '?'
10545                    ? "Search pattern not terminated or ternary operator parsed as search pattern"
10546                    : "Search pattern not terminated" );
10547     }
10548
10549     pm = (PMOP*)newPMOP(type, 0);
10550     if (PL_multi_open == '?')
10551         pm->op_pmflags |= PMf_ONCE;
10552 #ifdef PERL_MAD
10553     modstart = s;
10554 #endif
10555     while (*s && strchr(valid_flags, *s))
10556         pmflag(&pm->op_pmflags,*s++);
10557 #ifdef PERL_MAD
10558     if (PL_madskills && modstart != s) {
10559         SV* tmptoken = newSVpvn(modstart, s - modstart);
10560         append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
10561     }
10562 #endif
10563     /* issue a warning if /c is specified,but /g is not */
10564     if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
10565             && ckWARN(WARN_REGEXP))
10566     {
10567         Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
10568     }
10569
10570     pm->op_pmpermflags = pm->op_pmflags;
10571
10572     PL_lex_op = (OP*)pm;
10573     yylval.ival = OP_MATCH;
10574     return s;
10575 }
10576
10577 STATIC char *
10578 S_scan_subst(pTHX_ char *start)
10579 {
10580     dVAR;
10581     register char *s;
10582     register PMOP *pm;
10583     I32 first_start;
10584     I32 es = 0;
10585 #ifdef PERL_MAD
10586     char *modstart;
10587 #endif
10588
10589     yylval.ival = OP_NULL;
10590
10591     s = scan_str(start,!!PL_madskills,FALSE);
10592
10593     if (!s)
10594         Perl_croak(aTHX_ "Substitution pattern not terminated");
10595
10596     if (s[-1] == PL_multi_open)
10597         s--;
10598 #ifdef PERL_MAD
10599     if (PL_madskills) {
10600         CURMAD('q', PL_thisopen);
10601         CURMAD('_', PL_thiswhite);
10602         CURMAD('E', PL_thisstuff);
10603         CURMAD('Q', PL_thisclose);
10604         PL_realtokenstart = s - SvPVX(PL_linestr);
10605     }
10606 #endif
10607
10608     first_start = PL_multi_start;
10609     s = scan_str(s,!!PL_madskills,FALSE);
10610     if (!s) {
10611         if (PL_lex_stuff) {
10612             SvREFCNT_dec(PL_lex_stuff);
10613             PL_lex_stuff = NULL;
10614         }
10615         Perl_croak(aTHX_ "Substitution replacement not terminated");
10616     }
10617     PL_multi_start = first_start;       /* so whole substitution is taken together */
10618
10619     pm = (PMOP*)newPMOP(OP_SUBST, 0);
10620
10621 #ifdef PERL_MAD
10622     if (PL_madskills) {
10623         CURMAD('z', PL_thisopen);
10624         CURMAD('R', PL_thisstuff);
10625         CURMAD('Z', PL_thisclose);
10626     }
10627     modstart = s;
10628 #endif
10629
10630     while (*s) {
10631         if (*s == 'e') {
10632             s++;
10633             es++;
10634         }
10635         else if (strchr("iogcmsx", *s))
10636             pmflag(&pm->op_pmflags,*s++);
10637         else
10638             break;
10639     }
10640
10641 #ifdef PERL_MAD
10642     if (PL_madskills) {
10643         if (modstart != s)
10644             curmad('m', newSVpvn(modstart, s - modstart));
10645         append_madprops(PL_thismad, (OP*)pm, 0);
10646         PL_thismad = 0;
10647     }
10648 #endif
10649     if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
10650         Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
10651     }
10652
10653     if (es) {
10654         SV * const repl = newSVpvs("");
10655
10656         PL_sublex_info.super_bufptr = s;
10657         PL_sublex_info.super_bufend = PL_bufend;
10658         PL_multi_end = 0;
10659         pm->op_pmflags |= PMf_EVAL;
10660         while (es-- > 0)
10661             sv_catpv(repl, es ? "eval " : "do ");
10662         sv_catpvs(repl, "{");
10663         sv_catsv(repl, PL_lex_repl);
10664         sv_catpvs(repl, "}");
10665         SvEVALED_on(repl);
10666         SvREFCNT_dec(PL_lex_repl);
10667         PL_lex_repl = repl;
10668     }
10669
10670     pm->op_pmpermflags = pm->op_pmflags;
10671     PL_lex_op = (OP*)pm;
10672     yylval.ival = OP_SUBST;
10673     return s;
10674 }
10675
10676 STATIC char *
10677 S_scan_trans(pTHX_ char *start)
10678 {
10679     dVAR;
10680     register char* s;
10681     OP *o;
10682     short *tbl;
10683     I32 squash;
10684     I32 del;
10685     I32 complement;
10686 #ifdef PERL_MAD
10687     char *modstart;
10688 #endif
10689
10690     yylval.ival = OP_NULL;
10691
10692     s = scan_str(start,!!PL_madskills,FALSE);
10693     if (!s)
10694         Perl_croak(aTHX_ "Transliteration pattern not terminated");
10695
10696     if (s[-1] == PL_multi_open)
10697         s--;
10698 #ifdef PERL_MAD
10699     if (PL_madskills) {
10700         CURMAD('q', PL_thisopen);
10701         CURMAD('_', PL_thiswhite);
10702         CURMAD('E', PL_thisstuff);
10703         CURMAD('Q', PL_thisclose);
10704         PL_realtokenstart = s - SvPVX(PL_linestr);
10705     }
10706 #endif
10707
10708     s = scan_str(s,!!PL_madskills,FALSE);
10709     if (!s) {
10710         if (PL_lex_stuff) {
10711             SvREFCNT_dec(PL_lex_stuff);
10712             PL_lex_stuff = NULL;
10713         }
10714         Perl_croak(aTHX_ "Transliteration replacement not terminated");
10715     }
10716     if (PL_madskills) {
10717         CURMAD('z', PL_thisopen);
10718         CURMAD('R', PL_thisstuff);
10719         CURMAD('Z', PL_thisclose);
10720     }
10721
10722     complement = del = squash = 0;
10723 #ifdef PERL_MAD
10724     modstart = s;
10725 #endif
10726     while (1) {
10727         switch (*s) {
10728         case 'c':
10729             complement = OPpTRANS_COMPLEMENT;
10730             break;
10731         case 'd':
10732             del = OPpTRANS_DELETE;
10733             break;
10734         case 's':
10735             squash = OPpTRANS_SQUASH;
10736             break;
10737         default:
10738             goto no_more;
10739         }
10740         s++;
10741     }
10742   no_more:
10743
10744     Newx(tbl, complement&&!del?258:256, short);
10745     o = newPVOP(OP_TRANS, 0, (char*)tbl);
10746     o->op_private &= ~OPpTRANS_ALL;
10747     o->op_private |= del|squash|complement|
10748       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
10749       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
10750
10751     PL_lex_op = o;
10752     yylval.ival = OP_TRANS;
10753
10754 #ifdef PERL_MAD
10755     if (PL_madskills) {
10756         if (modstart != s)
10757             curmad('m', newSVpvn(modstart, s - modstart));
10758         append_madprops(PL_thismad, o, 0);
10759         PL_thismad = 0;
10760     }
10761 #endif
10762
10763     return s;
10764 }
10765
10766 STATIC char *
10767 S_scan_heredoc(pTHX_ register char *s)
10768 {
10769     dVAR;
10770     SV *herewas;
10771     I32 op_type = OP_SCALAR;
10772     I32 len;
10773     SV *tmpstr;
10774     char term;
10775     const char *found_newline;
10776     register char *d;
10777     register char *e;
10778     char *peek;
10779     const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
10780 #ifdef PERL_MAD
10781     I32 stuffstart = s - SvPVX(PL_linestr);
10782     char *tstart;
10783
10784     PL_realtokenstart = -1;
10785 #endif
10786
10787     s += 2;
10788     d = PL_tokenbuf;
10789     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
10790     if (!outer)
10791         *d++ = '\n';
10792     for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
10793     if (*peek == '`' || *peek == '\'' || *peek =='"') {
10794         s = peek;
10795         term = *s++;
10796         s = delimcpy(d, e, s, PL_bufend, term, &len);
10797         d += len;
10798         if (s < PL_bufend)
10799             s++;
10800     }
10801     else {
10802         if (*s == '\\')
10803             s++, term = '\'';
10804         else
10805             term = '"';
10806         if (!isALNUM_lazy_if(s,UTF))
10807             deprecate_old("bare << to mean <<\"\"");
10808         for (; isALNUM_lazy_if(s,UTF); s++) {
10809             if (d < e)
10810                 *d++ = *s;
10811         }
10812     }
10813     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
10814         Perl_croak(aTHX_ "Delimiter for here document is too long");
10815     *d++ = '\n';
10816     *d = '\0';
10817     len = d - PL_tokenbuf;
10818
10819 #ifdef PERL_MAD
10820     if (PL_madskills) {
10821         tstart = PL_tokenbuf + !outer;
10822         PL_thisclose = newSVpvn(tstart, len - !outer);
10823         tstart = SvPVX(PL_linestr) + stuffstart;
10824         PL_thisopen = newSVpvn(tstart, s - tstart);
10825         stuffstart = s - SvPVX(PL_linestr);
10826     }
10827 #endif
10828 #ifndef PERL_STRICT_CR
10829     d = strchr(s, '\r');
10830     if (d) {
10831         char * const olds = s;
10832         s = d;
10833         while (s < PL_bufend) {
10834             if (*s == '\r') {
10835                 *d++ = '\n';
10836                 if (*++s == '\n')
10837                     s++;
10838             }
10839             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
10840                 *d++ = *s++;
10841                 s++;
10842             }
10843             else
10844                 *d++ = *s++;
10845         }
10846         *d = '\0';
10847         PL_bufend = d;
10848         SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10849         s = olds;
10850     }
10851 #endif
10852 #ifdef PERL_MAD
10853     found_newline = 0;
10854 #endif
10855     if ( outer || !(found_newline = memchr(s, '\n', PL_bufend - s)) ) {
10856         herewas = newSVpvn(s,PL_bufend-s);
10857     }
10858     else {
10859 #ifdef PERL_MAD
10860         herewas = newSVpvn(s-1,found_newline-s+1);
10861 #else
10862         s--;
10863         herewas = newSVpvn(s,found_newline-s);
10864 #endif
10865     }
10866 #ifdef PERL_MAD
10867     if (PL_madskills) {
10868         tstart = SvPVX(PL_linestr) + stuffstart;
10869         if (PL_thisstuff)
10870             sv_catpvn(PL_thisstuff, tstart, s - tstart);
10871         else
10872             PL_thisstuff = newSVpvn(tstart, s - tstart);
10873     }
10874 #endif
10875     s += SvCUR(herewas);
10876
10877 #ifdef PERL_MAD
10878     stuffstart = s - SvPVX(PL_linestr);
10879
10880     if (found_newline)
10881         s--;
10882 #endif
10883
10884     tmpstr = newSV(79);
10885     sv_upgrade(tmpstr, SVt_PVIV);
10886     if (term == '\'') {
10887         op_type = OP_CONST;
10888         SvIV_set(tmpstr, -1);
10889     }
10890     else if (term == '`') {
10891         op_type = OP_BACKTICK;
10892         SvIV_set(tmpstr, '\\');
10893     }
10894
10895     CLINE;
10896     PL_multi_start = CopLINE(PL_curcop);
10897     PL_multi_open = PL_multi_close = '<';
10898     term = *PL_tokenbuf;
10899     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
10900         char * const bufptr = PL_sublex_info.super_bufptr;
10901         char * const bufend = PL_sublex_info.super_bufend;
10902         char * const olds = s - SvCUR(herewas);
10903         s = strchr(bufptr, '\n');
10904         if (!s)
10905             s = bufend;
10906         d = s;
10907         while (s < bufend &&
10908           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
10909             if (*s++ == '\n')
10910                 CopLINE_inc(PL_curcop);
10911         }
10912         if (s >= bufend) {
10913             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10914             missingterm(PL_tokenbuf);
10915         }
10916         sv_setpvn(herewas,bufptr,d-bufptr+1);
10917         sv_setpvn(tmpstr,d+1,s-d);
10918         s += len - 1;
10919         sv_catpvn(herewas,s,bufend-s);
10920         Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
10921
10922         s = olds;
10923         goto retval;
10924     }
10925     else if (!outer) {
10926         d = s;
10927         while (s < PL_bufend &&
10928           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
10929             if (*s++ == '\n')
10930                 CopLINE_inc(PL_curcop);
10931         }
10932         if (s >= PL_bufend) {
10933             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10934             missingterm(PL_tokenbuf);
10935         }
10936         sv_setpvn(tmpstr,d+1,s-d);
10937 #ifdef PERL_MAD
10938         if (PL_madskills) {
10939             if (PL_thisstuff)
10940                 sv_catpvn(PL_thisstuff, d + 1, s - d);
10941             else
10942                 PL_thisstuff = newSVpvn(d + 1, s - d);
10943             stuffstart = s - SvPVX(PL_linestr);
10944         }
10945 #endif
10946         s += len - 1;
10947         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
10948
10949         sv_catpvn(herewas,s,PL_bufend-s);
10950         sv_setsv(PL_linestr,herewas);
10951         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
10952         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10953         PL_last_lop = PL_last_uni = NULL;
10954     }
10955     else
10956         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
10957     while (s >= PL_bufend) {    /* multiple line string? */
10958 #ifdef PERL_MAD
10959         if (PL_madskills) {
10960             tstart = SvPVX(PL_linestr) + stuffstart;
10961             if (PL_thisstuff)
10962                 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10963             else
10964                 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10965         }
10966 #endif
10967         if (!outer ||
10968          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
10969             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10970             missingterm(PL_tokenbuf);
10971         }
10972 #ifdef PERL_MAD
10973         stuffstart = s - SvPVX(PL_linestr);
10974 #endif
10975         CopLINE_inc(PL_curcop);
10976         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10977         PL_last_lop = PL_last_uni = NULL;
10978 #ifndef PERL_STRICT_CR
10979         if (PL_bufend - PL_linestart >= 2) {
10980             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
10981                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10982             {
10983                 PL_bufend[-2] = '\n';
10984                 PL_bufend--;
10985                 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10986             }
10987             else if (PL_bufend[-1] == '\r')
10988                 PL_bufend[-1] = '\n';
10989         }
10990         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10991             PL_bufend[-1] = '\n';
10992 #endif
10993         if (PERLDB_LINE && PL_curstash != PL_debstash) {
10994             SV * const sv = newSV(0);
10995
10996             sv_upgrade(sv, SVt_PVMG);
10997             sv_setsv(sv,PL_linestr);
10998             (void)SvIOK_on(sv);
10999             SvIV_set(sv, 0);
11000             av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop),sv);
11001         }
11002         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11003             STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11004             *(SvPVX(PL_linestr) + off ) = ' ';
11005             sv_catsv(PL_linestr,herewas);
11006             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11007             s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11008         }
11009         else {
11010             s = PL_bufend;
11011             sv_catsv(tmpstr,PL_linestr);
11012         }
11013     }
11014     s++;
11015 retval:
11016     PL_multi_end = CopLINE(PL_curcop);
11017     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11018         SvPV_shrink_to_cur(tmpstr);
11019     }
11020     SvREFCNT_dec(herewas);
11021     if (!IN_BYTES) {
11022         if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11023             SvUTF8_on(tmpstr);
11024         else if (PL_encoding)
11025             sv_recode_to_utf8(tmpstr, PL_encoding);
11026     }
11027     PL_lex_stuff = tmpstr;
11028     yylval.ival = op_type;
11029     return s;
11030 }
11031
11032 /* scan_inputsymbol
11033    takes: current position in input buffer
11034    returns: new position in input buffer
11035    side-effects: yylval and lex_op are set.
11036
11037    This code handles:
11038
11039    <>           read from ARGV
11040    <FH>         read from filehandle
11041    <pkg::FH>    read from package qualified filehandle
11042    <pkg'FH>     read from package qualified filehandle
11043    <$fh>        read from filehandle in $fh
11044    <*.h>        filename glob
11045
11046 */
11047
11048 STATIC char *
11049 S_scan_inputsymbol(pTHX_ char *start)
11050 {
11051     dVAR;
11052     register char *s = start;           /* current position in buffer */
11053     char *end;
11054     I32 len;
11055
11056     char *d = PL_tokenbuf;                                      /* start of temp holding space */
11057     const char * const e = PL_tokenbuf + sizeof PL_tokenbuf;    /* end of temp holding space */
11058
11059     end = strchr(s, '\n');
11060     if (!end)
11061         end = PL_bufend;
11062     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
11063
11064     /* die if we didn't have space for the contents of the <>,
11065        or if it didn't end, or if we see a newline
11066     */
11067
11068     if (len >= sizeof PL_tokenbuf)
11069         Perl_croak(aTHX_ "Excessively long <> operator");
11070     if (s >= end)
11071         Perl_croak(aTHX_ "Unterminated <> operator");
11072
11073     s++;
11074
11075     /* check for <$fh>
11076        Remember, only scalar variables are interpreted as filehandles by
11077        this code.  Anything more complex (e.g., <$fh{$num}>) will be
11078        treated as a glob() call.
11079        This code makes use of the fact that except for the $ at the front,
11080        a scalar variable and a filehandle look the same.
11081     */
11082     if (*d == '$' && d[1]) d++;
11083
11084     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11085     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11086         d++;
11087
11088     /* If we've tried to read what we allow filehandles to look like, and
11089        there's still text left, then it must be a glob() and not a getline.
11090        Use scan_str to pull out the stuff between the <> and treat it
11091        as nothing more than a string.
11092     */
11093
11094     if (d - PL_tokenbuf != len) {
11095         yylval.ival = OP_GLOB;
11096         set_csh();
11097         s = scan_str(start,!!PL_madskills,FALSE);
11098         if (!s)
11099            Perl_croak(aTHX_ "Glob not terminated");
11100         return s;
11101     }
11102     else {
11103         bool readline_overriden = FALSE;
11104         GV *gv_readline;
11105         GV **gvp;
11106         /* we're in a filehandle read situation */
11107         d = PL_tokenbuf;
11108
11109         /* turn <> into <ARGV> */
11110         if (!len)
11111             Copy("ARGV",d,5,char);
11112
11113         /* Check whether readline() is overriden */
11114         gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11115         if ((gv_readline
11116                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11117                 ||
11118                 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11119                 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
11120                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11121             readline_overriden = TRUE;
11122
11123         /* if <$fh>, create the ops to turn the variable into a
11124            filehandle
11125         */
11126         if (*d == '$') {
11127             I32 tmp;
11128
11129             /* try to find it in the pad for this block, otherwise find
11130                add symbol table ops
11131             */
11132             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
11133                 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11134                     HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11135                     HEK * const stashname = HvNAME_HEK(stash);
11136                     SV * const sym = sv_2mortal(newSVhek(stashname));
11137                     sv_catpvs(sym, "::");
11138                     sv_catpv(sym, d+1);
11139                     d = SvPVX(sym);
11140                     goto intro_sym;
11141                 }
11142                 else {
11143                     OP * const o = newOP(OP_PADSV, 0);
11144                     o->op_targ = tmp;
11145                     PL_lex_op = readline_overriden
11146                         ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11147                                 append_elem(OP_LIST, o,
11148                                     newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11149                         : (OP*)newUNOP(OP_READLINE, 0, o);
11150                 }
11151             }
11152             else {
11153                 GV *gv;
11154                 ++d;
11155 intro_sym:
11156                 gv = gv_fetchpv(d,
11157                                 (PL_in_eval
11158                                  ? (GV_ADDMULTI | GV_ADDINEVAL)
11159                                  : GV_ADDMULTI),
11160                                 SVt_PV);
11161                 PL_lex_op = readline_overriden
11162                     ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11163                             append_elem(OP_LIST,
11164                                 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11165                                 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11166                     : (OP*)newUNOP(OP_READLINE, 0,
11167                             newUNOP(OP_RV2SV, 0,
11168                                 newGVOP(OP_GV, 0, gv)));
11169             }
11170             if (!readline_overriden)
11171                 PL_lex_op->op_flags |= OPf_SPECIAL;
11172             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
11173             yylval.ival = OP_NULL;
11174         }
11175
11176         /* If it's none of the above, it must be a literal filehandle
11177            (<Foo::BAR> or <FOO>) so build a simple readline OP */
11178         else {
11179             GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11180             PL_lex_op = readline_overriden
11181                 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11182                         append_elem(OP_LIST,
11183                             newGVOP(OP_GV, 0, gv),
11184                             newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11185                 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11186             yylval.ival = OP_NULL;
11187         }
11188     }
11189
11190     return s;
11191 }
11192
11193
11194 /* scan_str
11195    takes: start position in buffer
11196           keep_quoted preserve \ on the embedded delimiter(s)
11197           keep_delims preserve the delimiters around the string
11198    returns: position to continue reading from buffer
11199    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11200         updates the read buffer.
11201
11202    This subroutine pulls a string out of the input.  It is called for:
11203         q               single quotes           q(literal text)
11204         '               single quotes           'literal text'
11205         qq              double quotes           qq(interpolate $here please)
11206         "               double quotes           "interpolate $here please"
11207         qx              backticks               qx(/bin/ls -l)
11208         `               backticks               `/bin/ls -l`
11209         qw              quote words             @EXPORT_OK = qw( func() $spam )
11210         m//             regexp match            m/this/
11211         s///            regexp substitute       s/this/that/
11212         tr///           string transliterate    tr/this/that/
11213         y///            string transliterate    y/this/that/
11214         ($*@)           sub prototypes          sub foo ($)
11215         (stuff)         sub attr parameters     sub foo : attr(stuff)
11216         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
11217
11218    In most of these cases (all but <>, patterns and transliterate)
11219    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
11220    calls scan_str().  s/// makes yylex() call scan_subst() which calls
11221    scan_str().  tr/// and y/// make yylex() call scan_trans() which
11222    calls scan_str().
11223
11224    It skips whitespace before the string starts, and treats the first
11225    character as the delimiter.  If the delimiter is one of ([{< then
11226    the corresponding "close" character )]}> is used as the closing
11227    delimiter.  It allows quoting of delimiters, and if the string has
11228    balanced delimiters ([{<>}]) it allows nesting.
11229
11230    On success, the SV with the resulting string is put into lex_stuff or,
11231    if that is already non-NULL, into lex_repl. The second case occurs only
11232    when parsing the RHS of the special constructs s/// and tr/// (y///).
11233    For convenience, the terminating delimiter character is stuffed into
11234    SvIVX of the SV.
11235 */
11236
11237 STATIC char *
11238 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11239 {
11240     dVAR;
11241     SV *sv;                             /* scalar value: string */
11242     char *tmps;                         /* temp string, used for delimiter matching */
11243     register char *s = start;           /* current position in the buffer */
11244     register char term;                 /* terminating character */
11245     register char *to;                  /* current position in the sv's data */
11246     I32 brackets = 1;                   /* bracket nesting level */
11247     bool has_utf8 = FALSE;              /* is there any utf8 content? */
11248     I32 termcode;                       /* terminating char. code */
11249     U8 termstr[UTF8_MAXBYTES];          /* terminating string */
11250     STRLEN termlen;                     /* length of terminating string */
11251     char *last = NULL;                  /* last position for nesting bracket */
11252 #ifdef PERL_MAD
11253     int stuffstart;
11254     char *tstart;
11255 #endif
11256
11257     /* skip space before the delimiter */
11258     if (isSPACE(*s)) {
11259         s = PEEKSPACE(s);
11260     }
11261
11262 #ifdef PERL_MAD
11263     if (PL_realtokenstart >= 0) {
11264         stuffstart = PL_realtokenstart;
11265         PL_realtokenstart = -1;
11266     }
11267     else
11268         stuffstart = start - SvPVX(PL_linestr);
11269 #endif
11270     /* mark where we are, in case we need to report errors */
11271     CLINE;
11272
11273     /* after skipping whitespace, the next character is the terminator */
11274     term = *s;
11275     if (!UTF) {
11276         termcode = termstr[0] = term;
11277         termlen = 1;
11278     }
11279     else {
11280         termcode = utf8_to_uvchr((U8*)s, &termlen);
11281         Copy(s, termstr, termlen, U8);
11282         if (!UTF8_IS_INVARIANT(term))
11283             has_utf8 = TRUE;
11284     }
11285
11286     /* mark where we are */
11287     PL_multi_start = CopLINE(PL_curcop);
11288     PL_multi_open = term;
11289
11290     /* find corresponding closing delimiter */
11291     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11292         termcode = termstr[0] = term = tmps[5];
11293
11294     PL_multi_close = term;
11295
11296     /* create a new SV to hold the contents.  79 is the SV's initial length.
11297        What a random number. */
11298     sv = newSV(79);
11299     sv_upgrade(sv, SVt_PVIV);
11300     SvIV_set(sv, termcode);
11301     (void)SvPOK_only(sv);               /* validate pointer */
11302
11303     /* move past delimiter and try to read a complete string */
11304     if (keep_delims)
11305         sv_catpvn(sv, s, termlen);
11306     s += termlen;
11307 #ifdef PERL_MAD
11308     tstart = SvPVX(PL_linestr) + stuffstart;
11309     if (!PL_thisopen && !keep_delims) {
11310         PL_thisopen = newSVpvn(tstart, s - tstart);
11311         stuffstart = s - SvPVX(PL_linestr);
11312     }
11313 #endif
11314     for (;;) {
11315         if (PL_encoding && !UTF) {
11316             bool cont = TRUE;
11317
11318             while (cont) {
11319                 int offset = s - SvPVX_const(PL_linestr);
11320                 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11321                                            &offset, (char*)termstr, termlen);
11322                 const char * const ns = SvPVX_const(PL_linestr) + offset;
11323                 char * const svlast = SvEND(sv) - 1;
11324
11325                 for (; s < ns; s++) {
11326                     if (*s == '\n' && !PL_rsfp)
11327                         CopLINE_inc(PL_curcop);
11328                 }
11329                 if (!found)
11330                     goto read_more_line;
11331                 else {
11332                     /* handle quoted delimiters */
11333                     if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11334                         const char *t;
11335                         for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11336                             t--;
11337                         if ((svlast-1 - t) % 2) {
11338                             if (!keep_quoted) {
11339                                 *(svlast-1) = term;
11340                                 *svlast = '\0';
11341                                 SvCUR_set(sv, SvCUR(sv) - 1);
11342                             }
11343                             continue;
11344                         }
11345                     }
11346                     if (PL_multi_open == PL_multi_close) {
11347                         cont = FALSE;
11348                     }
11349                     else {
11350                         const char *t;
11351                         char *w;
11352                         if (!last)
11353                             last = SvPVX(sv);
11354                         for (t = w = last; t < svlast; w++, t++) {
11355                             /* At here, all closes are "was quoted" one,
11356                                so we don't check PL_multi_close. */
11357                             if (*t == '\\') {
11358                                 if (!keep_quoted && *(t+1) == PL_multi_open)
11359                                     t++;
11360                                 else
11361                                     *w++ = *t++;
11362                             }
11363                             else if (*t == PL_multi_open)
11364                                 brackets++;
11365
11366                             *w = *t;
11367                         }
11368                         if (w < t) {
11369                             *w++ = term;
11370                             *w = '\0';
11371                             SvCUR_set(sv, w - SvPVX_const(sv));
11372                         }
11373                         last = w;
11374                         if (--brackets <= 0)
11375                             cont = FALSE;
11376                     }
11377                 }
11378             }
11379             if (!keep_delims) {
11380                 SvCUR_set(sv, SvCUR(sv) - 1);
11381                 *SvEND(sv) = '\0';
11382             }
11383             break;
11384         }
11385
11386         /* extend sv if need be */
11387         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11388         /* set 'to' to the next character in the sv's string */
11389         to = SvPVX(sv)+SvCUR(sv);
11390
11391         /* if open delimiter is the close delimiter read unbridle */
11392         if (PL_multi_open == PL_multi_close) {
11393             for (; s < PL_bufend; s++,to++) {
11394                 /* embedded newlines increment the current line number */
11395                 if (*s == '\n' && !PL_rsfp)
11396                     CopLINE_inc(PL_curcop);
11397                 /* handle quoted delimiters */
11398                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11399                     if (!keep_quoted && s[1] == term)
11400                         s++;
11401                 /* any other quotes are simply copied straight through */
11402                     else
11403                         *to++ = *s++;
11404                 }
11405                 /* terminate when run out of buffer (the for() condition), or
11406                    have found the terminator */
11407                 else if (*s == term) {
11408                     if (termlen == 1)
11409                         break;
11410                     if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11411                         break;
11412                 }
11413                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11414                     has_utf8 = TRUE;
11415                 *to = *s;
11416             }
11417         }
11418
11419         /* if the terminator isn't the same as the start character (e.g.,
11420            matched brackets), we have to allow more in the quoting, and
11421            be prepared for nested brackets.
11422         */
11423         else {
11424             /* read until we run out of string, or we find the terminator */
11425             for (; s < PL_bufend; s++,to++) {
11426                 /* embedded newlines increment the line count */
11427                 if (*s == '\n' && !PL_rsfp)
11428                     CopLINE_inc(PL_curcop);
11429                 /* backslashes can escape the open or closing characters */
11430                 if (*s == '\\' && s+1 < PL_bufend) {
11431                     if (!keep_quoted &&
11432                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11433                         s++;
11434                     else
11435                         *to++ = *s++;
11436                 }
11437                 /* allow nested opens and closes */
11438                 else if (*s == PL_multi_close && --brackets <= 0)
11439                     break;
11440                 else if (*s == PL_multi_open)
11441                     brackets++;
11442                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11443                     has_utf8 = TRUE;
11444                 *to = *s;
11445             }
11446         }
11447         /* terminate the copied string and update the sv's end-of-string */
11448         *to = '\0';
11449         SvCUR_set(sv, to - SvPVX_const(sv));
11450
11451         /*
11452          * this next chunk reads more into the buffer if we're not done yet
11453          */
11454
11455         if (s < PL_bufend)
11456             break;              /* handle case where we are done yet :-) */
11457
11458 #ifndef PERL_STRICT_CR
11459         if (to - SvPVX_const(sv) >= 2) {
11460             if ((to[-2] == '\r' && to[-1] == '\n') ||
11461                 (to[-2] == '\n' && to[-1] == '\r'))
11462             {
11463                 to[-2] = '\n';
11464                 to--;
11465                 SvCUR_set(sv, to - SvPVX_const(sv));
11466             }
11467             else if (to[-1] == '\r')
11468                 to[-1] = '\n';
11469         }
11470         else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11471             to[-1] = '\n';
11472 #endif
11473
11474      read_more_line:
11475         /* if we're out of file, or a read fails, bail and reset the current
11476            line marker so we can report where the unterminated string began
11477         */
11478 #ifdef PERL_MAD
11479         if (PL_madskills) {
11480             char *tstart = SvPVX(PL_linestr) + stuffstart;
11481             if (PL_thisstuff)
11482                 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11483             else
11484                 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11485         }
11486 #endif
11487         if (!PL_rsfp ||
11488          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11489             sv_free(sv);
11490             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11491             return NULL;
11492         }
11493 #ifdef PERL_MAD
11494         stuffstart = 0;
11495 #endif
11496         /* we read a line, so increment our line counter */
11497         CopLINE_inc(PL_curcop);
11498
11499         /* update debugger info */
11500         if (PERLDB_LINE && PL_curstash != PL_debstash) {
11501             SV * const line_sv = newSV(0);
11502
11503             sv_upgrade(line_sv, SVt_PVMG);
11504             sv_setsv(line_sv,PL_linestr);
11505             (void)SvIOK_on(line_sv);
11506             SvIV_set(line_sv, 0);
11507             av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop), line_sv);
11508         }
11509
11510         /* having changed the buffer, we must update PL_bufend */
11511         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11512         PL_last_lop = PL_last_uni = NULL;
11513     }
11514
11515     /* at this point, we have successfully read the delimited string */
11516
11517     if (!PL_encoding || UTF) {
11518 #ifdef PERL_MAD
11519         if (PL_madskills) {
11520             char *tstart = SvPVX(PL_linestr) + stuffstart;
11521             if (PL_thisstuff)
11522                 sv_catpvn(PL_thisstuff, tstart, s - tstart);
11523             else
11524                 PL_thisstuff = newSVpvn(tstart, s - tstart);
11525             if (!PL_thisclose && !keep_delims)
11526                 PL_thisclose = newSVpvn(s,termlen);
11527         }
11528 #endif
11529
11530         if (keep_delims)
11531             sv_catpvn(sv, s, termlen);
11532         s += termlen;
11533     }
11534 #ifdef PERL_MAD
11535     else {
11536         if (PL_madskills) {
11537             char *tstart = SvPVX(PL_linestr) + stuffstart;
11538             if (PL_thisstuff)
11539                 sv_catpvn(PL_thisstuff, tstart, s - tstart - termlen);
11540             else
11541                 PL_thisstuff = newSVpvn(tstart, s - tstart - termlen);
11542             if (!PL_thisclose && !keep_delims)
11543                 PL_thisclose = newSVpvn(s - termlen,termlen);
11544         }
11545     }
11546 #endif
11547     if (has_utf8 || PL_encoding)
11548         SvUTF8_on(sv);
11549
11550     PL_multi_end = CopLINE(PL_curcop);
11551
11552     /* if we allocated too much space, give some back */
11553     if (SvCUR(sv) + 5 < SvLEN(sv)) {
11554         SvLEN_set(sv, SvCUR(sv) + 1);
11555         SvPV_renew(sv, SvLEN(sv));
11556     }
11557
11558     /* decide whether this is the first or second quoted string we've read
11559        for this op
11560     */
11561
11562     if (PL_lex_stuff)
11563         PL_lex_repl = sv;
11564     else
11565         PL_lex_stuff = sv;
11566     return s;
11567 }
11568
11569 /*
11570   scan_num
11571   takes: pointer to position in buffer
11572   returns: pointer to new position in buffer
11573   side-effects: builds ops for the constant in yylval.op
11574
11575   Read a number in any of the formats that Perl accepts:
11576
11577   \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)      12 12.34 12.
11578   \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                     .34
11579   0b[01](_?[01])*
11580   0[0-7](_?[0-7])*
11581   0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
11582
11583   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
11584   thing it reads.
11585
11586   If it reads a number without a decimal point or an exponent, it will
11587   try converting the number to an integer and see if it can do so
11588   without loss of precision.
11589 */
11590
11591 char *
11592 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
11593 {
11594     dVAR;
11595     register const char *s = start;     /* current position in buffer */
11596     register char *d;                   /* destination in temp buffer */
11597     register char *e;                   /* end of temp buffer */
11598     NV nv;                              /* number read, as a double */
11599     SV *sv = NULL;                      /* place to put the converted number */
11600     bool floatit;                       /* boolean: int or float? */
11601     const char *lastub = NULL;          /* position of last underbar */
11602     static char const number_too_long[] = "Number too long";
11603
11604     /* We use the first character to decide what type of number this is */
11605
11606     switch (*s) {
11607     default:
11608       Perl_croak(aTHX_ "panic: scan_num");
11609
11610     /* if it starts with a 0, it could be an octal number, a decimal in
11611        0.13 disguise, or a hexadecimal number, or a binary number. */
11612     case '0':
11613         {
11614           /* variables:
11615              u          holds the "number so far"
11616              shift      the power of 2 of the base
11617                         (hex == 4, octal == 3, binary == 1)
11618              overflowed was the number more than we can hold?
11619
11620              Shift is used when we add a digit.  It also serves as an "are
11621              we in octal/hex/binary?" indicator to disallow hex characters
11622              when in octal mode.
11623            */
11624             NV n = 0.0;
11625             UV u = 0;
11626             I32 shift;
11627             bool overflowed = FALSE;
11628             bool just_zero  = TRUE;     /* just plain 0 or binary number? */
11629             static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
11630             static const char* const bases[5] =
11631               { "", "binary", "", "octal", "hexadecimal" };
11632             static const char* const Bases[5] =
11633               { "", "Binary", "", "Octal", "Hexadecimal" };
11634             static const char* const maxima[5] =
11635               { "",
11636                 "0b11111111111111111111111111111111",
11637                 "",
11638                 "037777777777",
11639                 "0xffffffff" };
11640             const char *base, *Base, *max;
11641
11642             /* check for hex */
11643             if (s[1] == 'x') {
11644                 shift = 4;
11645                 s += 2;
11646                 just_zero = FALSE;
11647             } else if (s[1] == 'b') {
11648                 shift = 1;
11649                 s += 2;
11650                 just_zero = FALSE;
11651             }
11652             /* check for a decimal in disguise */
11653             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
11654                 goto decimal;
11655             /* so it must be octal */
11656             else {
11657                 shift = 3;
11658                 s++;
11659             }
11660
11661             if (*s == '_') {
11662                if (ckWARN(WARN_SYNTAX))
11663                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11664                                "Misplaced _ in number");
11665                lastub = s++;
11666             }
11667
11668             base = bases[shift];
11669             Base = Bases[shift];
11670             max  = maxima[shift];
11671
11672             /* read the rest of the number */
11673             for (;;) {
11674                 /* x is used in the overflow test,
11675                    b is the digit we're adding on. */
11676                 UV x, b;
11677
11678                 switch (*s) {
11679
11680                 /* if we don't mention it, we're done */
11681                 default:
11682                     goto out;
11683
11684                 /* _ are ignored -- but warned about if consecutive */
11685                 case '_':
11686                     if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
11687                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11688                                     "Misplaced _ in number");
11689                     lastub = s++;
11690                     break;
11691
11692                 /* 8 and 9 are not octal */
11693                 case '8': case '9':
11694                     if (shift == 3)
11695                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
11696                     /* FALL THROUGH */
11697
11698                 /* octal digits */
11699                 case '2': case '3': case '4':
11700                 case '5': case '6': case '7':
11701                     if (shift == 1)
11702                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
11703                     /* FALL THROUGH */
11704
11705                 case '0': case '1':
11706                     b = *s++ & 15;              /* ASCII digit -> value of digit */
11707                     goto digit;
11708
11709                 /* hex digits */
11710                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
11711                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
11712                     /* make sure they said 0x */
11713                     if (shift != 4)
11714                         goto out;
11715                     b = (*s++ & 7) + 9;
11716
11717                     /* Prepare to put the digit we have onto the end
11718                        of the number so far.  We check for overflows.
11719                     */
11720
11721                   digit:
11722                     just_zero = FALSE;
11723                     if (!overflowed) {
11724                         x = u << shift; /* make room for the digit */
11725
11726                         if ((x >> shift) != u
11727                             && !(PL_hints & HINT_NEW_BINARY)) {
11728                             overflowed = TRUE;
11729                             n = (NV) u;
11730                             if (ckWARN_d(WARN_OVERFLOW))
11731                                 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11732                                             "Integer overflow in %s number",
11733                                             base);
11734                         } else
11735                             u = x | b;          /* add the digit to the end */
11736                     }
11737                     if (overflowed) {
11738                         n *= nvshift[shift];
11739                         /* If an NV has not enough bits in its
11740                          * mantissa to represent an UV this summing of
11741                          * small low-order numbers is a waste of time
11742                          * (because the NV cannot preserve the
11743                          * low-order bits anyway): we could just
11744                          * remember when did we overflow and in the
11745                          * end just multiply n by the right
11746                          * amount. */
11747                         n += (NV) b;
11748                     }
11749                     break;
11750                 }
11751             }
11752
11753           /* if we get here, we had success: make a scalar value from
11754              the number.
11755           */
11756           out:
11757
11758             /* final misplaced underbar check */
11759             if (s[-1] == '_') {
11760                 if (ckWARN(WARN_SYNTAX))
11761                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
11762             }
11763
11764             sv = newSV(0);
11765             if (overflowed) {
11766                 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
11767                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
11768                                 "%s number > %s non-portable",
11769                                 Base, max);
11770                 sv_setnv(sv, n);
11771             }
11772             else {
11773 #if UVSIZE > 4
11774                 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
11775                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
11776                                 "%s number > %s non-portable",
11777                                 Base, max);
11778 #endif
11779                 sv_setuv(sv, u);
11780             }
11781             if (just_zero && (PL_hints & HINT_NEW_INTEGER))
11782                 sv = new_constant(start, s - start, "integer",
11783                                   sv, NULL, NULL);
11784             else if (PL_hints & HINT_NEW_BINARY)
11785                 sv = new_constant(start, s - start, "binary", sv, NULL, NULL);
11786         }
11787         break;
11788
11789     /*
11790       handle decimal numbers.
11791       we're also sent here when we read a 0 as the first digit
11792     */
11793     case '1': case '2': case '3': case '4': case '5':
11794     case '6': case '7': case '8': case '9': case '.':
11795       decimal:
11796         d = PL_tokenbuf;
11797         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11798         floatit = FALSE;
11799
11800         /* read next group of digits and _ and copy into d */
11801         while (isDIGIT(*s) || *s == '_') {
11802             /* skip underscores, checking for misplaced ones
11803                if -w is on
11804             */
11805             if (*s == '_') {
11806                 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
11807                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11808                                 "Misplaced _ in number");
11809                 lastub = s++;
11810             }
11811             else {
11812                 /* check for end of fixed-length buffer */
11813                 if (d >= e)
11814                     Perl_croak(aTHX_ number_too_long);
11815                 /* if we're ok, copy the character */
11816                 *d++ = *s++;
11817             }
11818         }
11819
11820         /* final misplaced underbar check */
11821         if (lastub && s == lastub + 1) {
11822             if (ckWARN(WARN_SYNTAX))
11823                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
11824         }
11825
11826         /* read a decimal portion if there is one.  avoid
11827            3..5 being interpreted as the number 3. followed
11828            by .5
11829         */
11830         if (*s == '.' && s[1] != '.') {
11831             floatit = TRUE;
11832             *d++ = *s++;
11833
11834             if (*s == '_') {
11835                 if (ckWARN(WARN_SYNTAX))
11836                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11837                                 "Misplaced _ in number");
11838                 lastub = s;
11839             }
11840
11841             /* copy, ignoring underbars, until we run out of digits.
11842             */
11843             for (; isDIGIT(*s) || *s == '_'; s++) {
11844                 /* fixed length buffer check */
11845                 if (d >= e)
11846                     Perl_croak(aTHX_ number_too_long);
11847                 if (*s == '_') {
11848                    if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
11849                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11850                                    "Misplaced _ in number");
11851                    lastub = s;
11852                 }
11853                 else
11854                     *d++ = *s;
11855             }
11856             /* fractional part ending in underbar? */
11857             if (s[-1] == '_') {
11858                 if (ckWARN(WARN_SYNTAX))
11859                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11860                                 "Misplaced _ in number");
11861             }
11862             if (*s == '.' && isDIGIT(s[1])) {
11863                 /* oops, it's really a v-string, but without the "v" */
11864                 s = start;
11865                 goto vstring;
11866             }
11867         }
11868
11869         /* read exponent part, if present */
11870         if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
11871             floatit = TRUE;
11872             s++;
11873
11874             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
11875             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
11876
11877             /* stray preinitial _ */
11878             if (*s == '_') {
11879                 if (ckWARN(WARN_SYNTAX))
11880                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11881                                 "Misplaced _ in number");
11882                 lastub = s++;
11883             }
11884
11885             /* allow positive or negative exponent */
11886             if (*s == '+' || *s == '-')
11887                 *d++ = *s++;
11888
11889             /* stray initial _ */
11890             if (*s == '_') {
11891                 if (ckWARN(WARN_SYNTAX))
11892                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11893                                 "Misplaced _ in number");
11894                 lastub = s++;
11895             }
11896
11897             /* read digits of exponent */
11898             while (isDIGIT(*s) || *s == '_') {
11899                 if (isDIGIT(*s)) {
11900                     if (d >= e)
11901                         Perl_croak(aTHX_ number_too_long);
11902                     *d++ = *s++;
11903                 }
11904                 else {
11905                    if (((lastub && s == lastub + 1) ||
11906                         (!isDIGIT(s[1]) && s[1] != '_'))
11907                     && ckWARN(WARN_SYNTAX))
11908                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11909                                    "Misplaced _ in number");
11910                    lastub = s++;
11911                 }
11912             }
11913         }
11914
11915
11916         /* make an sv from the string */
11917         sv = newSV(0);
11918
11919         /*
11920            We try to do an integer conversion first if no characters
11921            indicating "float" have been found.
11922          */
11923
11924         if (!floatit) {
11925             UV uv;
11926             const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11927
11928             if (flags == IS_NUMBER_IN_UV) {
11929               if (uv <= IV_MAX)
11930                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
11931               else
11932                 sv_setuv(sv, uv);
11933             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11934               if (uv <= (UV) IV_MIN)
11935                 sv_setiv(sv, -(IV)uv);
11936               else
11937                 floatit = TRUE;
11938             } else
11939               floatit = TRUE;
11940         }
11941         if (floatit) {
11942             /* terminate the string */
11943             *d = '\0';
11944             nv = Atof(PL_tokenbuf);
11945             sv_setnv(sv, nv);
11946         }
11947
11948         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
11949                        (PL_hints & HINT_NEW_INTEGER) )
11950             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
11951                               (floatit ? "float" : "integer"),
11952                               sv, NULL, NULL);
11953         break;
11954
11955     /* if it starts with a v, it could be a v-string */
11956     case 'v':
11957 vstring:
11958                 sv = newSV(5); /* preallocate storage space */
11959                 s = scan_vstring(s,sv);
11960         break;
11961     }
11962
11963     /* make the op for the constant and return */
11964
11965     if (sv)
11966         lvalp->opval = newSVOP(OP_CONST, 0, sv);
11967     else
11968         lvalp->opval = NULL;
11969
11970     return (char *)s;
11971 }
11972
11973 STATIC char *
11974 S_scan_formline(pTHX_ register char *s)
11975 {
11976     dVAR;
11977     register char *eol;
11978     register char *t;
11979     SV * const stuff = newSVpvs("");
11980     bool needargs = FALSE;
11981     bool eofmt = FALSE;
11982 #ifdef PERL_MAD
11983     char *tokenstart = s;
11984     SV* savewhite;
11985
11986     if (PL_madskills) {
11987         savewhite = PL_thiswhite;
11988         PL_thiswhite = 0;
11989     }
11990 #endif
11991
11992     while (!needargs) {
11993         if (*s == '.') {
11994 #ifdef PERL_STRICT_CR
11995             for (t = s+1;SPACE_OR_TAB(*t); t++) ;
11996 #else
11997             for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
11998 #endif
11999             if (*t == '\n' || t == PL_bufend) {
12000                 eofmt = TRUE;
12001                 break;
12002             }
12003         }
12004         if (PL_in_eval && !PL_rsfp) {
12005             eol = (char *) memchr(s,'\n',PL_bufend-s);
12006             if (!eol++)
12007                 eol = PL_bufend;
12008         }
12009         else
12010             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12011         if (*s != '#') {
12012             for (t = s; t < eol; t++) {
12013                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12014                     needargs = FALSE;
12015                     goto enough;        /* ~~ must be first line in formline */
12016                 }
12017                 if (*t == '@' || *t == '^')
12018                     needargs = TRUE;
12019             }
12020             if (eol > s) {
12021                 sv_catpvn(stuff, s, eol-s);
12022 #ifndef PERL_STRICT_CR
12023                 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12024                     char *end = SvPVX(stuff) + SvCUR(stuff);
12025                     end[-2] = '\n';
12026                     end[-1] = '\0';
12027                     SvCUR_set(stuff, SvCUR(stuff) - 1);
12028                 }
12029 #endif
12030             }
12031             else
12032               break;
12033         }
12034         s = (char*)eol;
12035         if (PL_rsfp) {
12036 #ifdef PERL_MAD
12037             if (PL_madskills) {
12038                 if (PL_thistoken)
12039                     sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12040                 else
12041                     PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12042             }
12043 #endif
12044             s = filter_gets(PL_linestr, PL_rsfp, 0);
12045 #ifdef PERL_MAD
12046             tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12047 #else
12048             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12049 #endif
12050             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12051             PL_last_lop = PL_last_uni = NULL;
12052             if (!s) {
12053                 s = PL_bufptr;
12054                 break;
12055             }
12056         }
12057         incline(s);
12058     }
12059   enough:
12060     if (SvCUR(stuff)) {
12061         PL_expect = XTERM;
12062         if (needargs) {
12063             PL_lex_state = LEX_NORMAL;
12064             start_force(PL_curforce);
12065             NEXTVAL_NEXTTOKE.ival = 0;
12066             force_next(',');
12067         }
12068         else
12069             PL_lex_state = LEX_FORMLINE;
12070         if (!IN_BYTES) {
12071             if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12072                 SvUTF8_on(stuff);
12073             else if (PL_encoding)
12074                 sv_recode_to_utf8(stuff, PL_encoding);
12075         }
12076         start_force(PL_curforce);
12077         NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12078         force_next(THING);
12079         start_force(PL_curforce);
12080         NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12081         force_next(LSTOP);
12082     }
12083     else {
12084         SvREFCNT_dec(stuff);
12085         if (eofmt)
12086             PL_lex_formbrack = 0;
12087         PL_bufptr = s;
12088     }
12089 #ifdef PERL_MAD
12090     if (PL_madskills) {
12091         if (PL_thistoken)
12092             sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12093         else
12094             PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12095         PL_thiswhite = savewhite;
12096     }
12097 #endif
12098     return s;
12099 }
12100
12101 STATIC void
12102 S_set_csh(pTHX)
12103 {
12104 #ifdef CSH
12105     dVAR;
12106     if (!PL_cshlen)
12107         PL_cshlen = strlen(PL_cshname);
12108 #else
12109 #if defined(USE_ITHREADS)
12110     PERL_UNUSED_CONTEXT;
12111 #endif
12112 #endif
12113 }
12114
12115 I32
12116 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12117 {
12118     dVAR;
12119     const I32 oldsavestack_ix = PL_savestack_ix;
12120     CV* const outsidecv = PL_compcv;
12121
12122     if (PL_compcv) {
12123         assert(SvTYPE(PL_compcv) == SVt_PVCV);
12124     }
12125     SAVEI32(PL_subline);
12126     save_item(PL_subname);
12127     SAVESPTR(PL_compcv);
12128
12129     PL_compcv = (CV*)newSV(0);
12130     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
12131     CvFLAGS(PL_compcv) |= flags;
12132
12133     PL_subline = CopLINE(PL_curcop);
12134     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12135     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv);
12136     CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12137
12138     return oldsavestack_ix;
12139 }
12140
12141 #ifdef __SC__
12142 #pragma segment Perl_yylex
12143 #endif
12144 int
12145 Perl_yywarn(pTHX_ const char *s)
12146 {
12147     dVAR;
12148     PL_in_eval |= EVAL_WARNONLY;
12149     yyerror(s);
12150     PL_in_eval &= ~EVAL_WARNONLY;
12151     return 0;
12152 }
12153
12154 int
12155 Perl_yyerror(pTHX_ const char *s)
12156 {
12157     dVAR;
12158     const char *where = NULL;
12159     const char *context = NULL;
12160     int contlen = -1;
12161     SV *msg;
12162
12163     if (!yychar || (yychar == ';' && !PL_rsfp))
12164         where = "at EOF";
12165     else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12166       PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12167       PL_oldbufptr != PL_bufptr) {
12168         /*
12169                 Only for NetWare:
12170                 The code below is removed for NetWare because it abends/crashes on NetWare
12171                 when the script has error such as not having the closing quotes like:
12172                     if ($var eq "value)
12173                 Checking of white spaces is anyway done in NetWare code.
12174         */
12175 #ifndef NETWARE
12176         while (isSPACE(*PL_oldoldbufptr))
12177             PL_oldoldbufptr++;
12178 #endif
12179         context = PL_oldoldbufptr;
12180         contlen = PL_bufptr - PL_oldoldbufptr;
12181     }
12182     else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12183       PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12184         /*
12185                 Only for NetWare:
12186                 The code below is removed for NetWare because it abends/crashes on NetWare
12187                 when the script has error such as not having the closing quotes like:
12188                     if ($var eq "value)
12189                 Checking of white spaces is anyway done in NetWare code.
12190         */
12191 #ifndef NETWARE
12192         while (isSPACE(*PL_oldbufptr))
12193             PL_oldbufptr++;
12194 #endif
12195         context = PL_oldbufptr;
12196         contlen = PL_bufptr - PL_oldbufptr;
12197     }
12198     else if (yychar > 255)
12199         where = "next token ???";
12200     else if (yychar == -2) { /* YYEMPTY */
12201         if (PL_lex_state == LEX_NORMAL ||
12202            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12203             where = "at end of line";
12204         else if (PL_lex_inpat)
12205             where = "within pattern";
12206         else
12207             where = "within string";
12208     }
12209     else {
12210         SV * const where_sv = sv_2mortal(newSVpvs("next char "));
12211         if (yychar < 32)
12212             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12213         else if (isPRINT_LC(yychar))
12214             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
12215         else
12216             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12217         where = SvPVX_const(where_sv);
12218     }
12219     msg = sv_2mortal(newSVpv(s, 0));
12220     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12221         OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12222     if (context)
12223         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12224     else
12225         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12226     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12227         Perl_sv_catpvf(aTHX_ msg,
12228         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12229                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12230         PL_multi_end = 0;
12231     }
12232     if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
12233         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
12234     else
12235         qerror(msg);
12236     if (PL_error_count >= 10) {
12237         if (PL_in_eval && SvCUR(ERRSV))
12238             Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12239             ERRSV, OutCopFILE(PL_curcop));
12240         else
12241             Perl_croak(aTHX_ "%s has too many errors.\n",
12242             OutCopFILE(PL_curcop));
12243     }
12244     PL_in_my = 0;
12245     PL_in_my_stash = NULL;
12246     return 0;
12247 }
12248 #ifdef __SC__
12249 #pragma segment Main
12250 #endif
12251
12252 STATIC char*
12253 S_swallow_bom(pTHX_ U8 *s)
12254 {
12255     dVAR;
12256     const STRLEN slen = SvCUR(PL_linestr);
12257     switch (s[0]) {
12258     case 0xFF:
12259         if (s[1] == 0xFE) {
12260             /* UTF-16 little-endian? (or UTF32-LE?) */
12261             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
12262                 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12263 #ifndef PERL_NO_UTF16_FILTER
12264             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12265             s += 2;
12266         utf16le:
12267             if (PL_bufend > (char*)s) {
12268                 U8 *news;
12269                 I32 newlen;
12270
12271                 filter_add(utf16rev_textfilter, NULL);
12272                 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12273                 utf16_to_utf8_reversed(s, news,
12274                                        PL_bufend - (char*)s - 1,
12275                                        &newlen);
12276                 sv_setpvn(PL_linestr, (const char*)news, newlen);
12277 #ifdef PERL_MAD
12278                 s = (U8*)SvPVX(PL_linestr);
12279                 Copy(news, s, newlen, U8);
12280                 s[newlen] = '\0';
12281 #endif
12282                 Safefree(news);
12283                 SvUTF8_on(PL_linestr);
12284                 s = (U8*)SvPVX(PL_linestr);
12285 #ifdef PERL_MAD
12286                 /* FIXME - is this a general bug fix?  */
12287                 s[newlen] = '\0';
12288 #endif
12289                 PL_bufend = SvPVX(PL_linestr) + newlen;
12290             }
12291 #else
12292             Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12293 #endif
12294         }
12295         break;
12296     case 0xFE:
12297         if (s[1] == 0xFF) {   /* UTF-16 big-endian? */
12298 #ifndef PERL_NO_UTF16_FILTER
12299             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12300             s += 2;
12301         utf16be:
12302             if (PL_bufend > (char *)s) {
12303                 U8 *news;
12304                 I32 newlen;
12305
12306                 filter_add(utf16_textfilter, NULL);
12307                 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12308                 utf16_to_utf8(s, news,
12309                               PL_bufend - (char*)s,
12310                               &newlen);
12311                 sv_setpvn(PL_linestr, (const char*)news, newlen);
12312                 Safefree(news);
12313                 SvUTF8_on(PL_linestr);
12314                 s = (U8*)SvPVX(PL_linestr);
12315                 PL_bufend = SvPVX(PL_linestr) + newlen;
12316             }
12317 #else
12318             Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12319 #endif
12320         }
12321         break;
12322     case 0xEF:
12323         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12324             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12325             s += 3;                      /* UTF-8 */
12326         }
12327         break;
12328     case 0:
12329         if (slen > 3) {
12330              if (s[1] == 0) {
12331                   if (s[2] == 0xFE && s[3] == 0xFF) {
12332                        /* UTF-32 big-endian */
12333                        Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12334                   }
12335              }
12336              else if (s[2] == 0 && s[3] != 0) {
12337                   /* Leading bytes
12338                    * 00 xx 00 xx
12339                    * are a good indicator of UTF-16BE. */
12340                   if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12341                   goto utf16be;
12342              }
12343         }
12344     default:
12345          if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12346                   /* Leading bytes
12347                    * xx 00 xx 00
12348                    * are a good indicator of UTF-16LE. */
12349               if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12350               goto utf16le;
12351          }
12352     }
12353     return (char*)s;
12354 }
12355
12356 /*
12357  * restore_rsfp
12358  * Restore a source filter.
12359  */
12360
12361 static void
12362 restore_rsfp(pTHX_ void *f)
12363 {
12364     dVAR;
12365     PerlIO * const fp = (PerlIO*)f;
12366
12367     if (PL_rsfp == PerlIO_stdin())
12368         PerlIO_clearerr(PL_rsfp);
12369     else if (PL_rsfp && (PL_rsfp != fp))
12370         PerlIO_close(PL_rsfp);
12371     PL_rsfp = fp;
12372 }
12373
12374 #ifndef PERL_NO_UTF16_FILTER
12375 static I32
12376 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12377 {
12378     dVAR;
12379     const STRLEN old = SvCUR(sv);
12380     const I32 count = FILTER_READ(idx+1, sv, maxlen);
12381     DEBUG_P(PerlIO_printf(Perl_debug_log,
12382                           "utf16_textfilter(%p): %d %d (%d)\n",
12383                           utf16_textfilter, idx, maxlen, (int) count));
12384     if (count) {
12385         U8* tmps;
12386         I32 newlen;
12387         Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12388         Copy(SvPVX_const(sv), tmps, old, char);
12389         utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12390                       SvCUR(sv) - old, &newlen);
12391         sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12392     }
12393     DEBUG_P({sv_dump(sv);});
12394     return SvCUR(sv);
12395 }
12396
12397 static I32
12398 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12399 {
12400     dVAR;
12401     const STRLEN old = SvCUR(sv);
12402     const I32 count = FILTER_READ(idx+1, sv, maxlen);
12403     DEBUG_P(PerlIO_printf(Perl_debug_log,
12404                           "utf16rev_textfilter(%p): %d %d (%d)\n",
12405                           utf16rev_textfilter, idx, maxlen, (int) count));
12406     if (count) {
12407         U8* tmps;
12408         I32 newlen;
12409         Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12410         Copy(SvPVX_const(sv), tmps, old, char);
12411         utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12412                       SvCUR(sv) - old, &newlen);
12413         sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12414     }
12415     DEBUG_P({ sv_dump(sv); });
12416     return count;
12417 }
12418 #endif
12419
12420 /*
12421 Returns a pointer to the next character after the parsed
12422 vstring, as well as updating the passed in sv.
12423
12424 Function must be called like
12425
12426         sv = newSV(5);
12427         s = scan_vstring(s,sv);
12428
12429 The sv should already be large enough to store the vstring
12430 passed in, for performance reasons.
12431
12432 */
12433
12434 char *
12435 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
12436 {
12437     dVAR;
12438     const char *pos = s;
12439     const char *start = s;
12440     if (*pos == 'v') pos++;  /* get past 'v' */
12441     while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12442         pos++;
12443     if ( *pos != '.') {
12444         /* this may not be a v-string if followed by => */
12445         const char *next = pos;
12446         while (next < PL_bufend && isSPACE(*next))
12447             ++next;
12448         if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
12449             /* return string not v-string */
12450             sv_setpvn(sv,(char *)s,pos-s);
12451             return (char *)pos;
12452         }
12453     }
12454
12455     if (!isALPHA(*pos)) {
12456         U8 tmpbuf[UTF8_MAXBYTES+1];
12457
12458         if (*s == 'v')
12459             s++;  /* get past 'v' */
12460
12461         sv_setpvn(sv, "", 0);
12462
12463         for (;;) {
12464             /* this is atoi() that tolerates underscores */
12465             U8 *tmpend;
12466             UV rev = 0;
12467             const char *end = pos;
12468             UV mult = 1;
12469             while (--end >= s) {
12470                 if (*end != '_') {
12471                     const UV orev = rev;
12472                     rev += (*end - '0') * mult;
12473                     mult *= 10;
12474                     if (orev > rev && ckWARN_d(WARN_OVERFLOW))
12475                         Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12476                                     "Integer overflow in decimal number");
12477                 }
12478             }
12479 #ifdef EBCDIC
12480             if (rev > 0x7FFFFFFF)
12481                  Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
12482 #endif
12483             /* Append native character for the rev point */
12484             tmpend = uvchr_to_utf8(tmpbuf, rev);
12485             sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12486             if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
12487                  SvUTF8_on(sv);
12488             if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
12489                  s = ++pos;
12490             else {
12491                  s = pos;
12492                  break;
12493             }
12494             while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12495                  pos++;
12496         }
12497         SvPOK_on(sv);
12498         sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12499         SvRMAGICAL_on(sv);
12500     }
12501     return (char *)s;
12502 }
12503
12504 /*
12505  * Local variables:
12506  * c-indentation-style: bsd
12507  * c-basic-offset: 4
12508  * indent-tabs-mode: t
12509  * End:
12510  *
12511  * ex: set ts=8 sts=4 sw=4 noet:
12512  */