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