toke.c

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