toke.c

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