toke.c

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