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