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