toke.c

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