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