toke.c

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