toke.c

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