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