toke.c

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