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