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