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         orig_keyword = 0;
4090         gv = Nullgv;
4091         gvp = 0;
4092
4093         PL_bufptr = s;
4094         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4095
4096         /* Some keywords can be followed by any delimiter, including ':' */
4097         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
4098                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
4099                              (PL_tokenbuf[0] == 'q' &&
4100                               strchr("qwxr", PL_tokenbuf[1])))));
4101
4102         /* x::* is just a word, unless x is "CORE" */
4103         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4104             goto just_a_word;
4105
4106         d = s;
4107         while (d < PL_bufend && isSPACE(*d))
4108                 d++;    /* no comments skipped here, or s### is misparsed */
4109
4110         /* Is this a label? */
4111         if (!tmp && PL_expect == XSTATE
4112               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4113             s = d + 1;
4114             yylval.pval = savepv(PL_tokenbuf);
4115             CLINE;
4116             TOKEN(LABEL);
4117         }
4118
4119         /* Check for keywords */
4120         tmp = keyword(PL_tokenbuf, len);
4121
4122         /* Is this a word before a => operator? */
4123         if (*d == '=' && d[1] == '>') {
4124             CLINE;
4125             yylval.opval
4126                 = (OP*)newSVOP(OP_CONST, 0,
4127                                S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
4128             yylval.opval->op_private = OPpCONST_BARE;
4129             TERM(WORD);
4130         }
4131
4132         if (tmp < 0) {                  /* second-class keyword? */
4133             GV *ogv = Nullgv;   /* override (winner) */
4134             GV *hgv = Nullgv;   /* hidden (loser) */
4135             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4136                 CV *cv;
4137                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
4138                     (cv = GvCVu(gv)))
4139                 {
4140                     if (GvIMPORTED_CV(gv))
4141                         ogv = gv;
4142                     else if (! CvMETHOD(cv))
4143                         hgv = gv;
4144                 }
4145                 if (!ogv &&
4146                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4147                     (gv = *gvp) != (GV*)&PL_sv_undef &&
4148                     GvCVu(gv) && GvIMPORTED_CV(gv))
4149                 {
4150                     ogv = gv;
4151                 }
4152             }
4153             if (ogv) {
4154                 orig_keyword = tmp;
4155                 tmp = 0;                /* overridden by import or by GLOBAL */
4156             }
4157             else if (gv && !gvp
4158                      && -tmp==KEY_lock  /* XXX generalizable kludge */
4159                      && GvCVu(gv)
4160                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
4161             {
4162                 tmp = 0;                /* any sub overrides "weak" keyword */
4163             }
4164             else if (gv && !gvp
4165                     && tmp == -KEY_err
4166                     && GvCVu(gv)
4167                     && PL_expect != XOPERATOR
4168                     && PL_expect != XTERMORDORDOR)
4169             {
4170                 /* any sub overrides the "err" keyword, except when really an
4171                  * operator is expected */
4172                 tmp = 0;
4173             }
4174             else {                      /* no override */
4175                 tmp = -tmp;
4176                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4177                     Perl_warner(aTHX_ packWARN(WARN_MISC),
4178                             "dump() better written as CORE::dump()");
4179                 }
4180                 gv = Nullgv;
4181                 gvp = 0;
4182                 if (hgv && tmp != KEY_x && tmp != KEY_CORE
4183                         && ckWARN(WARN_AMBIGUOUS))      /* never ambiguous */
4184                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4185                         "Ambiguous call resolved as CORE::%s(), %s",
4186                          GvENAME(hgv), "qualify as such or use &");
4187             }
4188         }
4189
4190       reserved_word:
4191         switch (tmp) {
4192
4193         default:                        /* not a keyword */
4194           just_a_word: {
4195                 SV *sv;
4196                 int pkgname = 0;
4197                 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
4198
4199                 /* Get the rest if it looks like a package qualifier */
4200
4201                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
4202                     STRLEN morelen;
4203                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
4204                                   TRUE, &morelen);
4205                     if (!morelen)
4206                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
4207                                 *s == '\'' ? "'" : "::");
4208                     len += morelen;
4209                     pkgname = 1;
4210                 }
4211
4212                 if (PL_expect == XOPERATOR) {
4213                     if (PL_bufptr == PL_linestart) {
4214                         CopLINE_dec(PL_curcop);
4215                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4216                         CopLINE_inc(PL_curcop);
4217                     }
4218                     else
4219                         no_op("Bareword",s);
4220                 }
4221
4222                 /* Look for a subroutine with this name in current package,
4223                    unless name is "Foo::", in which case Foo is a bearword
4224                    (and a package name). */
4225
4226                 if (len > 2 &&
4227                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
4228                 {
4229                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
4230                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
4231                             "Bareword \"%s\" refers to nonexistent package",
4232                              PL_tokenbuf);
4233                     len -= 2;
4234                     PL_tokenbuf[len] = '\0';
4235                     gv = Nullgv;
4236                     gvp = 0;
4237                 }
4238                 else {
4239                     len = 0;
4240                     if (!gv)
4241                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
4242                 }
4243
4244                 /* if we saw a global override before, get the right name */
4245
4246                 if (gvp) {
4247                     sv = newSVpvn("CORE::GLOBAL::",14);
4248                     sv_catpv(sv,PL_tokenbuf);
4249                 }
4250                 else {
4251                     /* If len is 0, newSVpv does strlen(), which is correct.
4252                        If len is non-zero, then it will be the true length,
4253                        and so the scalar will be created correctly.  */
4254                     sv = newSVpv(PL_tokenbuf,len);
4255                 }
4256
4257                 /* Presume this is going to be a bareword of some sort. */
4258
4259                 CLINE;
4260                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4261                 yylval.opval->op_private = OPpCONST_BARE;
4262                 /* UTF-8 package name? */
4263                 if (UTF && !IN_BYTES &&
4264                     is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
4265                     SvUTF8_on(sv);
4266
4267                 /* And if "Foo::", then that's what it certainly is. */
4268
4269                 if (len)
4270                     goto safe_bareword;
4271
4272                 /* See if it's the indirect object for a list operator. */
4273
4274                 if (PL_oldoldbufptr &&
4275                     PL_oldoldbufptr < PL_bufptr &&
4276                     (PL_oldoldbufptr == PL_last_lop
4277                      || PL_oldoldbufptr == PL_last_uni) &&
4278                     /* NO SKIPSPACE BEFORE HERE! */
4279                     (PL_expect == XREF ||
4280                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4281                 {
4282                     bool immediate_paren = *s == '(';
4283
4284                     /* (Now we can afford to cross potential line boundary.) */
4285                     s = skipspace(s);
4286
4287                     /* Two barewords in a row may indicate method call. */
4288
4289                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4290                         return REPORT(tmp);
4291
4292                     /* If not a declared subroutine, it's an indirect object. */
4293                     /* (But it's an indir obj regardless for sort.) */
4294                     /* Also, if "_" follows a filetest operator, it's a bareword */
4295
4296                     if (
4297                         ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4298                          ((!gv || !GvCVu(gv)) &&
4299                         (PL_last_lop_op != OP_MAPSTART &&
4300                          PL_last_lop_op != OP_GREPSTART))))
4301                        || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
4302                             && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
4303                        )
4304                     {
4305                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4306                         goto bareword;
4307                     }
4308                 }
4309
4310                 PL_expect = XOPERATOR;
4311                 s = skipspace(s);
4312
4313                 /* Is this a word before a => operator? */
4314                 if (*s == '=' && s[1] == '>' && !pkgname) {
4315                     CLINE;
4316                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4317                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4318                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4319                     TERM(WORD);
4320                 }
4321
4322                 /* If followed by a paren, it's certainly a subroutine. */
4323                 if (*s == '(') {
4324                     CLINE;
4325                     if (gv && GvCVu(gv)) {
4326                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4327                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4328                             s = d + 1;
4329                             goto its_constant;
4330                         }
4331                     }
4332                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4333                     PL_expect = XOPERATOR;
4334                     force_next(WORD);
4335                     yylval.ival = 0;
4336                     TOKEN('&');
4337                 }
4338
4339                 /* If followed by var or block, call it a method (unless sub) */
4340
4341                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4342                     PL_last_lop = PL_oldbufptr;
4343                     PL_last_lop_op = OP_METHOD;
4344                     PREBLOCK(METHOD);
4345                 }
4346
4347                 /* If followed by a bareword, see if it looks like indir obj. */
4348
4349                 if (!orig_keyword
4350                         && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4351                         && (tmp = intuit_method(s,gv)))
4352                     return REPORT(tmp);
4353
4354                 /* Not a method, so call it a subroutine (if defined) */
4355
4356                 if (gv && GvCVu(gv)) {
4357                     CV* cv;
4358                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4359                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4360                                 "Ambiguous use of -%s resolved as -&%s()",
4361                                 PL_tokenbuf, PL_tokenbuf);
4362                     /* Check for a constant sub */
4363                     cv = GvCV(gv);
4364                     if ((sv = cv_const_sv(cv))) {
4365                   its_constant:
4366                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4367                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4368                         yylval.opval->op_private = 0;
4369                         TOKEN(WORD);
4370                     }
4371
4372                     /* Resolve to GV now. */
4373                     op_free(yylval.opval);
4374                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4375                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4376                     PL_last_lop = PL_oldbufptr;
4377                     PL_last_lop_op = OP_ENTERSUB;
4378                     /* Is there a prototype? */
4379                     if (SvPOK(cv)) {
4380                         STRLEN len;
4381                         const char *proto = SvPV_const((SV*)cv, len);
4382                         if (!len)
4383                             TERM(FUNC0SUB);
4384                         if (*proto == '$' && proto[1] == '\0')
4385                             OPERATOR(UNIOPSUB);
4386                         while (*proto == ';')
4387                             proto++;
4388                         if (*proto == '&' && *s == '{') {
4389                             sv_setpv(PL_subname, PL_curstash ?
4390                                         "__ANON__" : "__ANON__::__ANON__");
4391                             PREBLOCK(LSTOPSUB);
4392                         }
4393                     }
4394                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4395                     PL_expect = XTERM;
4396                     force_next(WORD);
4397                     TOKEN(NOAMP);
4398                 }
4399
4400                 /* Call it a bare word */
4401
4402                 if (PL_hints & HINT_STRICT_SUBS)
4403                     yylval.opval->op_private |= OPpCONST_STRICT;
4404                 else {
4405                 bareword:
4406                     if (lastchar != '-') {
4407                         if (ckWARN(WARN_RESERVED)) {
4408                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4409                             if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4410                                 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4411                                        PL_tokenbuf);
4412                         }
4413                     }
4414                 }
4415
4416             safe_bareword:
4417                 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
4418                     && ckWARN_d(WARN_AMBIGUOUS)) {
4419                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4420                         "Operator or semicolon missing before %c%s",
4421                         lastchar, PL_tokenbuf);
4422                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4423                         "Ambiguous use of %c resolved as operator %c",
4424                         lastchar, lastchar);
4425                 }
4426                 TOKEN(WORD);
4427             }
4428
4429         case KEY___FILE__:
4430             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4431                                         newSVpv(CopFILE(PL_curcop),0));
4432             TERM(THING);
4433
4434         case KEY___LINE__:
4435             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4436                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4437             TERM(THING);
4438
4439         case KEY___PACKAGE__:
4440             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4441                                         (PL_curstash
4442                                          ? newSVhek(HvNAME_HEK(PL_curstash))
4443                                          : &PL_sv_undef));
4444             TERM(THING);
4445
4446         case KEY___DATA__:
4447         case KEY___END__: {
4448             GV *gv;
4449             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4450                 const char *pname = "main";
4451                 if (PL_tokenbuf[2] == 'D')
4452                     pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
4453                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4454                 GvMULTI_on(gv);
4455                 if (!GvIO(gv))
4456                     GvIOp(gv) = newIO();
4457                 IoIFP(GvIOp(gv)) = PL_rsfp;
4458 #if defined(HAS_FCNTL) && defined(F_SETFD)
4459                 {
4460                     const int fd = PerlIO_fileno(PL_rsfp);
4461                     fcntl(fd,F_SETFD,fd >= 3);
4462                 }
4463 #endif
4464                 /* Mark this internal pseudo-handle as clean */
4465                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4466                 if (PL_preprocess)
4467                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4468                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4469                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4470                 else
4471                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4472 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4473                 /* if the script was opened in binmode, we need to revert
4474                  * it to text mode for compatibility; but only iff it has CRs
4475                  * XXX this is a questionable hack at best. */
4476                 if (PL_bufend-PL_bufptr > 2
4477                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4478                 {
4479                     Off_t loc = 0;
4480                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4481                         loc = PerlIO_tell(PL_rsfp);
4482                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
4483                     }
4484 #ifdef NETWARE
4485                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4486 #else
4487                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4488 #endif  /* NETWARE */
4489 #ifdef PERLIO_IS_STDIO /* really? */
4490 #  if defined(__BORLANDC__)
4491                         /* XXX see note in do_binmode() */
4492                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4493 #  endif
4494 #endif
4495                         if (loc > 0)
4496                             PerlIO_seek(PL_rsfp, loc, 0);
4497                     }
4498                 }
4499 #endif
4500 #ifdef PERLIO_LAYERS
4501                 if (!IN_BYTES) {
4502                     if (UTF)
4503                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4504                     else if (PL_encoding) {
4505                         SV *name;
4506                         dSP;
4507                         ENTER;
4508                         SAVETMPS;
4509                         PUSHMARK(sp);
4510                         EXTEND(SP, 1);
4511                         XPUSHs(PL_encoding);
4512                         PUTBACK;
4513                         call_method("name", G_SCALAR);
4514                         SPAGAIN;
4515                         name = POPs;
4516                         PUTBACK;
4517                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4518                                             Perl_form(aTHX_ ":encoding(%"SVf")",
4519                                                       name));
4520                         FREETMPS;
4521                         LEAVE;
4522                     }
4523                 }
4524 #endif
4525                 PL_rsfp = Nullfp;
4526             }
4527             goto fake_eof;
4528         }
4529
4530         case KEY_AUTOLOAD:
4531         case KEY_DESTROY:
4532         case KEY_BEGIN:
4533         case KEY_CHECK:
4534         case KEY_INIT:
4535         case KEY_END:
4536             if (PL_expect == XSTATE) {
4537                 s = PL_bufptr;
4538                 goto really_sub;
4539             }
4540             goto just_a_word;
4541
4542         case KEY_CORE:
4543             if (*s == ':' && s[1] == ':') {
4544                 s += 2;
4545                 d = s;
4546                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4547                 if (!(tmp = keyword(PL_tokenbuf, len)))
4548                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4549                 if (tmp < 0)
4550                     tmp = -tmp;
4551                 else if (tmp == KEY_require || tmp == KEY_do)
4552                     /* that's a way to remember we saw "CORE::" */
4553                     orig_keyword = tmp;
4554                 goto reserved_word;
4555             }
4556             goto just_a_word;
4557
4558         case KEY_abs:
4559             UNI(OP_ABS);
4560
4561         case KEY_alarm:
4562             UNI(OP_ALARM);
4563
4564         case KEY_accept:
4565             LOP(OP_ACCEPT,XTERM);
4566
4567         case KEY_and:
4568             OPERATOR(ANDOP);
4569
4570         case KEY_atan2:
4571             LOP(OP_ATAN2,XTERM);
4572
4573         case KEY_bind:
4574             LOP(OP_BIND,XTERM);
4575
4576         case KEY_binmode:
4577             LOP(OP_BINMODE,XTERM);
4578
4579         case KEY_bless:
4580             LOP(OP_BLESS,XTERM);
4581
4582         case KEY_break:
4583             FUN0(OP_BREAK);
4584
4585         case KEY_chop:
4586             UNI(OP_CHOP);
4587
4588         case KEY_continue:
4589             /* When 'use switch' is in effect, continue has a dual
4590                life as a control operator. */
4591             {
4592                 if (!FEATURE_IS_ENABLED("switch", 6))
4593                     PREBLOCK(CONTINUE);
4594                 else {
4595                     /* We have to disambiguate the two senses of
4596                       "continue". If the next token is a '{' then
4597                       treat it as the start of a continue block;
4598                       otherwise treat it as a control operator.
4599                      */
4600                     s = skipspace(s);
4601                     if (*s == '{')
4602             PREBLOCK(CONTINUE);
4603                     else
4604                         FUN0(OP_CONTINUE);
4605                 }
4606             }
4607
4608         case KEY_chdir:
4609             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
4610             UNI(OP_CHDIR);
4611
4612         case KEY_close:
4613             UNI(OP_CLOSE);
4614
4615         case KEY_closedir:
4616             UNI(OP_CLOSEDIR);
4617
4618         case KEY_cmp:
4619             Eop(OP_SCMP);
4620
4621         case KEY_caller:
4622             UNI(OP_CALLER);
4623
4624         case KEY_crypt:
4625 #ifdef FCRYPT
4626             if (!PL_cryptseen) {
4627                 PL_cryptseen = TRUE;
4628                 init_des();
4629             }
4630 #endif
4631             LOP(OP_CRYPT,XTERM);
4632
4633         case KEY_chmod:
4634             LOP(OP_CHMOD,XTERM);
4635
4636         case KEY_chown:
4637             LOP(OP_CHOWN,XTERM);
4638
4639         case KEY_connect:
4640             LOP(OP_CONNECT,XTERM);
4641
4642         case KEY_chr:
4643             UNI(OP_CHR);
4644
4645         case KEY_cos:
4646             UNI(OP_COS);
4647
4648         case KEY_chroot:
4649             UNI(OP_CHROOT);
4650
4651         case KEY_default:
4652             PREBLOCK(DEFAULT);
4653
4654         case KEY_do:
4655             s = skipspace(s);
4656             if (*s == '{')
4657                 PRETERMBLOCK(DO);
4658             if (*s != '\'')
4659                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4660             if (orig_keyword == KEY_do) {
4661                 orig_keyword = 0;
4662                 yylval.ival = 1;
4663             }
4664             else
4665                 yylval.ival = 0;
4666             OPERATOR(DO);
4667
4668         case KEY_die:
4669             PL_hints |= HINT_BLOCK_SCOPE;
4670             LOP(OP_DIE,XTERM);
4671
4672         case KEY_defined:
4673             UNI(OP_DEFINED);
4674
4675         case KEY_delete:
4676             UNI(OP_DELETE);
4677
4678         case KEY_dbmopen:
4679             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4680             LOP(OP_DBMOPEN,XTERM);
4681
4682         case KEY_dbmclose:
4683             UNI(OP_DBMCLOSE);
4684
4685         case KEY_dump:
4686             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4687             LOOPX(OP_DUMP);
4688
4689         case KEY_else:
4690             PREBLOCK(ELSE);
4691
4692         case KEY_elsif:
4693             yylval.ival = CopLINE(PL_curcop);
4694             OPERATOR(ELSIF);
4695
4696         case KEY_eq:
4697             Eop(OP_SEQ);
4698
4699         case KEY_exists:
4700             UNI(OP_EXISTS);
4701
4702         case KEY_exit:
4703             UNI(OP_EXIT);
4704
4705         case KEY_eval:
4706             s = skipspace(s);
4707             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4708             UNIBRACK(OP_ENTEREVAL);
4709
4710         case KEY_eof:
4711             UNI(OP_EOF);
4712
4713         case KEY_err:
4714             OPERATOR(DOROP);
4715
4716         case KEY_exp:
4717             UNI(OP_EXP);
4718
4719         case KEY_each:
4720             UNI(OP_EACH);
4721
4722         case KEY_exec:
4723             set_csh();
4724             LOP(OP_EXEC,XREF);
4725
4726         case KEY_endhostent:
4727             FUN0(OP_EHOSTENT);
4728
4729         case KEY_endnetent:
4730             FUN0(OP_ENETENT);
4731
4732         case KEY_endservent:
4733             FUN0(OP_ESERVENT);
4734
4735         case KEY_endprotoent:
4736             FUN0(OP_EPROTOENT);
4737
4738         case KEY_endpwent:
4739             FUN0(OP_EPWENT);
4740
4741         case KEY_endgrent:
4742             FUN0(OP_EGRENT);
4743
4744         case KEY_for:
4745         case KEY_foreach:
4746             yylval.ival = CopLINE(PL_curcop);
4747             s = skipspace(s);
4748             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4749                 char *p = s;
4750                 if ((PL_bufend - p) >= 3 &&
4751                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4752                     p += 2;
4753                 else if ((PL_bufend - p) >= 4 &&
4754                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4755                     p += 3;
4756                 p = skipspace(p);
4757                 if (isIDFIRST_lazy_if(p,UTF)) {
4758                     p = scan_ident(p, PL_bufend,
4759                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4760                     p = skipspace(p);
4761                 }
4762                 if (*p != '$')
4763                     Perl_croak(aTHX_ "Missing $ on loop variable");
4764             }
4765             OPERATOR(FOR);
4766
4767         case KEY_formline:
4768             LOP(OP_FORMLINE,XTERM);
4769
4770         case KEY_fork:
4771             FUN0(OP_FORK);
4772
4773         case KEY_fcntl:
4774             LOP(OP_FCNTL,XTERM);
4775
4776         case KEY_fileno:
4777             UNI(OP_FILENO);
4778
4779         case KEY_flock:
4780             LOP(OP_FLOCK,XTERM);
4781
4782         case KEY_gt:
4783             Rop(OP_SGT);
4784
4785         case KEY_ge:
4786             Rop(OP_SGE);
4787
4788         case KEY_grep:
4789             LOP(OP_GREPSTART, XREF);
4790
4791         case KEY_goto:
4792             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4793             LOOPX(OP_GOTO);
4794
4795         case KEY_gmtime:
4796             UNI(OP_GMTIME);
4797
4798         case KEY_getc:
4799             UNIDOR(OP_GETC);
4800
4801         case KEY_getppid:
4802             FUN0(OP_GETPPID);
4803
4804         case KEY_getpgrp:
4805             UNI(OP_GETPGRP);
4806
4807         case KEY_getpriority:
4808             LOP(OP_GETPRIORITY,XTERM);
4809
4810         case KEY_getprotobyname:
4811             UNI(OP_GPBYNAME);
4812
4813         case KEY_getprotobynumber:
4814             LOP(OP_GPBYNUMBER,XTERM);
4815
4816         case KEY_getprotoent:
4817             FUN0(OP_GPROTOENT);
4818
4819         case KEY_getpwent:
4820             FUN0(OP_GPWENT);
4821
4822         case KEY_getpwnam:
4823             UNI(OP_GPWNAM);
4824
4825         case KEY_getpwuid:
4826             UNI(OP_GPWUID);
4827
4828         case KEY_getpeername:
4829             UNI(OP_GETPEERNAME);
4830
4831         case KEY_gethostbyname:
4832             UNI(OP_GHBYNAME);
4833
4834         case KEY_gethostbyaddr:
4835             LOP(OP_GHBYADDR,XTERM);
4836
4837         case KEY_gethostent:
4838             FUN0(OP_GHOSTENT);
4839
4840         case KEY_getnetbyname:
4841             UNI(OP_GNBYNAME);
4842
4843         case KEY_getnetbyaddr:
4844             LOP(OP_GNBYADDR,XTERM);
4845
4846         case KEY_getnetent:
4847             FUN0(OP_GNETENT);
4848
4849         case KEY_getservbyname:
4850             LOP(OP_GSBYNAME,XTERM);
4851
4852         case KEY_getservbyport:
4853             LOP(OP_GSBYPORT,XTERM);
4854
4855         case KEY_getservent:
4856             FUN0(OP_GSERVENT);
4857
4858         case KEY_getsockname:
4859             UNI(OP_GETSOCKNAME);
4860
4861         case KEY_getsockopt:
4862             LOP(OP_GSOCKOPT,XTERM);
4863
4864         case KEY_getgrent:
4865             FUN0(OP_GGRENT);
4866
4867         case KEY_getgrnam:
4868             UNI(OP_GGRNAM);
4869
4870         case KEY_getgrgid:
4871             UNI(OP_GGRGID);
4872
4873         case KEY_getlogin:
4874             FUN0(OP_GETLOGIN);
4875
4876         case KEY_given:
4877             yylval.ival = CopLINE(PL_curcop);
4878             OPERATOR(GIVEN);
4879
4880         case KEY_glob:
4881             set_csh();
4882             LOP(OP_GLOB,XTERM);
4883
4884         case KEY_hex:
4885             UNI(OP_HEX);
4886
4887         case KEY_if:
4888             yylval.ival = CopLINE(PL_curcop);
4889             OPERATOR(IF);
4890
4891         case KEY_index:
4892             LOP(OP_INDEX,XTERM);
4893
4894         case KEY_int:
4895             UNI(OP_INT);
4896
4897         case KEY_ioctl:
4898             LOP(OP_IOCTL,XTERM);
4899
4900         case KEY_join:
4901             LOP(OP_JOIN,XTERM);
4902
4903         case KEY_keys:
4904             UNI(OP_KEYS);
4905
4906         case KEY_kill:
4907             LOP(OP_KILL,XTERM);
4908
4909         case KEY_last:
4910             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4911             LOOPX(OP_LAST);
4912
4913         case KEY_lc:
4914             UNI(OP_LC);
4915
4916         case KEY_lcfirst:
4917             UNI(OP_LCFIRST);
4918
4919         case KEY_local:
4920             yylval.ival = 0;
4921             OPERATOR(LOCAL);
4922
4923         case KEY_length:
4924             UNI(OP_LENGTH);
4925
4926         case KEY_lt:
4927             Rop(OP_SLT);
4928
4929         case KEY_le:
4930             Rop(OP_SLE);
4931
4932         case KEY_localtime:
4933             UNI(OP_LOCALTIME);
4934
4935         case KEY_log:
4936             UNI(OP_LOG);
4937
4938         case KEY_link:
4939             LOP(OP_LINK,XTERM);
4940
4941         case KEY_listen:
4942             LOP(OP_LISTEN,XTERM);
4943
4944         case KEY_lock:
4945             UNI(OP_LOCK);
4946
4947         case KEY_lstat:
4948             UNI(OP_LSTAT);
4949
4950         case KEY_m:
4951             s = scan_pat(s,OP_MATCH);
4952             TERM(sublex_start());
4953
4954         case KEY_map:
4955             LOP(OP_MAPSTART, XREF);
4956
4957         case KEY_mkdir:
4958             LOP(OP_MKDIR,XTERM);
4959
4960         case KEY_msgctl:
4961             LOP(OP_MSGCTL,XTERM);
4962
4963         case KEY_msgget:
4964             LOP(OP_MSGGET,XTERM);
4965
4966         case KEY_msgrcv:
4967             LOP(OP_MSGRCV,XTERM);
4968
4969         case KEY_msgsnd:
4970             LOP(OP_MSGSND,XTERM);
4971
4972         case KEY_our:
4973         case KEY_my:
4974             PL_in_my = tmp;
4975             s = skipspace(s);
4976             if (isIDFIRST_lazy_if(s,UTF)) {
4977                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4978                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4979                     goto really_sub;
4980                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4981                 if (!PL_in_my_stash) {
4982                     char tmpbuf[1024];
4983                     PL_bufptr = s;
4984                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4985                     yyerror(tmpbuf);
4986                 }
4987             }
4988             yylval.ival = 1;
4989             OPERATOR(MY);
4990
4991         case KEY_next:
4992             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4993             LOOPX(OP_NEXT);
4994
4995         case KEY_ne:
4996             Eop(OP_SNE);
4997
4998         case KEY_no:
4999             s = tokenize_use(0, s);
5000             OPERATOR(USE);
5001
5002         case KEY_not:
5003             if (*s == '(' || (s = skipspace(s), *s == '('))
5004                 FUN1(OP_NOT);
5005             else
5006                 OPERATOR(NOTOP);
5007
5008         case KEY_open:
5009             s = skipspace(s);
5010             if (isIDFIRST_lazy_if(s,UTF)) {
5011                 const char *t;
5012                 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
5013                 for (t=d; *t && isSPACE(*t); t++) ;
5014                 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
5015                     /* [perl #16184] */
5016                     && !(t[0] == '=' && t[1] == '>')
5017                 ) {
5018                     int len = (int)(d-s);
5019                     Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5020                            "Precedence problem: open %.*s should be open(%.*s)",
5021                             len, s, len, s);
5022                 }
5023             }
5024             LOP(OP_OPEN,XTERM);
5025
5026         case KEY_or:
5027             yylval.ival = OP_OR;
5028             OPERATOR(OROP);
5029
5030         case KEY_ord:
5031             UNI(OP_ORD);
5032
5033         case KEY_oct:
5034             UNI(OP_OCT);
5035
5036         case KEY_opendir:
5037             LOP(OP_OPEN_DIR,XTERM);
5038
5039         case KEY_print:
5040             checkcomma(s,PL_tokenbuf,"filehandle");
5041             LOP(OP_PRINT,XREF);
5042
5043         case KEY_printf:
5044             checkcomma(s,PL_tokenbuf,"filehandle");
5045             LOP(OP_PRTF,XREF);
5046
5047         case KEY_prototype:
5048             UNI(OP_PROTOTYPE);
5049
5050         case KEY_push:
5051             LOP(OP_PUSH,XTERM);
5052
5053         case KEY_pop:
5054             UNIDOR(OP_POP);
5055
5056         case KEY_pos:
5057             UNIDOR(OP_POS);
5058
5059         case KEY_pack:
5060             LOP(OP_PACK,XTERM);
5061
5062         case KEY_package:
5063             s = force_word(s,WORD,FALSE,TRUE,FALSE);
5064             OPERATOR(PACKAGE);
5065
5066         case KEY_pipe:
5067             LOP(OP_PIPE_OP,XTERM);
5068
5069         case KEY_q:
5070             s = scan_str(s,FALSE,FALSE);
5071             if (!s)
5072                 missingterm((char*)0);
5073             yylval.ival = OP_CONST;
5074             TERM(sublex_start());
5075
5076         case KEY_quotemeta:
5077             UNI(OP_QUOTEMETA);
5078
5079         case KEY_qw:
5080             s = scan_str(s,FALSE,FALSE);
5081             if (!s)
5082                 missingterm((char*)0);
5083             PL_expect = XOPERATOR;
5084             force_next(')');
5085             if (SvCUR(PL_lex_stuff)) {
5086                 OP *words = Nullop;
5087                 int warned = 0;
5088                 d = SvPV_force(PL_lex_stuff, len);
5089                 while (len) {
5090                     SV *sv;
5091                     for (; isSPACE(*d) && len; --len, ++d) ;
5092                     if (len) {
5093                         const char *b = d;
5094                         if (!warned && ckWARN(WARN_QW)) {
5095                             for (; !isSPACE(*d) && len; --len, ++d) {
5096                                 if (*d == ',') {
5097                                     Perl_warner(aTHX_ packWARN(WARN_QW),
5098                                         "Possible attempt to separate words with commas");
5099                                     ++warned;
5100                                 }
5101                                 else if (*d == '#') {
5102                                     Perl_warner(aTHX_ packWARN(WARN_QW),
5103                                         "Possible attempt to put comments in qw() list");
5104                                     ++warned;
5105                                 }
5106                             }
5107                         }
5108                         else {
5109                             for (; !isSPACE(*d) && len; --len, ++d) ;
5110                         }
5111                         sv = newSVpvn(b, d-b);
5112                         if (DO_UTF8(PL_lex_stuff))
5113                             SvUTF8_on(sv);
5114                         words = append_elem(OP_LIST, words,
5115                                             newSVOP(OP_CONST, 0, tokeq(sv)));
5116                     }
5117                 }
5118                 if (words) {
5119                     PL_nextval[PL_nexttoke].opval = words;
5120                     force_next(THING);
5121                 }
5122             }
5123             if (PL_lex_stuff) {
5124                 SvREFCNT_dec(PL_lex_stuff);
5125                 PL_lex_stuff = Nullsv;
5126             }
5127             PL_expect = XTERM;
5128             TOKEN('(');
5129
5130         case KEY_qq:
5131             s = scan_str(s,FALSE,FALSE);
5132             if (!s)
5133                 missingterm((char*)0);
5134             yylval.ival = OP_STRINGIFY;
5135             if (SvIVX(PL_lex_stuff) == '\'')
5136                 SvIV_set(PL_lex_stuff, 0);      /* qq'$foo' should intepolate */
5137             TERM(sublex_start());
5138
5139         case KEY_qr:
5140             s = scan_pat(s,OP_QR);
5141             TERM(sublex_start());
5142
5143         case KEY_qx:
5144             s = scan_str(s,FALSE,FALSE);
5145             if (!s)
5146                 missingterm((char*)0);
5147             yylval.ival = OP_BACKTICK;
5148             set_csh();
5149             TERM(sublex_start());
5150
5151         case KEY_return:
5152             OLDLOP(OP_RETURN);
5153
5154         case KEY_require:
5155             s = skipspace(s);
5156             if (isDIGIT(*s)) {
5157                 s = force_version(s, FALSE);
5158             }
5159             else if (*s != 'v' || !isDIGIT(s[1])
5160                     || (s = force_version(s, TRUE), *s == 'v'))
5161             {
5162                 *PL_tokenbuf = '\0';
5163                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5164                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
5165                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
5166                 else if (*s == '<')
5167                     yyerror("<> should be quotes");
5168             }
5169             if (orig_keyword == KEY_require) {
5170                 orig_keyword = 0;
5171                 yylval.ival = 1;
5172             }
5173             else
5174                 yylval.ival = 0;
5175             PL_expect = XTERM;
5176             PL_bufptr = s;
5177             PL_last_uni = PL_oldbufptr;
5178             PL_last_lop_op = OP_REQUIRE;
5179             s = skipspace(s);
5180             return REPORT( (int)REQUIRE );
5181
5182         case KEY_reset:
5183             UNI(OP_RESET);
5184
5185         case KEY_redo:
5186             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5187             LOOPX(OP_REDO);
5188
5189         case KEY_rename:
5190             LOP(OP_RENAME,XTERM);
5191
5192         case KEY_rand:
5193             UNI(OP_RAND);
5194
5195         case KEY_rmdir:
5196             UNI(OP_RMDIR);
5197
5198         case KEY_rindex:
5199             LOP(OP_RINDEX,XTERM);
5200
5201         case KEY_read:
5202             LOP(OP_READ,XTERM);
5203
5204         case KEY_readdir:
5205             UNI(OP_READDIR);
5206
5207         case KEY_readline:
5208             set_csh();
5209             UNIDOR(OP_READLINE);
5210
5211         case KEY_readpipe:
5212             set_csh();
5213             UNI(OP_BACKTICK);
5214
5215         case KEY_rewinddir:
5216             UNI(OP_REWINDDIR);
5217
5218         case KEY_recv:
5219             LOP(OP_RECV,XTERM);
5220
5221         case KEY_reverse:
5222             LOP(OP_REVERSE,XTERM);
5223
5224         case KEY_readlink:
5225             UNIDOR(OP_READLINK);
5226
5227         case KEY_ref:
5228             UNI(OP_REF);
5229
5230         case KEY_s:
5231             s = scan_subst(s);
5232             if (yylval.opval)
5233                 TERM(sublex_start());
5234             else
5235                 TOKEN(1);       /* force error */
5236
5237         case KEY_say:
5238             checkcomma(s,PL_tokenbuf,"filehandle");
5239             LOP(OP_SAY,XREF);
5240
5241         case KEY_chomp:
5242             UNI(OP_CHOMP);
5243
5244         case KEY_scalar:
5245             UNI(OP_SCALAR);
5246
5247         case KEY_select:
5248             LOP(OP_SELECT,XTERM);
5249
5250         case KEY_seek:
5251             LOP(OP_SEEK,XTERM);
5252
5253         case KEY_semctl:
5254             LOP(OP_SEMCTL,XTERM);
5255
5256         case KEY_semget:
5257             LOP(OP_SEMGET,XTERM);
5258
5259         case KEY_semop:
5260             LOP(OP_SEMOP,XTERM);
5261
5262         case KEY_send:
5263             LOP(OP_SEND,XTERM);
5264
5265         case KEY_setpgrp:
5266             LOP(OP_SETPGRP,XTERM);
5267
5268         case KEY_setpriority:
5269             LOP(OP_SETPRIORITY,XTERM);
5270
5271         case KEY_sethostent:
5272             UNI(OP_SHOSTENT);
5273
5274         case KEY_setnetent:
5275             UNI(OP_SNETENT);
5276
5277         case KEY_setservent:
5278             UNI(OP_SSERVENT);
5279
5280         case KEY_setprotoent:
5281             UNI(OP_SPROTOENT);
5282
5283         case KEY_setpwent:
5284             FUN0(OP_SPWENT);
5285
5286         case KEY_setgrent:
5287             FUN0(OP_SGRENT);
5288
5289         case KEY_seekdir:
5290             LOP(OP_SEEKDIR,XTERM);
5291
5292         case KEY_setsockopt:
5293             LOP(OP_SSOCKOPT,XTERM);
5294
5295         case KEY_shift:
5296             UNIDOR(OP_SHIFT);
5297
5298         case KEY_shmctl:
5299             LOP(OP_SHMCTL,XTERM);
5300
5301         case KEY_shmget:
5302             LOP(OP_SHMGET,XTERM);
5303
5304         case KEY_shmread:
5305             LOP(OP_SHMREAD,XTERM);
5306
5307         case KEY_shmwrite:
5308             LOP(OP_SHMWRITE,XTERM);
5309
5310         case KEY_shutdown:
5311             LOP(OP_SHUTDOWN,XTERM);
5312
5313         case KEY_sin:
5314             UNI(OP_SIN);
5315
5316         case KEY_sleep:
5317             UNI(OP_SLEEP);
5318
5319         case KEY_socket:
5320             LOP(OP_SOCKET,XTERM);
5321
5322         case KEY_socketpair:
5323             LOP(OP_SOCKPAIR,XTERM);
5324
5325         case KEY_sort:
5326             checkcomma(s,PL_tokenbuf,"subroutine name");
5327             s = skipspace(s);
5328             if (*s == ';' || *s == ')')         /* probably a close */
5329                 Perl_croak(aTHX_ "sort is now a reserved word");
5330             PL_expect = XTERM;
5331             s = force_word(s,WORD,TRUE,TRUE,FALSE);
5332             LOP(OP_SORT,XREF);
5333
5334         case KEY_split:
5335             LOP(OP_SPLIT,XTERM);
5336
5337         case KEY_sprintf:
5338             LOP(OP_SPRINTF,XTERM);
5339
5340         case KEY_splice:
5341             LOP(OP_SPLICE,XTERM);
5342
5343         case KEY_sqrt:
5344             UNI(OP_SQRT);
5345
5346         case KEY_srand:
5347             UNI(OP_SRAND);
5348
5349         case KEY_stat:
5350             UNI(OP_STAT);
5351
5352         case KEY_study:
5353             UNI(OP_STUDY);
5354
5355         case KEY_substr:
5356             LOP(OP_SUBSTR,XTERM);
5357
5358         case KEY_format:
5359         case KEY_sub:
5360           really_sub:
5361             {
5362                 char tmpbuf[sizeof PL_tokenbuf];
5363                 SSize_t tboffset = 0;
5364                 expectation attrful;
5365                 bool have_name, have_proto, bad_proto;
5366                 const int key = tmp;
5367
5368                 s = skipspace(s);
5369
5370                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5371                     (*s == ':' && s[1] == ':'))
5372                 {
5373                     PL_expect = XBLOCK;
5374                     attrful = XATTRBLOCK;
5375                     /* remember buffer pos'n for later force_word */
5376                     tboffset = s - PL_oldbufptr;
5377                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5378                     if (strchr(tmpbuf, ':'))
5379                         sv_setpv(PL_subname, tmpbuf);
5380                     else {
5381                         sv_setsv(PL_subname,PL_curstname);
5382                         sv_catpvn(PL_subname,"::",2);
5383                         sv_catpvn(PL_subname,tmpbuf,len);
5384                     }
5385                     s = skipspace(d);
5386                     have_name = TRUE;
5387                 }
5388                 else {
5389                     if (key == KEY_my)
5390                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
5391                     PL_expect = XTERMBLOCK;
5392                     attrful = XATTRTERM;
5393                     sv_setpvn(PL_subname,"?",1);
5394                     have_name = FALSE;
5395                 }
5396
5397                 if (key == KEY_format) {
5398                     if (*s == '=')
5399                         PL_lex_formbrack = PL_lex_brackets + 1;
5400                     if (have_name)
5401                         (void) force_word(PL_oldbufptr + tboffset, WORD,
5402                                           FALSE, TRUE, TRUE);
5403                     OPERATOR(FORMAT);
5404                 }
5405
5406                 /* Look for a prototype */
5407                 if (*s == '(') {
5408                     char *p;
5409
5410                     s = scan_str(s,FALSE,FALSE);
5411                     if (!s)
5412                         Perl_croak(aTHX_ "Prototype not terminated");
5413                     /* strip spaces and check for bad characters */
5414                     d = SvPVX(PL_lex_stuff);
5415                     tmp = 0;
5416                     bad_proto = FALSE;
5417                     for (p = d; *p; ++p) {
5418                         if (!isSPACE(*p)) {
5419                             d[tmp++] = *p;
5420                             if (!strchr("$@%*;[]&\\", *p))
5421                                 bad_proto = TRUE;
5422                         }
5423                     }
5424                     d[tmp] = '\0';
5425                     if (bad_proto && ckWARN(WARN_SYNTAX))
5426                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5427                                     "Illegal character in prototype for %"SVf" : %s",
5428                                     PL_subname, d);
5429                     SvCUR_set(PL_lex_stuff, tmp);
5430                     have_proto = TRUE;
5431
5432                     s = skipspace(s);
5433                 }
5434                 else
5435                     have_proto = FALSE;
5436
5437                 if (*s == ':' && s[1] != ':')
5438                     PL_expect = attrful;
5439                 else if (*s != '{' && key == KEY_sub) {
5440                     if (!have_name)
5441                         Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5442                     else if (*s != ';')
5443                         Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
5444                 }
5445
5446                 if (have_proto) {
5447                     PL_nextval[PL_nexttoke].opval =
5448                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5449                     PL_lex_stuff = Nullsv;
5450                     force_next(THING);
5451                 }
5452                 if (!have_name) {
5453                     sv_setpv(PL_subname,
5454                         PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5455                     TOKEN(ANONSUB);
5456                 }
5457                 (void) force_word(PL_oldbufptr + tboffset, WORD,
5458                                   FALSE, TRUE, TRUE);
5459                 if (key == KEY_my)
5460                     TOKEN(MYSUB);
5461                 TOKEN(SUB);
5462             }
5463
5464         case KEY_system:
5465             set_csh();
5466             LOP(OP_SYSTEM,XREF);
5467
5468         case KEY_symlink:
5469             LOP(OP_SYMLINK,XTERM);
5470
5471         case KEY_syscall:
5472             LOP(OP_SYSCALL,XTERM);
5473
5474         case KEY_sysopen:
5475             LOP(OP_SYSOPEN,XTERM);
5476
5477         case KEY_sysseek:
5478             LOP(OP_SYSSEEK,XTERM);
5479
5480         case KEY_sysread:
5481             LOP(OP_SYSREAD,XTERM);
5482
5483         case KEY_syswrite:
5484             LOP(OP_SYSWRITE,XTERM);
5485
5486         case KEY_tr:
5487             s = scan_trans(s);
5488             TERM(sublex_start());
5489
5490         case KEY_tell:
5491             UNI(OP_TELL);
5492
5493         case KEY_telldir:
5494             UNI(OP_TELLDIR);
5495
5496         case KEY_tie:
5497             LOP(OP_TIE,XTERM);
5498
5499         case KEY_tied:
5500             UNI(OP_TIED);
5501
5502         case KEY_time:
5503             FUN0(OP_TIME);
5504
5505         case KEY_times:
5506             FUN0(OP_TMS);
5507
5508         case KEY_truncate:
5509             LOP(OP_TRUNCATE,XTERM);
5510
5511         case KEY_uc:
5512             UNI(OP_UC);
5513
5514         case KEY_ucfirst:
5515             UNI(OP_UCFIRST);
5516
5517         case KEY_untie:
5518             UNI(OP_UNTIE);
5519
5520         case KEY_until:
5521             yylval.ival = CopLINE(PL_curcop);
5522             OPERATOR(UNTIL);
5523
5524         case KEY_unless:
5525             yylval.ival = CopLINE(PL_curcop);
5526             OPERATOR(UNLESS);
5527
5528         case KEY_unlink:
5529             LOP(OP_UNLINK,XTERM);
5530
5531         case KEY_undef:
5532             UNIDOR(OP_UNDEF);
5533
5534         case KEY_unpack:
5535             LOP(OP_UNPACK,XTERM);
5536
5537         case KEY_utime:
5538             LOP(OP_UTIME,XTERM);
5539
5540         case KEY_umask:
5541             UNIDOR(OP_UMASK);
5542
5543         case KEY_unshift:
5544             LOP(OP_UNSHIFT,XTERM);
5545
5546         case KEY_use:
5547             s = tokenize_use(1, s);
5548             OPERATOR(USE);
5549
5550         case KEY_values:
5551             UNI(OP_VALUES);
5552
5553         case KEY_vec:
5554             LOP(OP_VEC,XTERM);
5555
5556         case KEY_when:
5557             yylval.ival = CopLINE(PL_curcop);
5558             OPERATOR(WHEN);
5559
5560         case KEY_while:
5561             yylval.ival = CopLINE(PL_curcop);
5562             OPERATOR(WHILE);
5563
5564         case KEY_warn:
5565             PL_hints |= HINT_BLOCK_SCOPE;
5566             LOP(OP_WARN,XTERM);
5567
5568         case KEY_wait:
5569             FUN0(OP_WAIT);
5570
5571         case KEY_waitpid:
5572             LOP(OP_WAITPID,XTERM);
5573
5574         case KEY_wantarray:
5575             FUN0(OP_WANTARRAY);
5576
5577         case KEY_write:
5578 #ifdef EBCDIC
5579         {
5580             char ctl_l[2];
5581             ctl_l[0] = toCTRL('L');
5582             ctl_l[1] = '\0';
5583             gv_fetchpv(ctl_l,TRUE, SVt_PV);
5584         }
5585 #else
5586             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
5587 #endif
5588             UNI(OP_ENTERWRITE);
5589
5590         case KEY_x:
5591             if (PL_expect == XOPERATOR)
5592                 Mop(OP_REPEAT);
5593             check_uni();
5594             goto just_a_word;
5595
5596         case KEY_xor:
5597             yylval.ival = OP_XOR;
5598             OPERATOR(OROP);
5599
5600         case KEY_y:
5601             s = scan_trans(s);
5602             TERM(sublex_start());
5603         }
5604     }}
5605 }
5606 #ifdef __SC__
5607 #pragma segment Main
5608 #endif
5609
5610 static int
5611 S_pending_ident(pTHX)
5612 {
5613     register char *d;
5614     register I32 tmp = 0;
5615     /* pit holds the identifier we read and pending_ident is reset */
5616     char pit = PL_pending_ident;
5617     PL_pending_ident = 0;
5618
5619     DEBUG_T({ PerlIO_printf(Perl_debug_log,
5620           "### Pending identifier '%s'\n", PL_tokenbuf); });
5621
5622     /* if we're in a my(), we can't allow dynamics here.
5623        $foo'bar has already been turned into $foo::bar, so
5624        just check for colons.
5625
5626        if it's a legal name, the OP is a PADANY.
5627     */
5628     if (PL_in_my) {
5629         if (PL_in_my == KEY_our) {      /* "our" is merely analogous to "my" */
5630             if (strchr(PL_tokenbuf,':'))
5631                 yyerror(Perl_form(aTHX_ "No package name allowed for "
5632                                   "variable %s in \"our\"",
5633                                   PL_tokenbuf));
5634             tmp = allocmy(PL_tokenbuf);
5635         }
5636         else {
5637             if (strchr(PL_tokenbuf,':'))
5638                 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5639
5640             yylval.opval = newOP(OP_PADANY, 0);
5641             yylval.opval->op_targ = allocmy(PL_tokenbuf);
5642             return PRIVATEREF;
5643         }
5644     }
5645
5646     /*
5647        build the ops for accesses to a my() variable.
5648
5649        Deny my($a) or my($b) in a sort block, *if* $a or $b is
5650        then used in a comparison.  This catches most, but not
5651        all cases.  For instance, it catches
5652            sort { my($a); $a <=> $b }
5653        but not
5654            sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5655        (although why you'd do that is anyone's guess).
5656     */
5657
5658     if (!strchr(PL_tokenbuf,':')) {
5659         if (!PL_in_my)
5660             tmp = pad_findmy(PL_tokenbuf);
5661         if (tmp != NOT_IN_PAD) {
5662             /* might be an "our" variable" */
5663             if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5664                 /* build ops for a bareword */
5665                 HV *  const stash = PAD_COMPNAME_OURSTASH(tmp);
5666                 HEK * const stashname = HvNAME_HEK(stash);
5667                 SV *  const sym = newSVhek(stashname);
5668                 sv_catpvn(sym, "::", 2);
5669                 sv_catpv(sym, PL_tokenbuf+1);
5670                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5671                 yylval.opval->op_private = OPpCONST_ENTERED;
5672                 gv_fetchsv(sym,
5673                     (PL_in_eval
5674                         ? (GV_ADDMULTI | GV_ADDINEVAL)
5675                         : GV_ADDMULTI
5676                     ),
5677                     ((PL_tokenbuf[0] == '$') ? SVt_PV
5678                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5679                      : SVt_PVHV));
5680                 return WORD;
5681             }
5682
5683             /* if it's a sort block and they're naming $a or $b */
5684             if (PL_last_lop_op == OP_SORT &&
5685                 PL_tokenbuf[0] == '$' &&
5686                 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5687                 && !PL_tokenbuf[2])
5688             {
5689                 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5690                      d < PL_bufend && *d != '\n';
5691                      d++)
5692                 {
5693                     if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5694                         Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5695                               PL_tokenbuf);
5696                     }
5697                 }
5698             }
5699
5700             yylval.opval = newOP(OP_PADANY, 0);
5701             yylval.opval->op_targ = tmp;
5702             return PRIVATEREF;
5703         }
5704     }
5705
5706     /*
5707        Whine if they've said @foo in a doublequoted string,
5708        and @foo isn't a variable we can find in the symbol
5709        table.
5710     */
5711     if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5712         GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5713         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5714              && ckWARN(WARN_AMBIGUOUS))
5715         {
5716             /* Downgraded from fatal to warning 20000522 mjd */
5717             Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5718                         "Possible unintended interpolation of %s in string",
5719                          PL_tokenbuf);
5720         }
5721     }
5722
5723     /* build ops for a bareword */
5724     yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5725     yylval.opval->op_private = OPpCONST_ENTERED;
5726     gv_fetchpv(
5727             PL_tokenbuf+1,
5728             PL_in_eval
5729                 ? (GV_ADDMULTI | GV_ADDINEVAL)
5730                 /* If the identifier refers to a stash, don't autovivify it.
5731                  * Change 24660 had the side effect of causing symbol table
5732                  * hashes to always be defined, even if they were freshly
5733                  * created and the only reference in the entire program was
5734                  * the single statement with the defined %foo::bar:: test.
5735                  * It appears that all code in the wild doing this actually
5736                  * wants to know whether sub-packages have been loaded, so
5737                  * by avoiding auto-vivifying symbol tables, we ensure that
5738                  * defined %foo::bar:: continues to be false, and the existing
5739                  * tests still give the expected answers, even though what
5740                  * they're actually testing has now changed subtly.
5741                  */
5742                 : !(*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'),
5743             ((PL_tokenbuf[0] == '$') ? SVt_PV
5744              : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5745              : SVt_PVHV));
5746     return WORD;
5747 }
5748
5749 /*
5750  *  The following code was generated by perl_keyword.pl.
5751  */
5752
5753 I32
5754 Perl_keyword (pTHX_ const char *name, I32 len)
5755 {
5756   switch (len)
5757   {
5758     case 1: /* 5 tokens of length 1 */
5759       switch (name[0])
5760       {
5761         case 'm':
5762           {                                       /* m          */
5763             return KEY_m;
5764           }
5765
5766         case 'q':
5767           {                                       /* q          */
5768             return KEY_q;
5769           }
5770
5771         case 's':
5772           {                                       /* s          */
5773             return KEY_s;
5774           }
5775
5776         case 'x':
5777           {                                       /* x          */
5778             return -KEY_x;
5779           }
5780
5781         case 'y':
5782           {                                       /* y          */
5783             return KEY_y;
5784           }
5785
5786         default:
5787           goto unknown;
5788       }
5789
5790     case 2: /* 18 tokens of length 2 */
5791       switch (name[0])
5792       {
5793         case 'd':
5794           if (name[1] == 'o')
5795           {                                       /* do         */
5796             return KEY_do;
5797           }
5798
5799           goto unknown;
5800
5801         case 'e':
5802           if (name[1] == 'q')
5803           {                                       /* eq         */
5804             return -KEY_eq;
5805           }
5806
5807           goto unknown;
5808
5809         case 'g':
5810           switch (name[1])
5811           {
5812             case 'e':
5813               {                                   /* ge         */
5814                 return -KEY_ge;
5815               }
5816
5817             case 't':
5818               {                                   /* gt         */
5819                 return -KEY_gt;
5820               }
5821
5822             default:
5823               goto unknown;
5824           }
5825
5826         case 'i':
5827           if (name[1] == 'f')
5828           {                                       /* if         */
5829             return KEY_if;
5830           }
5831
5832           goto unknown;
5833
5834         case 'l':
5835           switch (name[1])
5836           {
5837             case 'c':
5838               {                                   /* lc         */
5839                 return -KEY_lc;
5840               }
5841
5842             case 'e':
5843               {                                   /* le         */
5844                 return -KEY_le;
5845               }
5846
5847             case 't':
5848               {                                   /* lt         */
5849                 return -KEY_lt;
5850               }
5851
5852             default:
5853               goto unknown;
5854           }
5855
5856         case 'm':
5857           if (name[1] == 'y')
5858           {                                       /* my         */
5859             return KEY_my;
5860           }
5861
5862           goto unknown;
5863
5864         case 'n':
5865           switch (name[1])
5866           {
5867             case 'e':
5868               {                                   /* ne         */
5869                 return -KEY_ne;
5870               }
5871
5872             case 'o':
5873               {                                   /* no         */
5874                 return KEY_no;
5875               }
5876
5877             default:
5878               goto unknown;
5879           }
5880
5881         case 'o':
5882           if (name[1] == 'r')
5883           {                                       /* or         */
5884             return -KEY_or;
5885           }
5886
5887           goto unknown;
5888
5889         case 'q':
5890           switch (name[1])
5891           {
5892             case 'q':
5893               {                                   /* qq         */
5894                 return KEY_qq;
5895               }
5896
5897             case 'r':
5898               {                                   /* qr         */
5899                 return KEY_qr;
5900               }
5901
5902             case 'w':
5903               {                                   /* qw         */
5904                 return KEY_qw;
5905               }
5906
5907             case 'x':
5908               {                                   /* qx         */
5909                 return KEY_qx;
5910               }
5911
5912             default:
5913               goto unknown;
5914           }
5915
5916         case 't':
5917           if (name[1] == 'r')
5918           {                                       /* tr         */
5919             return KEY_tr;
5920           }
5921
5922           goto unknown;
5923
5924         case 'u':
5925           if (name[1] == 'c')
5926           {                                       /* uc         */
5927             return -KEY_uc;
5928           }
5929
5930           goto unknown;
5931
5932         default:
5933           goto unknown;
5934       }
5935
5936     case 3: /* 29 tokens of length 3 */
5937       switch (name[0])
5938       {
5939         case 'E':
5940           if (name[1] == 'N' &&
5941               name[2] == 'D')
5942           {                                       /* END        */
5943             return KEY_END;
5944           }
5945
5946           goto unknown;
5947
5948         case 'a':
5949           switch (name[1])
5950           {
5951             case 'b':
5952               if (name[2] == 's')
5953               {                                   /* abs        */
5954                 return -KEY_abs;
5955               }
5956
5957               goto unknown;
5958
5959             case 'n':
5960               if (name[2] == 'd')
5961               {                                   /* and        */
5962                 return -KEY_and;
5963               }
5964
5965               goto unknown;
5966
5967             default:
5968               goto unknown;
5969           }
5970
5971         case 'c':
5972           switch (name[1])
5973           {
5974             case 'h':
5975               if (name[2] == 'r')
5976               {                                   /* chr        */
5977                 return -KEY_chr;
5978               }
5979
5980               goto unknown;
5981
5982             case 'm':
5983               if (name[2] == 'p')
5984               {                                   /* cmp        */
5985                 return -KEY_cmp;
5986               }
5987
5988               goto unknown;
5989
5990             case 'o':
5991               if (name[2] == 's')
5992               {                                   /* cos        */
5993                 return -KEY_cos;
5994               }
5995
5996               goto unknown;
5997
5998             default:
5999               goto unknown;
6000           }
6001
6002         case 'd':
6003           if (name[1] == 'i' &&
6004               name[2] == 'e')
6005           {                                       /* die        */
6006             return -KEY_die;
6007           }
6008
6009           goto unknown;
6010
6011         case 'e':
6012           switch (name[1])
6013           {
6014             case 'o':
6015               if (name[2] == 'f')
6016               {                                   /* eof        */
6017                 return -KEY_eof;
6018               }
6019
6020               goto unknown;
6021
6022             case 'r':
6023               if (name[2] == 'r')
6024               {                                   /* err        */
6025                 return -KEY_err;
6026               }
6027
6028               goto unknown;
6029
6030             case 'x':
6031               if (name[2] == 'p')
6032               {                                   /* exp        */
6033                 return -KEY_exp;
6034               }
6035
6036               goto unknown;
6037
6038             default:
6039               goto unknown;
6040           }
6041
6042         case 'f':
6043           if (name[1] == 'o' &&
6044               name[2] == 'r')
6045           {                                       /* for        */
6046             return KEY_for;
6047           }
6048
6049           goto unknown;
6050
6051         case 'h':
6052           if (name[1] == 'e' &&
6053               name[2] == 'x')
6054           {                                       /* hex        */
6055             return -KEY_hex;
6056           }
6057
6058           goto unknown;
6059
6060         case 'i':
6061           if (name[1] == 'n' &&
6062               name[2] == 't')
6063           {                                       /* int        */
6064             return -KEY_int;
6065           }
6066
6067           goto unknown;
6068
6069         case 'l':
6070           if (name[1] == 'o' &&
6071               name[2] == 'g')
6072           {                                       /* log        */
6073             return -KEY_log;
6074           }
6075
6076           goto unknown;
6077
6078         case 'm':
6079           if (name[1] == 'a' &&
6080               name[2] == 'p')
6081           {                                       /* map        */
6082             return KEY_map;
6083           }
6084
6085           goto unknown;
6086
6087         case 'n':
6088           if (name[1] == 'o' &&
6089               name[2] == 't')
6090           {                                       /* not        */
6091             return -KEY_not;
6092           }
6093
6094           goto unknown;
6095
6096         case 'o':
6097           switch (name[1])
6098           {
6099             case 'c':
6100               if (name[2] == 't')
6101               {                                   /* oct        */
6102                 return -KEY_oct;
6103               }
6104
6105               goto unknown;
6106
6107             case 'r':
6108               if (name[2] == 'd')
6109               {                                   /* ord        */
6110                 return -KEY_ord;
6111               }
6112
6113               goto unknown;
6114
6115             case 'u':
6116               if (name[2] == 'r')
6117               {                                   /* our        */
6118                 return KEY_our;
6119               }
6120
6121               goto unknown;
6122
6123             default:
6124               goto unknown;
6125           }
6126
6127         case 'p':
6128           if (name[1] == 'o')
6129           {
6130             switch (name[2])
6131             {
6132               case 'p':
6133                 {                                 /* pop        */
6134                   return -KEY_pop;
6135                 }
6136
6137               case 's':
6138                 {                                 /* pos        */
6139                   return KEY_pos;
6140                 }
6141
6142               default:
6143                 goto unknown;
6144             }
6145           }
6146
6147           goto unknown;
6148
6149         case 'r':
6150           if (name[1] == 'e' &&
6151               name[2] == 'f')
6152           {                                       /* ref        */
6153             return -KEY_ref;
6154           }
6155
6156           goto unknown;
6157
6158         case 's':
6159           switch (name[1])
6160           {
6161             case 'a':
6162               if (name[2] == 'y')
6163               {                                   /* say        */
6164                 return (FEATURE_IS_ENABLED("say", 3) ? -KEY_say : 0);
6165               }
6166
6167               goto unknown;
6168
6169             case 'i':
6170               if (name[2] == 'n')
6171               {                                   /* sin        */
6172                 return -KEY_sin;
6173               }
6174
6175               goto unknown;
6176
6177             case 'u':
6178               if (name[2] == 'b')
6179               {                                   /* sub        */
6180                 return KEY_sub;
6181               }
6182
6183               goto unknown;
6184
6185             default:
6186               goto unknown;
6187           }
6188
6189         case 't':
6190           if (name[1] == 'i' &&
6191               name[2] == 'e')
6192           {                                       /* tie        */
6193             return KEY_tie;
6194           }
6195
6196           goto unknown;
6197
6198         case 'u':
6199           if (name[1] == 's' &&
6200               name[2] == 'e')
6201           {                                       /* use        */
6202             return KEY_use;
6203           }
6204
6205           goto unknown;
6206
6207         case 'v':
6208           if (name[1] == 'e' &&
6209               name[2] == 'c')
6210           {                                       /* vec        */
6211             return -KEY_vec;
6212           }
6213
6214           goto unknown;
6215
6216         case 'x':
6217           if (name[1] == 'o' &&
6218               name[2] == 'r')
6219           {                                       /* xor        */
6220             return -KEY_xor;
6221           }
6222
6223           goto unknown;
6224
6225         default:
6226           goto unknown;
6227       }
6228
6229     case 4: /* 41 tokens of length 4 */
6230       switch (name[0])
6231       {
6232         case 'C':
6233           if (name[1] == 'O' &&
6234               name[2] == 'R' &&
6235               name[3] == 'E')
6236           {                                       /* CORE       */
6237             return -KEY_CORE;
6238           }
6239
6240           goto unknown;
6241
6242         case 'I':
6243           if (name[1] == 'N' &&
6244               name[2] == 'I' &&
6245               name[3] == 'T')
6246           {                                       /* INIT       */
6247             return KEY_INIT;
6248           }
6249
6250           goto unknown;
6251
6252         case 'b':
6253           if (name[1] == 'i' &&
6254               name[2] == 'n' &&
6255               name[3] == 'd')
6256           {                                       /* bind       */
6257             return -KEY_bind;
6258           }
6259
6260           goto unknown;
6261
6262         case 'c':
6263           if (name[1] == 'h' &&
6264               name[2] == 'o' &&
6265               name[3] == 'p')
6266           {                                       /* chop       */
6267             return -KEY_chop;
6268           }
6269
6270           goto unknown;
6271
6272         case 'd':
6273           if (name[1] == 'u' &&
6274               name[2] == 'm' &&
6275               name[3] == 'p')
6276           {                                       /* dump       */
6277             return -KEY_dump;
6278           }
6279
6280           goto unknown;
6281
6282         case 'e':
6283           switch (name[1])
6284           {
6285             case 'a':
6286               if (name[2] == 'c' &&
6287                   name[3] == 'h')
6288               {                                   /* each       */
6289                 return -KEY_each;
6290               }
6291
6292               goto unknown;
6293
6294             case 'l':
6295               if (name[2] == 's' &&
6296                   name[3] == 'e')
6297               {                                   /* else       */
6298                 return KEY_else;
6299               }
6300
6301               goto unknown;
6302
6303             case 'v':
6304               if (name[2] == 'a' &&
6305                   name[3] == 'l')
6306               {                                   /* eval       */
6307                 return KEY_eval;
6308               }
6309
6310               goto unknown;
6311
6312             case 'x':
6313               switch (name[2])
6314               {
6315                 case 'e':
6316                   if (name[3] == 'c')
6317                   {                               /* exec       */
6318                     return -KEY_exec;
6319                   }
6320
6321                   goto unknown;
6322
6323                 case 'i':
6324                   if (name[3] == 't')
6325                   {                               /* exit       */
6326                     return -KEY_exit;
6327                   }
6328
6329                   goto unknown;
6330
6331                 default:
6332                   goto unknown;
6333               }
6334
6335             default:
6336               goto unknown;
6337           }
6338
6339         case 'f':
6340           if (name[1] == 'o' &&
6341               name[2] == 'r' &&
6342               name[3] == 'k')
6343           {                                       /* fork       */
6344             return -KEY_fork;
6345           }
6346
6347           goto unknown;
6348
6349         case 'g':
6350           switch (name[1])
6351           {
6352             case 'e':
6353               if (name[2] == 't' &&
6354                   name[3] == 'c')
6355               {                                   /* getc       */
6356                 return -KEY_getc;
6357               }
6358
6359               goto unknown;
6360
6361             case 'l':
6362               if (name[2] == 'o' &&
6363                   name[3] == 'b')
6364               {                                   /* glob       */
6365                 return KEY_glob;
6366               }
6367
6368               goto unknown;
6369
6370             case 'o':
6371               if (name[2] == 't' &&
6372                   name[3] == 'o')
6373               {                                   /* goto       */
6374                 return KEY_goto;
6375               }
6376
6377               goto unknown;
6378
6379             case 'r':
6380               if (name[2] == 'e' &&
6381                   name[3] == 'p')
6382               {                                   /* grep       */
6383                 return KEY_grep;
6384               }
6385
6386               goto unknown;
6387
6388             default:
6389               goto unknown;
6390           }
6391
6392         case 'j':
6393           if (name[1] == 'o' &&
6394               name[2] == 'i' &&
6395               name[3] == 'n')
6396           {                                       /* join       */
6397             return -KEY_join;
6398           }
6399
6400           goto unknown;
6401
6402         case 'k':
6403           switch (name[1])
6404           {
6405             case 'e':
6406               if (name[2] == 'y' &&
6407                   name[3] == 's')
6408               {                                   /* keys       */
6409                 return -KEY_keys;
6410               }
6411
6412               goto unknown;
6413
6414             case 'i':
6415               if (name[2] == 'l' &&
6416                   name[3] == 'l')
6417               {                                   /* kill       */
6418                 return -KEY_kill;
6419               }
6420
6421               goto unknown;
6422
6423             default:
6424               goto unknown;
6425           }
6426
6427         case 'l':
6428           switch (name[1])
6429           {
6430             case 'a':
6431               if (name[2] == 's' &&
6432                   name[3] == 't')
6433               {                                   /* last       */
6434                 return KEY_last;
6435               }
6436
6437               goto unknown;
6438
6439             case 'i':
6440               if (name[2] == 'n' &&
6441                   name[3] == 'k')
6442               {                                   /* link       */
6443                 return -KEY_link;
6444               }
6445
6446               goto unknown;
6447
6448             case 'o':
6449               if (name[2] == 'c' &&
6450                   name[3] == 'k')
6451               {                                   /* lock       */
6452                 return -KEY_lock;
6453               }
6454
6455               goto unknown;
6456
6457             default:
6458               goto unknown;
6459           }
6460
6461         case 'n':
6462           if (name[1] == 'e' &&
6463               name[2] == 'x' &&
6464               name[3] == 't')
6465           {                                       /* next       */
6466             return KEY_next;
6467           }
6468
6469           goto unknown;
6470
6471         case 'o':
6472           if (name[1] == 'p' &&
6473               name[2] == 'e' &&
6474               name[3] == 'n')
6475           {                                       /* open       */
6476             return -KEY_open;
6477           }
6478
6479           goto unknown;
6480
6481         case 'p':
6482           switch (name[1])
6483           {
6484             case 'a':
6485               if (name[2] == 'c' &&
6486                   name[3] == 'k')
6487               {                                   /* pack       */
6488                 return -KEY_pack;
6489               }
6490
6491               goto unknown;
6492
6493             case 'i':
6494               if (name[2] == 'p' &&
6495                   name[3] == 'e')
6496               {                                   /* pipe       */
6497                 return -KEY_pipe;
6498               }
6499
6500               goto unknown;
6501
6502             case 'u':
6503               if (name[2] == 's' &&
6504                   name[3] == 'h')
6505               {                                   /* push       */
6506                 return -KEY_push;
6507               }
6508
6509               goto unknown;
6510
6511             default:
6512               goto unknown;
6513           }
6514
6515         case 'r':
6516           switch (name[1])
6517           {
6518             case 'a':
6519               if (name[2] == 'n' &&
6520                   name[3] == 'd')
6521               {                                   /* rand       */
6522                 return -KEY_rand;
6523               }
6524
6525               goto unknown;
6526
6527             case 'e':
6528               switch (name[2])
6529               {
6530                 case 'a':
6531                   if (name[3] == 'd')
6532                   {                               /* read       */
6533                     return -KEY_read;
6534                   }
6535
6536                   goto unknown;
6537
6538                 case 'c':
6539                   if (name[3] == 'v')
6540                   {                               /* recv       */
6541                     return -KEY_recv;
6542                   }
6543
6544                   goto unknown;
6545
6546                 case 'd':
6547                   if (name[3] == 'o')
6548                   {                               /* redo       */
6549                     return KEY_redo;
6550                   }
6551
6552                   goto unknown;
6553
6554                 default:
6555                   goto unknown;
6556               }
6557
6558             default:
6559               goto unknown;
6560           }
6561
6562         case 's':
6563           switch (name[1])
6564           {
6565             case 'e':
6566               switch (name[2])
6567               {
6568                 case 'e':
6569                   if (name[3] == 'k')
6570                   {                               /* seek       */
6571                     return -KEY_seek;
6572                   }
6573
6574                   goto unknown;
6575
6576                 case 'n':
6577                   if (name[3] == 'd')
6578                   {                               /* send       */
6579                     return -KEY_send;
6580                   }
6581
6582                   goto unknown;
6583
6584                 default:
6585                   goto unknown;
6586               }
6587
6588             case 'o':
6589               if (name[2] == 'r' &&
6590                   name[3] == 't')
6591               {                                   /* sort       */
6592                 return KEY_sort;
6593               }
6594
6595               goto unknown;
6596
6597             case 'q':
6598               if (name[2] == 'r' &&
6599                   name[3] == 't')
6600               {                                   /* sqrt       */
6601                 return -KEY_sqrt;
6602               }
6603
6604               goto unknown;
6605
6606             case 't':
6607               if (name[2] == 'a' &&
6608                   name[3] == 't')
6609               {                                   /* stat       */
6610                 return -KEY_stat;
6611               }
6612
6613               goto unknown;
6614
6615             default:
6616               goto unknown;
6617           }
6618
6619         case 't':
6620           switch (name[1])
6621           {
6622             case 'e':
6623               if (name[2] == 'l' &&
6624                   name[3] == 'l')
6625               {                                   /* tell       */
6626                 return -KEY_tell;
6627               }
6628
6629               goto unknown;
6630
6631             case 'i':
6632               switch (name[2])
6633               {
6634                 case 'e':
6635                   if (name[3] == 'd')
6636                   {                               /* tied       */
6637                     return KEY_tied;
6638                   }
6639
6640                   goto unknown;
6641
6642                 case 'm':
6643                   if (name[3] == 'e')
6644                   {                               /* time       */
6645                     return -KEY_time;
6646                   }
6647
6648                   goto unknown;
6649
6650                 default:
6651                   goto unknown;
6652               }
6653
6654             default:
6655               goto unknown;
6656           }
6657
6658         case 'w':
6659           switch (name[1])
6660           {
6661             case 'a':
6662             switch (name[2])
6663             {
6664               case 'i':
6665                 if (name[3] == 't')
6666                 {                                 /* wait       */
6667                   return -KEY_wait;
6668                 }
6669
6670                 goto unknown;
6671
6672               case 'r':
6673                 if (name[3] == 'n')
6674                 {                                 /* warn       */
6675                   return -KEY_warn;
6676                 }
6677
6678                 goto unknown;
6679
6680               default:
6681                 goto unknown;
6682             }
6683
6684             case 'h':
6685               if (name[2] == 'e' &&
6686                   name[3] == 'n')
6687               {                                   /* when       */
6688                 return (FEATURE_IS_ENABLED("switch", 6) ? KEY_when : 0);
6689           }
6690
6691           goto unknown;
6692
6693         default:
6694           goto unknown;
6695       }
6696
6697         default:
6698           goto unknown;
6699       }
6700
6701     case 5: /* 38 tokens of length 5 */
6702       switch (name[0])
6703       {
6704         case 'B':
6705           if (name[1] == 'E' &&
6706               name[2] == 'G' &&
6707               name[3] == 'I' &&
6708               name[4] == 'N')
6709           {                                       /* BEGIN      */
6710             return KEY_BEGIN;
6711           }
6712
6713           goto unknown;
6714
6715         case 'C':
6716           if (name[1] == 'H' &&
6717               name[2] == 'E' &&
6718               name[3] == 'C' &&
6719               name[4] == 'K')
6720           {                                       /* CHECK      */
6721             return KEY_CHECK;
6722           }
6723
6724           goto unknown;
6725
6726         case 'a':
6727           switch (name[1])
6728           {
6729             case 'l':
6730               if (name[2] == 'a' &&
6731                   name[3] == 'r' &&
6732                   name[4] == 'm')
6733               {                                   /* alarm      */
6734                 return -KEY_alarm;
6735               }
6736
6737               goto unknown;
6738
6739             case 't':
6740               if (name[2] == 'a' &&
6741                   name[3] == 'n' &&
6742                   name[4] == '2')
6743               {                                   /* atan2      */
6744                 return -KEY_atan2;
6745               }
6746
6747               goto unknown;
6748
6749             default:
6750               goto unknown;
6751           }
6752
6753         case 'b':
6754           switch (name[1])
6755           {
6756             case 'l':
6757               if (name[2] == 'e' &&
6758               name[3] == 's' &&
6759               name[4] == 's')
6760           {                                       /* bless      */
6761             return -KEY_bless;
6762           }
6763
6764           goto unknown;
6765
6766             case 'r':
6767               if (name[2] == 'e' &&
6768                   name[3] == 'a' &&
6769                   name[4] == 'k')
6770               {                                   /* break      */
6771                 return (FEATURE_IS_ENABLED("switch", 6) ? -KEY_break : 0);
6772               }
6773
6774               goto unknown;
6775
6776             default:
6777               goto unknown;
6778           }
6779
6780         case 'c':
6781           switch (name[1])
6782           {
6783             case 'h':
6784               switch (name[2])
6785               {
6786                 case 'd':
6787                   if (name[3] == 'i' &&
6788                       name[4] == 'r')
6789                   {                               /* chdir      */
6790                     return -KEY_chdir;
6791                   }
6792
6793                   goto unknown;
6794
6795                 case 'm':
6796                   if (name[3] == 'o' &&
6797                       name[4] == 'd')
6798                   {                               /* chmod      */
6799                     return -KEY_chmod;
6800                   }
6801
6802                   goto unknown;
6803
6804                 case 'o':
6805                   switch (name[3])
6806                   {
6807                     case 'm':
6808                       if (name[4] == 'p')
6809                       {                           /* chomp      */
6810                         return -KEY_chomp;
6811                       }
6812
6813                       goto unknown;
6814
6815                     case 'w':
6816                       if (name[4] == 'n')
6817                       {                           /* chown      */
6818                         return -KEY_chown;
6819                       }
6820
6821                       goto unknown;
6822
6823                     default:
6824                       goto unknown;
6825                   }
6826
6827                 default:
6828                   goto unknown;
6829               }
6830
6831             case 'l':
6832               if (name[2] == 'o' &&
6833                   name[3] == 's' &&
6834                   name[4] == 'e')
6835               {                                   /* close      */
6836                 return -KEY_close;
6837               }
6838
6839               goto unknown;
6840
6841             case 'r':
6842               if (name[2] == 'y' &&
6843                   name[3] == 'p' &&
6844                   name[4] == 't')
6845               {                                   /* crypt      */
6846                 return -KEY_crypt;
6847               }
6848
6849               goto unknown;
6850
6851             default:
6852               goto unknown;
6853           }
6854
6855         case 'e':
6856           if (name[1] == 'l' &&
6857               name[2] == 's' &&
6858               name[3] == 'i' &&
6859               name[4] == 'f')
6860           {                                       /* elsif      */
6861             return KEY_elsif;
6862           }
6863
6864           goto unknown;
6865
6866         case 'f':
6867           switch (name[1])
6868           {
6869             case 'c':
6870               if (name[2] == 'n' &&
6871                   name[3] == 't' &&
6872                   name[4] == 'l')
6873               {                                   /* fcntl      */
6874                 return -KEY_fcntl;
6875               }
6876
6877               goto unknown;
6878
6879             case 'l':
6880               if (name[2] == 'o' &&
6881                   name[3] == 'c' &&
6882                   name[4] == 'k')
6883               {                                   /* flock      */
6884                 return -KEY_flock;
6885               }
6886
6887               goto unknown;
6888
6889             default:
6890               goto unknown;
6891           }
6892
6893         case 'g':
6894           if (name[1] == 'i' &&
6895               name[2] == 'v' &&
6896               name[3] == 'e' &&
6897               name[4] == 'n')
6898           {                                       /* given      */
6899             return (FEATURE_IS_ENABLED("switch", 6) ? KEY_given : 0);
6900           }
6901
6902           goto unknown;
6903
6904         case 'i':
6905           switch (name[1])
6906           {
6907             case 'n':
6908               if (name[2] == 'd' &&
6909                   name[3] == 'e' &&
6910                   name[4] == 'x')
6911               {                                   /* index      */
6912                 return -KEY_index;
6913               }
6914
6915               goto unknown;
6916
6917             case 'o':
6918               if (name[2] == 'c' &&
6919                   name[3] == 't' &&
6920                   name[4] == 'l')
6921               {                                   /* ioctl      */
6922                 return -KEY_ioctl;
6923               }
6924
6925               goto unknown;
6926
6927             default:
6928               goto unknown;
6929           }
6930
6931         case 'l':
6932           switch (name[1])
6933           {
6934             case 'o':
6935               if (name[2] == 'c' &&
6936                   name[3] == 'a' &&
6937                   name[4] == 'l')
6938               {                                   /* local      */
6939                 return KEY_local;
6940               }
6941
6942               goto unknown;
6943
6944             case 's':
6945               if (name[2] == 't' &&
6946                   name[3] == 'a' &&
6947                   name[4] == 't')
6948               {                                   /* lstat      */
6949                 return -KEY_lstat;
6950               }
6951
6952               goto unknown;
6953
6954             default:
6955               goto unknown;
6956           }
6957
6958         case 'm':
6959           if (name[1] == 'k' &&
6960               name[2] == 'd' &&
6961               name[3] == 'i' &&
6962               name[4] == 'r')
6963           {                                       /* mkdir      */
6964             return -KEY_mkdir;
6965           }
6966
6967           goto unknown;
6968
6969         case 'p':
6970           if (name[1] == 'r' &&
6971               name[2] == 'i' &&
6972               name[3] == 'n' &&
6973               name[4] == 't')
6974           {                                       /* print      */
6975             return KEY_print;
6976           }
6977
6978           goto unknown;
6979
6980         case 'r':
6981           switch (name[1])
6982           {
6983             case 'e':
6984               if (name[2] == 's' &&
6985                   name[3] == 'e' &&
6986                   name[4] == 't')
6987               {                                   /* reset      */
6988                 return -KEY_reset;
6989               }
6990
6991               goto unknown;
6992
6993             case 'm':
6994               if (name[2] == 'd' &&
6995                   name[3] == 'i' &&
6996                   name[4] == 'r')
6997               {                                   /* rmdir      */
6998                 return -KEY_rmdir;
6999               }
7000
7001               goto unknown;
7002
7003             default:
7004               goto unknown;
7005           }
7006
7007         case 's':
7008           switch (name[1])
7009           {
7010             case 'e':
7011               if (name[2] == 'm' &&
7012                   name[3] == 'o' &&
7013                   name[4] == 'p')
7014               {                                   /* semop      */
7015                 return -KEY_semop;
7016               }
7017
7018               goto unknown;
7019
7020             case 'h':
7021               if (name[2] == 'i' &&
7022                   name[3] == 'f' &&
7023                   name[4] == 't')
7024               {                                   /* shift      */
7025                 return -KEY_shift;
7026               }
7027
7028               goto unknown;
7029
7030             case 'l':
7031               if (name[2] == 'e' &&
7032                   name[3] == 'e' &&
7033                   name[4] == 'p')
7034               {                                   /* sleep      */
7035                 return -KEY_sleep;
7036               }
7037
7038               goto unknown;
7039
7040             case 'p':
7041               if (name[2] == 'l' &&
7042                   name[3] == 'i' &&
7043                   name[4] == 't')
7044               {                                   /* split      */
7045                 return KEY_split;
7046               }
7047
7048               goto unknown;
7049
7050             case 'r':
7051               if (name[2] == 'a' &&
7052                   name[3] == 'n' &&
7053                   name[4] == 'd')
7054               {                                   /* srand      */
7055                 return -KEY_srand;
7056               }
7057
7058               goto unknown;
7059
7060             case 't':
7061               if (name[2] == 'u' &&
7062                   name[3] == 'd' &&
7063                   name[4] == 'y')
7064               {                                   /* study      */
7065                 return KEY_study;
7066               }
7067
7068               goto unknown;
7069
7070             default:
7071               goto unknown;
7072           }
7073
7074         case 't':
7075           if (name[1] == 'i' &&
7076               name[2] == 'm' &&
7077               name[3] == 'e' &&
7078               name[4] == 's')
7079           {                                       /* times      */
7080             return -KEY_times;
7081           }
7082
7083           goto unknown;
7084
7085         case 'u':
7086           switch (name[1])
7087           {
7088             case 'm':
7089               if (name[2] == 'a' &&
7090                   name[3] == 's' &&
7091                   name[4] == 'k')
7092               {                                   /* umask      */
7093                 return -KEY_umask;
7094               }
7095
7096               goto unknown;
7097
7098             case 'n':
7099               switch (name[2])
7100               {
7101                 case 'd':
7102                   if (name[3] == 'e' &&
7103                       name[4] == 'f')
7104                   {                               /* undef      */
7105                     return KEY_undef;
7106                   }
7107
7108                   goto unknown;
7109
7110                 case 't':
7111                   if (name[3] == 'i')
7112                   {
7113                     switch (name[4])
7114                     {
7115                       case 'e':
7116                         {                         /* untie      */
7117                           return KEY_untie;
7118                         }
7119
7120                       case 'l':
7121                         {                         /* until      */
7122                           return KEY_until;
7123                         }
7124
7125                       default:
7126                         goto unknown;
7127                     }
7128                   }
7129
7130                   goto unknown;
7131
7132                 default:
7133                   goto unknown;
7134               }
7135
7136             case 't':
7137               if (name[2] == 'i' &&
7138                   name[3] == 'm' &&
7139                   name[4] == 'e')
7140               {                                   /* utime      */
7141                 return -KEY_utime;
7142               }
7143
7144               goto unknown;
7145
7146             default:
7147               goto unknown;
7148           }
7149
7150         case 'w':
7151           switch (name[1])
7152           {
7153             case 'h':
7154               if (name[2] == 'i' &&
7155                   name[3] == 'l' &&
7156                   name[4] == 'e')
7157               {                                   /* while      */
7158                 return KEY_while;
7159               }
7160
7161               goto unknown;
7162
7163             case 'r':
7164               if (name[2] == 'i' &&
7165                   name[3] == 't' &&
7166                   name[4] == 'e')
7167               {                                   /* write      */
7168                 return -KEY_write;
7169               }
7170
7171               goto unknown;
7172
7173             default:
7174               goto unknown;
7175           }
7176
7177         default:
7178           goto unknown;
7179       }
7180
7181     case 6: /* 33 tokens of length 6 */
7182       switch (name[0])
7183       {
7184         case 'a':
7185           if (name[1] == 'c' &&
7186               name[2] == 'c' &&
7187               name[3] == 'e' &&
7188               name[4] == 'p' &&
7189               name[5] == 't')
7190           {                                       /* accept     */
7191             return -KEY_accept;
7192           }
7193
7194           goto unknown;
7195
7196         case 'c':
7197           switch (name[1])
7198           {
7199             case 'a':
7200               if (name[2] == 'l' &&
7201                   name[3] == 'l' &&
7202                   name[4] == 'e' &&
7203                   name[5] == 'r')
7204               {                                   /* caller     */
7205                 return -KEY_caller;
7206               }
7207
7208               goto unknown;
7209
7210             case 'h':
7211               if (name[2] == 'r' &&
7212                   name[3] == 'o' &&
7213                   name[4] == 'o' &&
7214                   name[5] == 't')
7215               {                                   /* chroot     */
7216                 return -KEY_chroot;
7217               }
7218
7219               goto unknown;
7220
7221             default:
7222               goto unknown;
7223           }
7224
7225         case 'd':
7226           if (name[1] == 'e' &&
7227               name[2] == 'l' &&
7228               name[3] == 'e' &&
7229               name[4] == 't' &&
7230               name[5] == 'e')
7231           {                                       /* delete     */
7232             return KEY_delete;
7233           }
7234
7235           goto unknown;
7236
7237         case 'e':
7238           switch (name[1])
7239           {
7240             case 'l':
7241               if (name[2] == 's' &&
7242                   name[3] == 'e' &&
7243                   name[4] == 'i' &&
7244                   name[5] == 'f')
7245               {                                   /* elseif     */
7246                 if(ckWARN_d(WARN_SYNTAX))
7247                   Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
7248               }
7249
7250               goto unknown;
7251
7252             case 'x':
7253               if (name[2] == 'i' &&
7254                   name[3] == 's' &&
7255                   name[4] == 't' &&
7256                   name[5] == 's')
7257               {                                   /* exists     */
7258                 return KEY_exists;
7259               }
7260
7261               goto unknown;
7262
7263             default:
7264               goto unknown;
7265           }
7266
7267         case 'f':
7268           switch (name[1])
7269           {
7270             case 'i':
7271               if (name[2] == 'l' &&
7272                   name[3] == 'e' &&
7273                   name[4] == 'n' &&
7274                   name[5] == 'o')
7275               {                                   /* fileno     */
7276                 return -KEY_fileno;
7277               }
7278
7279               goto unknown;
7280
7281             case 'o':
7282               if (name[2] == 'r' &&
7283                   name[3] == 'm' &&
7284                   name[4] == 'a' &&
7285                   name[5] == 't')
7286               {                                   /* format     */
7287                 return KEY_format;
7288               }
7289
7290               goto unknown;
7291
7292             default:
7293               goto unknown;
7294           }
7295
7296         case 'g':
7297           if (name[1] == 'm' &&
7298               name[2] == 't' &&
7299               name[3] == 'i' &&
7300               name[4] == 'm' &&
7301               name[5] == 'e')
7302           {                                       /* gmtime     */
7303             return -KEY_gmtime;
7304           }
7305
7306           goto unknown;
7307
7308         case 'l':
7309           switch (name[1])
7310           {
7311             case 'e':
7312               if (name[2] == 'n' &&
7313                   name[3] == 'g' &&
7314                   name[4] == 't' &&
7315                   name[5] == 'h')
7316               {                                   /* length     */
7317                 return -KEY_length;
7318               }
7319
7320               goto unknown;
7321
7322             case 'i':
7323               if (name[2] == 's' &&
7324                   name[3] == 't' &&
7325                   name[4] == 'e' &&
7326                   name[5] == 'n')
7327               {                                   /* listen     */
7328                 return -KEY_listen;
7329               }
7330
7331               goto unknown;
7332
7333             default:
7334               goto unknown;
7335           }
7336
7337         case 'm':
7338           if (name[1] == 's' &&
7339               name[2] == 'g')
7340           {
7341             switch (name[3])
7342             {
7343               case 'c':
7344                 if (name[4] == 't' &&
7345                     name[5] == 'l')
7346                 {                                 /* msgctl     */
7347                   return -KEY_msgctl;
7348                 }
7349
7350                 goto unknown;
7351
7352               case 'g':
7353                 if (name[4] == 'e' &&
7354                     name[5] == 't')
7355                 {                                 /* msgget     */
7356                   return -KEY_msgget;
7357                 }
7358
7359                 goto unknown;
7360
7361               case 'r':
7362                 if (name[4] == 'c' &&
7363                     name[5] == 'v')
7364                 {                                 /* msgrcv     */
7365                   return -KEY_msgrcv;
7366                 }
7367
7368                 goto unknown;
7369
7370               case 's':
7371                 if (name[4] == 'n' &&
7372                     name[5] == 'd')
7373                 {                                 /* msgsnd     */
7374                   return -KEY_msgsnd;
7375                 }
7376
7377                 goto unknown;
7378
7379               default:
7380                 goto unknown;
7381             }
7382           }
7383
7384           goto unknown;
7385
7386         case 'p':
7387           if (name[1] == 'r' &&
7388               name[2] == 'i' &&
7389               name[3] == 'n' &&
7390               name[4] == 't' &&
7391               name[5] == 'f')
7392           {                                       /* printf     */
7393             return KEY_printf;
7394           }
7395
7396           goto unknown;
7397
7398         case 'r':
7399           switch (name[1])
7400           {
7401             case 'e':
7402               switch (name[2])
7403               {
7404                 case 'n':
7405                   if (name[3] == 'a' &&
7406                       name[4] == 'm' &&
7407                       name[5] == 'e')
7408                   {                               /* rename     */
7409                     return -KEY_rename;
7410                   }
7411
7412                   goto unknown;
7413
7414                 case 't':
7415                   if (name[3] == 'u' &&
7416                       name[4] == 'r' &&
7417                       name[5] == 'n')
7418                   {                               /* return     */
7419                     return KEY_return;
7420                   }
7421
7422                   goto unknown;
7423
7424                 default:
7425                   goto unknown;
7426               }
7427
7428             case 'i':
7429               if (name[2] == 'n' &&
7430                   name[3] == 'd' &&
7431                   name[4] == 'e' &&
7432                   name[5] == 'x')
7433               {                                   /* rindex     */
7434                 return -KEY_rindex;
7435               }
7436
7437               goto unknown;
7438
7439             default:
7440               goto unknown;
7441           }
7442
7443         case 's':
7444           switch (name[1])
7445           {
7446             case 'c':
7447               if (name[2] == 'a' &&
7448                   name[3] == 'l' &&
7449                   name[4] == 'a' &&
7450                   name[5] == 'r')
7451               {                                   /* scalar     */
7452                 return KEY_scalar;
7453               }
7454
7455               goto unknown;
7456
7457             case 'e':
7458               switch (name[2])
7459               {
7460                 case 'l':
7461                   if (name[3] == 'e' &&
7462                       name[4] == 'c' &&
7463                       name[5] == 't')
7464                   {                               /* select     */
7465                     return -KEY_select;
7466                   }
7467
7468                   goto unknown;
7469
7470                 case 'm':
7471                   switch (name[3])
7472                   {
7473                     case 'c':
7474                       if (name[4] == 't' &&
7475                           name[5] == 'l')
7476                       {                           /* semctl     */
7477                         return -KEY_semctl;
7478                       }
7479
7480                       goto unknown;
7481
7482                     case 'g':
7483                       if (name[4] == 'e' &&
7484                           name[5] == 't')
7485                       {                           /* semget     */
7486                         return -KEY_semget;
7487                       }
7488
7489                       goto unknown;
7490
7491                     default:
7492                       goto unknown;
7493                   }
7494
7495                 default:
7496                   goto unknown;
7497               }
7498
7499             case 'h':
7500               if (name[2] == 'm')
7501               {
7502                 switch (name[3])
7503                 {
7504                   case 'c':
7505                     if (name[4] == 't' &&
7506                         name[5] == 'l')
7507                     {                             /* shmctl     */
7508                       return -KEY_shmctl;
7509                     }
7510
7511                     goto unknown;
7512
7513                   case 'g':
7514                     if (name[4] == 'e' &&
7515                         name[5] == 't')
7516                     {                             /* shmget     */
7517                       return -KEY_shmget;
7518                     }
7519
7520                     goto unknown;
7521
7522                   default:
7523                     goto unknown;
7524                 }
7525               }
7526
7527               goto unknown;
7528
7529             case 'o':
7530               if (name[2] == 'c' &&
7531                   name[3] == 'k' &&
7532                   name[4] == 'e' &&
7533                   name[5] == 't')
7534               {                                   /* socket     */
7535                 return -KEY_socket;
7536               }
7537
7538               goto unknown;
7539
7540             case 'p':
7541               if (name[2] == 'l' &&
7542                   name[3] == 'i' &&
7543                   name[4] == 'c' &&
7544                   name[5] == 'e')
7545               {                                   /* splice     */
7546                 return -KEY_splice;
7547               }
7548
7549               goto unknown;
7550
7551             case 'u':
7552               if (name[2] == 'b' &&
7553                   name[3] == 's' &&
7554                   name[4] == 't' &&
7555                   name[5] == 'r')
7556               {                                   /* substr     */
7557                 return -KEY_substr;
7558               }
7559
7560               goto unknown;
7561
7562             case 'y':
7563               if (name[2] == 's' &&
7564                   name[3] == 't' &&
7565                   name[4] == 'e' &&
7566                   name[5] == 'm')
7567               {                                   /* system     */
7568                 return -KEY_system;
7569               }
7570
7571               goto unknown;
7572
7573             default:
7574               goto unknown;
7575           }
7576
7577         case 'u':
7578           if (name[1] == 'n')
7579           {
7580             switch (name[2])
7581             {
7582               case 'l':
7583                 switch (name[3])
7584                 {
7585                   case 'e':
7586                     if (name[4] == 's' &&
7587                         name[5] == 's')
7588                     {                             /* unless     */
7589                       return KEY_unless;
7590                     }
7591
7592                     goto unknown;
7593
7594                   case 'i':
7595                     if (name[4] == 'n' &&
7596                         name[5] == 'k')
7597                     {                             /* unlink     */
7598                       return -KEY_unlink;
7599                     }
7600
7601                     goto unknown;
7602
7603                   default:
7604                     goto unknown;
7605                 }
7606
7607               case 'p':
7608                 if (name[3] == 'a' &&
7609                     name[4] == 'c' &&
7610                     name[5] == 'k')
7611                 {                                 /* unpack     */
7612                   return -KEY_unpack;
7613                 }
7614
7615                 goto unknown;
7616
7617               default:
7618                 goto unknown;
7619             }
7620           }
7621
7622           goto unknown;
7623
7624         case 'v':
7625           if (name[1] == 'a' &&
7626               name[2] == 'l' &&
7627               name[3] == 'u' &&
7628               name[4] == 'e' &&
7629               name[5] == 's')
7630           {                                       /* values     */
7631             return -KEY_values;
7632           }
7633
7634           goto unknown;
7635
7636         default:
7637           goto unknown;
7638       }
7639
7640     case 7: /* 29 tokens of length 7 */
7641       switch (name[0])
7642       {
7643         case 'D':
7644           if (name[1] == 'E' &&
7645               name[2] == 'S' &&
7646               name[3] == 'T' &&
7647               name[4] == 'R' &&
7648               name[5] == 'O' &&
7649               name[6] == 'Y')
7650           {                                       /* DESTROY    */
7651             return KEY_DESTROY;
7652           }
7653
7654           goto unknown;
7655
7656         case '_':
7657           if (name[1] == '_' &&
7658               name[2] == 'E' &&
7659               name[3] == 'N' &&
7660               name[4] == 'D' &&
7661               name[5] == '_' &&
7662               name[6] == '_')
7663           {                                       /* __END__    */
7664             return KEY___END__;
7665           }
7666
7667           goto unknown;
7668
7669         case 'b':
7670           if (name[1] == 'i' &&
7671               name[2] == 'n' &&
7672               name[3] == 'm' &&
7673               name[4] == 'o' &&
7674               name[5] == 'd' &&
7675               name[6] == 'e')
7676           {                                       /* binmode    */
7677             return -KEY_binmode;
7678           }
7679
7680           goto unknown;
7681
7682         case 'c':
7683           if (name[1] == 'o' &&
7684               name[2] == 'n' &&
7685               name[3] == 'n' &&
7686               name[4] == 'e' &&
7687               name[5] == 'c' &&
7688               name[6] == 't')
7689           {                                       /* connect    */
7690             return -KEY_connect;
7691           }
7692
7693           goto unknown;
7694
7695         case 'd':
7696           switch (name[1])
7697           {
7698             case 'b':
7699               if (name[2] == 'm' &&
7700                   name[3] == 'o' &&
7701                   name[4] == 'p' &&
7702                   name[5] == 'e' &&
7703                   name[6] == 'n')
7704               {                                   /* dbmopen    */
7705                 return -KEY_dbmopen;
7706               }
7707
7708               goto unknown;
7709
7710             case 'e':
7711               if (name[2] == 'f')
7712               {
7713                 switch (name[3])
7714                 {
7715                   case 'a':
7716                     if (name[4] == 'u' &&
7717                         name[5] == 'l' &&
7718                         name[6] == 't')
7719                     {                             /* default    */
7720                       return (FEATURE_IS_ENABLED("switch", 6) ? KEY_default : 0);
7721                     }
7722
7723                     goto unknown;
7724
7725                   case 'i':
7726                     if (name[4] == 'n' &&
7727                   name[5] == 'e' &&
7728                   name[6] == 'd')
7729               {                                   /* defined    */
7730                 return KEY_defined;
7731               }
7732
7733               goto unknown;
7734
7735             default:
7736               goto unknown;
7737           }
7738               }
7739
7740               goto unknown;
7741
7742             default:
7743               goto unknown;
7744           }
7745
7746         case 'f':
7747           if (name[1] == 'o' &&
7748               name[2] == 'r' &&
7749               name[3] == 'e' &&
7750               name[4] == 'a' &&
7751               name[5] == 'c' &&
7752               name[6] == 'h')
7753           {                                       /* foreach    */
7754             return KEY_foreach;
7755           }
7756
7757           goto unknown;
7758
7759         case 'g':
7760           if (name[1] == 'e' &&
7761               name[2] == 't' &&
7762               name[3] == 'p')
7763           {
7764             switch (name[4])
7765             {
7766               case 'g':
7767                 if (name[5] == 'r' &&
7768                     name[6] == 'p')
7769                 {                                 /* getpgrp    */
7770                   return -KEY_getpgrp;
7771                 }
7772
7773                 goto unknown;
7774
7775               case 'p':
7776                 if (name[5] == 'i' &&
7777                     name[6] == 'd')
7778                 {                                 /* getppid    */
7779                   return -KEY_getppid;
7780                 }
7781
7782                 goto unknown;
7783
7784               default:
7785                 goto unknown;
7786             }
7787           }
7788
7789           goto unknown;
7790
7791         case 'l':
7792           if (name[1] == 'c' &&
7793               name[2] == 'f' &&
7794               name[3] == 'i' &&
7795               name[4] == 'r' &&
7796               name[5] == 's' &&
7797               name[6] == 't')
7798           {                                       /* lcfirst    */
7799             return -KEY_lcfirst;
7800           }
7801
7802           goto unknown;
7803
7804         case 'o':
7805           if (name[1] == 'p' &&
7806               name[2] == 'e' &&
7807               name[3] == 'n' &&
7808               name[4] == 'd' &&
7809               name[5] == 'i' &&
7810               name[6] == 'r')
7811           {                                       /* opendir    */
7812             return -KEY_opendir;
7813           }
7814
7815           goto unknown;
7816
7817         case 'p':
7818           if (name[1] == 'a' &&
7819               name[2] == 'c' &&
7820               name[3] == 'k' &&
7821               name[4] == 'a' &&
7822               name[5] == 'g' &&
7823               name[6] == 'e')
7824           {                                       /* package    */
7825             return KEY_package;
7826           }
7827
7828           goto unknown;
7829
7830         case 'r':
7831           if (name[1] == 'e')
7832           {
7833             switch (name[2])
7834             {
7835               case 'a':
7836                 if (name[3] == 'd' &&
7837                     name[4] == 'd' &&
7838                     name[5] == 'i' &&
7839                     name[6] == 'r')
7840                 {                                 /* readdir    */
7841                   return -KEY_readdir;
7842                 }
7843
7844                 goto unknown;
7845
7846               case 'q':
7847                 if (name[3] == 'u' &&
7848                     name[4] == 'i' &&
7849                     name[5] == 'r' &&
7850                     name[6] == 'e')
7851                 {                                 /* require    */
7852                   return KEY_require;
7853                 }
7854
7855                 goto unknown;
7856
7857               case 'v':
7858                 if (name[3] == 'e' &&
7859                     name[4] == 'r' &&
7860                     name[5] == 's' &&
7861                     name[6] == 'e')
7862                 {                                 /* reverse    */
7863                   return -KEY_reverse;
7864                 }
7865
7866                 goto unknown;
7867
7868               default:
7869                 goto unknown;
7870             }
7871           }
7872
7873           goto unknown;
7874
7875         case 's':
7876           switch (name[1])
7877           {
7878             case 'e':
7879               switch (name[2])
7880               {
7881                 case 'e':
7882                   if (name[3] == 'k' &&
7883                       name[4] == 'd' &&
7884                       name[5] == 'i' &&
7885                       name[6] == 'r')
7886                   {                               /* seekdir    */
7887                     return -KEY_seekdir;
7888                   }
7889
7890                   goto unknown;
7891
7892                 case 't':
7893                   if (name[3] == 'p' &&
7894                       name[4] == 'g' &&
7895                       name[5] == 'r' &&
7896                       name[6] == 'p')
7897                   {                               /* setpgrp    */
7898                     return -KEY_setpgrp;
7899                   }
7900
7901                   goto unknown;
7902
7903                 default:
7904                   goto unknown;
7905               }
7906
7907             case 'h':
7908               if (name[2] == 'm' &&
7909                   name[3] == 'r' &&
7910                   name[4] == 'e' &&
7911                   name[5] == 'a' &&
7912                   name[6] == 'd')
7913               {                                   /* shmread    */
7914                 return -KEY_shmread;
7915               }
7916
7917               goto unknown;
7918
7919             case 'p':
7920               if (name[2] == 'r' &&
7921                   name[3] == 'i' &&
7922                   name[4] == 'n' &&
7923                   name[5] == 't' &&
7924                   name[6] == 'f')
7925               {                                   /* sprintf    */
7926                 return -KEY_sprintf;
7927               }
7928
7929               goto unknown;
7930
7931             case 'y':
7932               switch (name[2])
7933               {
7934                 case 'm':
7935                   if (name[3] == 'l' &&
7936                       name[4] == 'i' &&
7937                       name[5] == 'n' &&
7938                       name[6] == 'k')
7939                   {                               /* symlink    */
7940                     return -KEY_symlink;
7941                   }
7942
7943                   goto unknown;
7944
7945                 case 's':
7946                   switch (name[3])
7947                   {
7948                     case 'c':
7949                       if (name[4] == 'a' &&
7950                           name[5] == 'l' &&
7951                           name[6] == 'l')
7952                       {                           /* syscall    */
7953                         return -KEY_syscall;
7954                       }
7955
7956                       goto unknown;
7957
7958                     case 'o':
7959                       if (name[4] == 'p' &&
7960                           name[5] == 'e' &&
7961                           name[6] == 'n')
7962                       {                           /* sysopen    */
7963                         return -KEY_sysopen;
7964                       }
7965
7966                       goto unknown;
7967
7968                     case 'r':
7969                       if (name[4] == 'e' &&
7970                           name[5] == 'a' &&
7971                           name[6] == 'd')
7972                       {                           /* sysread    */
7973                         return -KEY_sysread;
7974                       }
7975
7976                       goto unknown;
7977
7978                     case 's':
7979                       if (name[4] == 'e' &&
7980                           name[5] == 'e' &&
7981                           name[6] == 'k')
7982                       {                           /* sysseek    */
7983                         return -KEY_sysseek;
7984                       }
7985
7986                       goto unknown;
7987
7988                     default:
7989                       goto unknown;
7990                   }
7991
7992                 default:
7993                   goto unknown;
7994               }
7995
7996             default:
7997               goto unknown;
7998           }
7999
8000         case 't':
8001           if (name[1] == 'e' &&
8002               name[2] == 'l' &&
8003               name[3] == 'l' &&
8004               name[4] == 'd' &&
8005               name[5] == 'i' &&
8006               name[6] == 'r')
8007           {                                       /* telldir    */
8008             return -KEY_telldir;
8009           }
8010
8011           goto unknown;
8012
8013         case 'u':
8014           switch (name[1])
8015           {
8016             case 'c':
8017               if (name[2] == 'f' &&
8018                   name[3] == 'i' &&
8019                   name[4] == 'r' &&
8020                   name[5] == 's' &&
8021                   name[6] == 't')
8022               {                                   /* ucfirst    */
8023                 return -KEY_ucfirst;
8024               }
8025
8026               goto unknown;
8027
8028             case 'n':
8029               if (name[2] == 's' &&
8030                   name[3] == 'h' &&
8031                   name[4] == 'i' &&
8032                   name[5] == 'f' &&
8033                   name[6] == 't')
8034               {                                   /* unshift    */
8035                 return -KEY_unshift;
8036               }
8037
8038               goto unknown;
8039
8040             default:
8041               goto unknown;
8042           }
8043
8044         case 'w':
8045           if (name[1] == 'a' &&
8046               name[2] == 'i' &&
8047               name[3] == 't' &&
8048               name[4] == 'p' &&
8049               name[5] == 'i' &&
8050               name[6] == 'd')
8051           {                                       /* waitpid    */
8052             return -KEY_waitpid;
8053           }
8054
8055           goto unknown;
8056
8057         default:
8058           goto unknown;
8059       }
8060
8061     case 8: /* 26 tokens of length 8 */
8062       switch (name[0])
8063       {
8064         case 'A':
8065           if (name[1] == 'U' &&
8066               name[2] == 'T' &&
8067               name[3] == 'O' &&
8068               name[4] == 'L' &&
8069               name[5] == 'O' &&
8070               name[6] == 'A' &&
8071               name[7] == 'D')
8072           {                                       /* AUTOLOAD   */
8073             return KEY_AUTOLOAD;
8074           }
8075
8076           goto unknown;
8077
8078         case '_':
8079           if (name[1] == '_')
8080           {
8081             switch (name[2])
8082             {
8083               case 'D':
8084                 if (name[3] == 'A' &&
8085                     name[4] == 'T' &&
8086                     name[5] == 'A' &&
8087                     name[6] == '_' &&
8088                     name[7] == '_')
8089                 {                                 /* __DATA__   */
8090                   return KEY___DATA__;
8091                 }
8092
8093                 goto unknown;
8094
8095               case 'F':
8096                 if (name[3] == 'I' &&
8097                     name[4] == 'L' &&
8098                     name[5] == 'E' &&
8099                     name[6] == '_' &&
8100                     name[7] == '_')
8101                 {                                 /* __FILE__   */
8102                   return -KEY___FILE__;
8103                 }
8104
8105                 goto unknown;
8106
8107               case 'L':
8108                 if (name[3] == 'I' &&
8109                     name[4] == 'N' &&
8110                     name[5] == 'E' &&
8111                     name[6] == '_' &&
8112                     name[7] == '_')
8113                 {                                 /* __LINE__   */
8114                   return -KEY___LINE__;
8115                 }
8116
8117                 goto unknown;
8118
8119               default:
8120                 goto unknown;
8121             }
8122           }
8123
8124           goto unknown;
8125
8126         case 'c':
8127           switch (name[1])
8128           {
8129             case 'l':
8130               if (name[2] == 'o' &&
8131                   name[3] == 's' &&
8132                   name[4] == 'e' &&
8133                   name[5] == 'd' &&
8134                   name[6] == 'i' &&
8135                   name[7] == 'r')
8136               {                                   /* closedir   */
8137                 return -KEY_closedir;
8138               }
8139
8140               goto unknown;
8141
8142             case 'o':
8143               if (name[2] == 'n' &&
8144                   name[3] == 't' &&
8145                   name[4] == 'i' &&
8146                   name[5] == 'n' &&
8147                   name[6] == 'u' &&
8148                   name[7] == 'e')
8149               {                                   /* continue   */
8150                 return -KEY_continue;
8151               }
8152
8153               goto unknown;
8154
8155             default:
8156               goto unknown;
8157           }
8158
8159         case 'd':
8160           if (name[1] == 'b' &&
8161               name[2] == 'm' &&
8162               name[3] == 'c' &&
8163               name[4] == 'l' &&
8164               name[5] == 'o' &&
8165               name[6] == 's' &&
8166               name[7] == 'e')
8167           {                                       /* dbmclose   */
8168             return -KEY_dbmclose;
8169           }
8170
8171           goto unknown;
8172
8173         case 'e':
8174           if (name[1] == 'n' &&
8175               name[2] == 'd')
8176           {
8177             switch (name[3])
8178             {
8179               case 'g':
8180                 if (name[4] == 'r' &&
8181                     name[5] == 'e' &&
8182                     name[6] == 'n' &&
8183                     name[7] == 't')
8184                 {                                 /* endgrent   */
8185                   return -KEY_endgrent;
8186                 }
8187
8188                 goto unknown;
8189
8190               case 'p':
8191                 if (name[4] == 'w' &&
8192                     name[5] == 'e' &&
8193                     name[6] == 'n' &&
8194                     name[7] == 't')
8195                 {                                 /* endpwent   */
8196                   return -KEY_endpwent;
8197                 }
8198
8199                 goto unknown;
8200
8201               default:
8202                 goto unknown;
8203             }
8204           }
8205
8206           goto unknown;
8207
8208         case 'f':
8209           if (name[1] == 'o' &&
8210               name[2] == 'r' &&
8211               name[3] == 'm' &&
8212               name[4] == 'l' &&
8213               name[5] == 'i' &&
8214               name[6] == 'n' &&
8215               name[7] == 'e')
8216           {                                       /* formline   */
8217             return -KEY_formline;
8218           }
8219
8220           goto unknown;
8221
8222         case 'g':
8223           if (name[1] == 'e' &&
8224               name[2] == 't')
8225           {
8226             switch (name[3])
8227             {
8228               case 'g':
8229                 if (name[4] == 'r')
8230                 {
8231                   switch (name[5])
8232                   {
8233                     case 'e':
8234                       if (name[6] == 'n' &&
8235                           name[7] == 't')
8236                       {                           /* getgrent   */
8237                         return -KEY_getgrent;
8238                       }
8239
8240                       goto unknown;
8241
8242                     case 'g':
8243                       if (name[6] == 'i' &&
8244                           name[7] == 'd')
8245                       {                           /* getgrgid   */
8246                         return -KEY_getgrgid;
8247                       }
8248
8249                       goto unknown;
8250
8251                     case 'n':
8252                       if (name[6] == 'a' &&
8253                           name[7] == 'm')
8254                       {                           /* getgrnam   */
8255                         return -KEY_getgrnam;
8256                       }
8257
8258                       goto unknown;
8259
8260                     default:
8261                       goto unknown;
8262                   }
8263                 }
8264
8265                 goto unknown;
8266
8267               case 'l':
8268                 if (name[4] == 'o' &&
8269                     name[5] == 'g' &&
8270                     name[6] == 'i' &&
8271                     name[7] == 'n')
8272                 {                                 /* getlogin   */
8273                   return -KEY_getlogin;
8274                 }
8275
8276                 goto unknown;
8277
8278               case 'p':
8279                 if (name[4] == 'w')
8280                 {
8281                   switch (name[5])
8282                   {
8283                     case 'e':
8284                       if (name[6] == 'n' &&
8285                           name[7] == 't')
8286                       {                           /* getpwent   */
8287                         return -KEY_getpwent;
8288                       }
8289
8290                       goto unknown;
8291
8292                     case 'n':
8293                       if (name[6] == 'a' &&
8294                           name[7] == 'm')
8295                       {                           /* getpwnam   */
8296                         return -KEY_getpwnam;
8297                       }
8298
8299                       goto unknown;
8300
8301                     case 'u':
8302                       if (name[6] == 'i' &&
8303                           name[7] == 'd')
8304                       {                           /* getpwuid   */
8305                         return -KEY_getpwuid;
8306                       }
8307
8308                       goto unknown;
8309
8310                     default:
8311                       goto unknown;
8312                   }
8313                 }
8314
8315                 goto unknown;
8316
8317               default:
8318                 goto unknown;
8319             }
8320           }
8321
8322           goto unknown;
8323
8324         case 'r':
8325           if (name[1] == 'e' &&
8326               name[2] == 'a' &&
8327               name[3] == 'd')
8328           {
8329             switch (name[4])
8330             {
8331               case 'l':
8332                 if (name[5] == 'i' &&
8333                     name[6] == 'n')
8334                 {
8335                   switch (name[7])
8336                   {
8337                     case 'e':
8338                       {                           /* readline   */
8339                         return -KEY_readline;
8340                       }
8341
8342                     case 'k':
8343                       {                           /* readlink   */
8344                         return -KEY_readlink;
8345                       }
8346
8347                     default:
8348                       goto unknown;
8349                   }
8350                 }
8351
8352                 goto unknown;
8353
8354               case 'p':
8355                 if (name[5] == 'i' &&
8356                     name[6] == 'p' &&
8357                     name[7] == 'e')
8358                 {                                 /* readpipe   */
8359                   return -KEY_readpipe;
8360                 }
8361
8362                 goto unknown;
8363
8364               default:
8365                 goto unknown;
8366             }
8367           }
8368
8369           goto unknown;
8370
8371         case 's':
8372           switch (name[1])
8373           {
8374             case 'e':
8375               if (name[2] == 't')
8376               {
8377                 switch (name[3])
8378                 {
8379                   case 'g':
8380                     if (name[4] == 'r' &&
8381                         name[5] == 'e' &&
8382                         name[6] == 'n' &&
8383                         name[7] == 't')
8384                     {                             /* setgrent   */
8385                       return -KEY_setgrent;
8386                     }
8387
8388                     goto unknown;
8389
8390                   case 'p':
8391                     if (name[4] == 'w' &&
8392                         name[5] == 'e' &&
8393                         name[6] == 'n' &&
8394                         name[7] == 't')
8395                     {                             /* setpwent   */
8396                       return -KEY_setpwent;
8397                     }
8398
8399                     goto unknown;
8400
8401                   default:
8402                     goto unknown;
8403                 }
8404               }
8405
8406               goto unknown;
8407
8408             case 'h':
8409               switch (name[2])
8410               {
8411                 case 'm':
8412                   if (name[3] == 'w' &&
8413                       name[4] == 'r' &&
8414                       name[5] == 'i' &&
8415                       name[6] == 't' &&
8416                       name[7] == 'e')
8417                   {                               /* shmwrite   */
8418                     return -KEY_shmwrite;
8419                   }
8420
8421                   goto unknown;
8422
8423                 case 'u':
8424                   if (name[3] == 't' &&
8425                       name[4] == 'd' &&
8426                       name[5] == 'o' &&
8427                       name[6] == 'w' &&
8428                       name[7] == 'n')
8429                   {                               /* shutdown   */
8430                     return -KEY_shutdown;
8431                   }
8432
8433                   goto unknown;
8434
8435                 default:
8436                   goto unknown;
8437               }
8438
8439             case 'y':
8440               if (name[2] == 's' &&
8441                   name[3] == 'w' &&
8442                   name[4] == 'r' &&
8443                   name[5] == 'i' &&
8444                   name[6] == 't' &&
8445                   name[7] == 'e')
8446               {                                   /* syswrite   */
8447                 return -KEY_syswrite;
8448               }
8449
8450               goto unknown;
8451
8452             default:
8453               goto unknown;
8454           }
8455
8456         case 't':
8457           if (name[1] == 'r' &&
8458               name[2] == 'u' &&
8459               name[3] == 'n' &&
8460               name[4] == 'c' &&
8461               name[5] == 'a' &&
8462               name[6] == 't' &&
8463               name[7] == 'e')
8464           {                                       /* truncate   */
8465             return -KEY_truncate;
8466           }
8467
8468           goto unknown;
8469
8470         default:
8471           goto unknown;
8472       }
8473
8474     case 9: /* 8 tokens of length 9 */
8475       switch (name[0])
8476       {
8477         case 'e':
8478           if (name[1] == 'n' &&
8479               name[2] == 'd' &&
8480               name[3] == 'n' &&
8481               name[4] == 'e' &&
8482               name[5] == 't' &&
8483               name[6] == 'e' &&
8484               name[7] == 'n' &&
8485               name[8] == 't')
8486           {                                       /* endnetent  */
8487             return -KEY_endnetent;
8488           }
8489
8490           goto unknown;
8491
8492         case 'g':
8493           if (name[1] == 'e' &&
8494               name[2] == 't' &&
8495               name[3] == 'n' &&
8496               name[4] == 'e' &&
8497               name[5] == 't' &&
8498               name[6] == 'e' &&
8499               name[7] == 'n' &&
8500               name[8] == 't')
8501           {                                       /* getnetent  */
8502             return -KEY_getnetent;
8503           }
8504
8505           goto unknown;
8506
8507         case 'l':
8508           if (name[1] == 'o' &&
8509               name[2] == 'c' &&
8510               name[3] == 'a' &&
8511               name[4] == 'l' &&
8512               name[5] == 't' &&
8513               name[6] == 'i' &&
8514               name[7] == 'm' &&
8515               name[8] == 'e')
8516           {                                       /* localtime  */
8517             return -KEY_localtime;
8518           }
8519
8520           goto unknown;
8521
8522         case 'p':
8523           if (name[1] == 'r' &&
8524               name[2] == 'o' &&
8525               name[3] == 't' &&
8526               name[4] == 'o' &&
8527               name[5] == 't' &&
8528               name[6] == 'y' &&
8529               name[7] == 'p' &&
8530               name[8] == 'e')
8531           {                                       /* prototype  */
8532             return KEY_prototype;
8533           }
8534
8535           goto unknown;
8536
8537         case 'q':
8538           if (name[1] == 'u' &&
8539               name[2] == 'o' &&
8540               name[3] == 't' &&
8541               name[4] == 'e' &&
8542               name[5] == 'm' &&
8543               name[6] == 'e' &&
8544               name[7] == 't' &&
8545               name[8] == 'a')
8546           {                                       /* quotemeta  */
8547             return -KEY_quotemeta;
8548           }
8549
8550           goto unknown;
8551
8552         case 'r':
8553           if (name[1] == 'e' &&
8554               name[2] == 'w' &&
8555               name[3] == 'i' &&
8556               name[4] == 'n' &&
8557               name[5] == 'd' &&
8558               name[6] == 'd' &&
8559               name[7] == 'i' &&
8560               name[8] == 'r')
8561           {                                       /* rewinddir  */
8562             return -KEY_rewinddir;
8563           }
8564
8565           goto unknown;
8566
8567         case 's':
8568           if (name[1] == 'e' &&
8569               name[2] == 't' &&
8570               name[3] == 'n' &&
8571               name[4] == 'e' &&
8572               name[5] == 't' &&
8573               name[6] == 'e' &&
8574               name[7] == 'n' &&
8575               name[8] == 't')
8576           {                                       /* setnetent  */
8577             return -KEY_setnetent;
8578           }
8579
8580           goto unknown;
8581
8582         case 'w':
8583           if (name[1] == 'a' &&
8584               name[2] == 'n' &&
8585               name[3] == 't' &&
8586               name[4] == 'a' &&
8587               name[5] == 'r' &&
8588               name[6] == 'r' &&
8589               name[7] == 'a' &&
8590               name[8] == 'y')
8591           {                                       /* wantarray  */
8592             return -KEY_wantarray;
8593           }
8594
8595           goto unknown;
8596
8597         default:
8598           goto unknown;
8599       }
8600
8601     case 10: /* 9 tokens of length 10 */
8602       switch (name[0])
8603       {
8604         case 'e':
8605           if (name[1] == 'n' &&
8606               name[2] == 'd')
8607           {
8608             switch (name[3])
8609             {
8610               case 'h':
8611                 if (name[4] == 'o' &&
8612                     name[5] == 's' &&
8613                     name[6] == 't' &&
8614                     name[7] == 'e' &&
8615                     name[8] == 'n' &&
8616                     name[9] == 't')
8617                 {                                 /* endhostent */
8618                   return -KEY_endhostent;
8619                 }
8620
8621                 goto unknown;
8622
8623               case 's':
8624                 if (name[4] == 'e' &&
8625                     name[5] == 'r' &&
8626                     name[6] == 'v' &&
8627                     name[7] == 'e' &&
8628                     name[8] == 'n' &&
8629                     name[9] == 't')
8630                 {                                 /* endservent */
8631                   return -KEY_endservent;
8632                 }
8633
8634                 goto unknown;
8635
8636               default:
8637                 goto unknown;
8638             }
8639           }
8640
8641           goto unknown;
8642
8643         case 'g':
8644           if (name[1] == 'e' &&
8645               name[2] == 't')
8646           {
8647             switch (name[3])
8648             {
8649               case 'h':
8650                 if (name[4] == 'o' &&
8651                     name[5] == 's' &&
8652                     name[6] == 't' &&
8653                     name[7] == 'e' &&
8654                     name[8] == 'n' &&
8655                     name[9] == 't')
8656                 {                                 /* gethostent */
8657                   return -KEY_gethostent;
8658                 }
8659
8660                 goto unknown;
8661
8662               case 's':
8663                 switch (name[4])
8664                 {
8665                   case 'e':
8666                     if (name[5] == 'r' &&
8667                         name[6] == 'v' &&
8668                         name[7] == 'e' &&
8669                         name[8] == 'n' &&
8670                         name[9] == 't')
8671                     {                             /* getservent */
8672                       return -KEY_getservent;
8673                     }
8674
8675                     goto unknown;
8676
8677                   case 'o':
8678                     if (name[5] == 'c' &&
8679                         name[6] == 'k' &&
8680                         name[7] == 'o' &&
8681                         name[8] == 'p' &&
8682                         name[9] == 't')
8683                     {                             /* getsockopt */
8684                       return -KEY_getsockopt;
8685                     }
8686
8687                     goto unknown;
8688
8689                   default:
8690                     goto unknown;
8691                 }
8692
8693               default:
8694                 goto unknown;
8695             }
8696           }
8697
8698           goto unknown;
8699
8700         case 's':
8701           switch (name[1])
8702           {
8703             case 'e':
8704               if (name[2] == 't')
8705               {
8706                 switch (name[3])
8707                 {
8708                   case 'h':
8709                     if (name[4] == 'o' &&
8710                         name[5] == 's' &&
8711                         name[6] == 't' &&
8712                         name[7] == 'e' &&
8713                         name[8] == 'n' &&
8714                         name[9] == 't')
8715                     {                             /* sethostent */
8716                       return -KEY_sethostent;
8717                     }
8718
8719                     goto unknown;
8720
8721                   case 's':
8722                     switch (name[4])
8723                     {
8724                       case 'e':
8725                         if (name[5] == 'r' &&
8726                             name[6] == 'v' &&
8727                             name[7] == 'e' &&
8728                             name[8] == 'n' &&
8729                             name[9] == 't')
8730                         {                         /* setservent */
8731                           return -KEY_setservent;
8732                         }
8733
8734                         goto unknown;
8735
8736                       case 'o':
8737                         if (name[5] == 'c' &&
8738                             name[6] == 'k' &&
8739                             name[7] == 'o' &&
8740                             name[8] == 'p' &&
8741                             name[9] == 't')
8742                         {                         /* setsockopt */
8743                           return -KEY_setsockopt;
8744                         }
8745
8746                         goto unknown;
8747
8748                       default:
8749                         goto unknown;
8750                     }
8751
8752                   default:
8753                     goto unknown;
8754                 }
8755               }
8756
8757               goto unknown;
8758
8759             case 'o':
8760               if (name[2] == 'c' &&
8761                   name[3] == 'k' &&
8762                   name[4] == 'e' &&
8763                   name[5] == 't' &&
8764                   name[6] == 'p' &&
8765                   name[7] == 'a' &&
8766                   name[8] == 'i' &&
8767                   name[9] == 'r')
8768               {                                   /* socketpair */
8769                 return -KEY_socketpair;
8770               }
8771
8772               goto unknown;
8773
8774             default:
8775               goto unknown;
8776           }
8777
8778         default:
8779           goto unknown;
8780       }
8781
8782     case 11: /* 8 tokens of length 11 */
8783       switch (name[0])
8784       {
8785         case '_':
8786           if (name[1] == '_' &&
8787               name[2] == 'P' &&
8788               name[3] == 'A' &&
8789               name[4] == 'C' &&
8790               name[5] == 'K' &&
8791               name[6] == 'A' &&
8792               name[7] == 'G' &&
8793               name[8] == 'E' &&
8794               name[9] == '_' &&
8795               name[10] == '_')
8796           {                                       /* __PACKAGE__ */
8797             return -KEY___PACKAGE__;
8798           }
8799
8800           goto unknown;
8801
8802         case 'e':
8803           if (name[1] == 'n' &&
8804               name[2] == 'd' &&
8805               name[3] == 'p' &&
8806               name[4] == 'r' &&
8807               name[5] == 'o' &&
8808               name[6] == 't' &&
8809               name[7] == 'o' &&
8810               name[8] == 'e' &&
8811               name[9] == 'n' &&
8812               name[10] == 't')
8813           {                                       /* endprotoent */
8814             return -KEY_endprotoent;
8815           }
8816
8817           goto unknown;
8818
8819         case 'g':
8820           if (name[1] == 'e' &&
8821               name[2] == 't')
8822           {
8823             switch (name[3])
8824             {
8825               case 'p':
8826                 switch (name[4])
8827                 {
8828                   case 'e':
8829                     if (name[5] == 'e' &&
8830                         name[6] == 'r' &&
8831                         name[7] == 'n' &&
8832                         name[8] == 'a' &&
8833                         name[9] == 'm' &&
8834                         name[10] == 'e')
8835                     {                             /* getpeername */
8836                       return -KEY_getpeername;
8837                     }
8838
8839                     goto unknown;
8840
8841                   case 'r':
8842                     switch (name[5])
8843                     {
8844                       case 'i':
8845                         if (name[6] == 'o' &&
8846                             name[7] == 'r' &&
8847                             name[8] == 'i' &&
8848                             name[9] == 't' &&
8849                             name[10] == 'y')
8850                         {                         /* getpriority */
8851                           return -KEY_getpriority;
8852                         }
8853
8854                         goto unknown;
8855
8856                       case 'o':
8857                         if (name[6] == 't' &&
8858                             name[7] == 'o' &&
8859                             name[8] == 'e' &&
8860                             name[9] == 'n' &&
8861                             name[10] == 't')
8862                         {                         /* getprotoent */
8863                           return -KEY_getprotoent;
8864                         }
8865
8866                         goto unknown;
8867
8868                       default:
8869                         goto unknown;
8870                     }
8871
8872                   default:
8873                     goto unknown;
8874                 }
8875
8876               case 's':
8877                 if (name[4] == 'o' &&
8878                     name[5] == 'c' &&
8879                     name[6] == 'k' &&
8880                     name[7] == 'n' &&
8881                     name[8] == 'a' &&
8882                     name[9] == 'm' &&
8883                     name[10] == 'e')
8884                 {                                 /* getsockname */
8885                   return -KEY_getsockname;
8886                 }
8887
8888                 goto unknown;
8889
8890               default:
8891                 goto unknown;
8892             }
8893           }
8894
8895           goto unknown;
8896
8897         case 's':
8898           if (name[1] == 'e' &&
8899               name[2] == 't' &&
8900               name[3] == 'p' &&
8901               name[4] == 'r')
8902           {
8903             switch (name[5])
8904             {
8905               case 'i':
8906                 if (name[6] == 'o' &&
8907                     name[7] == 'r' &&
8908                     name[8] == 'i' &&
8909                     name[9] == 't' &&
8910                     name[10] == 'y')
8911                 {                                 /* setpriority */
8912                   return -KEY_setpriority;
8913                 }
8914
8915                 goto unknown;
8916
8917               case 'o':
8918                 if (name[6] == 't' &&
8919                     name[7] == 'o' &&
8920                     name[8] == 'e' &&
8921                     name[9] == 'n' &&
8922                     name[10] == 't')
8923                 {                                 /* setprotoent */
8924                   return -KEY_setprotoent;
8925                 }
8926
8927                 goto unknown;
8928
8929               default:
8930                 goto unknown;
8931             }
8932           }
8933
8934           goto unknown;
8935
8936         default:
8937           goto unknown;
8938       }
8939
8940     case 12: /* 2 tokens of length 12 */
8941       if (name[0] == 'g' &&
8942           name[1] == 'e' &&
8943           name[2] == 't' &&
8944           name[3] == 'n' &&
8945           name[4] == 'e' &&
8946           name[5] == 't' &&
8947           name[6] == 'b' &&
8948           name[7] == 'y')
8949       {
8950         switch (name[8])
8951         {
8952           case 'a':
8953             if (name[9] == 'd' &&
8954                 name[10] == 'd' &&
8955                 name[11] == 'r')
8956             {                                     /* getnetbyaddr */
8957               return -KEY_getnetbyaddr;
8958             }
8959
8960             goto unknown;
8961
8962           case 'n':
8963             if (name[9] == 'a' &&
8964                 name[10] == 'm' &&
8965                 name[11] == 'e')
8966             {                                     /* getnetbyname */
8967               return -KEY_getnetbyname;
8968             }
8969
8970             goto unknown;
8971
8972           default:
8973             goto unknown;
8974         }
8975       }
8976
8977       goto unknown;
8978
8979     case 13: /* 4 tokens of length 13 */
8980       if (name[0] == 'g' &&
8981           name[1] == 'e' &&
8982           name[2] == 't')
8983       {
8984         switch (name[3])
8985         {
8986           case 'h':
8987             if (name[4] == 'o' &&
8988                 name[5] == 's' &&
8989                 name[6] == 't' &&
8990                 name[7] == 'b' &&
8991                 name[8] == 'y')
8992             {
8993               switch (name[9])
8994               {
8995                 case 'a':
8996                   if (name[10] == 'd' &&
8997                       name[11] == 'd' &&
8998                       name[12] == 'r')
8999                   {                               /* gethostbyaddr */
9000                     return -KEY_gethostbyaddr;
9001                   }
9002
9003                   goto unknown;
9004
9005                 case 'n':
9006                   if (name[10] == 'a' &&
9007                       name[11] == 'm' &&
9008                       name[12] == 'e')
9009                   {                               /* gethostbyname */
9010                     return -KEY_gethostbyname;
9011                   }
9012
9013                   goto unknown;
9014
9015                 default:
9016                   goto unknown;
9017               }
9018             }
9019
9020             goto unknown;
9021
9022           case 's':
9023             if (name[4] == 'e' &&
9024                 name[5] == 'r' &&
9025                 name[6] == 'v' &&
9026                 name[7] == 'b' &&
9027                 name[8] == 'y')
9028             {
9029               switch (name[9])
9030               {
9031                 case 'n':
9032                   if (name[10] == 'a' &&
9033                       name[11] == 'm' &&
9034                       name[12] == 'e')
9035                   {                               /* getservbyname */
9036                     return -KEY_getservbyname;
9037                   }
9038
9039                   goto unknown;
9040
9041                 case 'p':
9042                   if (name[10] == 'o' &&
9043                       name[11] == 'r' &&
9044                       name[12] == 't')
9045                   {                               /* getservbyport */
9046                     return -KEY_getservbyport;
9047                   }
9048
9049                   goto unknown;
9050
9051                 default:
9052                   goto unknown;
9053               }
9054             }
9055
9056             goto unknown;
9057
9058           default:
9059             goto unknown;
9060         }
9061       }
9062
9063       goto unknown;
9064
9065     case 14: /* 1 tokens of length 14 */
9066       if (name[0] == 'g' &&
9067           name[1] == 'e' &&
9068           name[2] == 't' &&
9069           name[3] == 'p' &&
9070           name[4] == 'r' &&
9071           name[5] == 'o' &&
9072           name[6] == 't' &&
9073           name[7] == 'o' &&
9074           name[8] == 'b' &&
9075           name[9] == 'y' &&
9076           name[10] == 'n' &&
9077           name[11] == 'a' &&
9078           name[12] == 'm' &&
9079           name[13] == 'e')
9080       {                                           /* getprotobyname */
9081         return -KEY_getprotobyname;
9082       }
9083
9084       goto unknown;
9085
9086     case 16: /* 1 tokens of length 16 */
9087       if (name[0] == 'g' &&
9088           name[1] == 'e' &&
9089           name[2] == 't' &&
9090           name[3] == 'p' &&
9091           name[4] == 'r' &&
9092           name[5] == 'o' &&
9093           name[6] == 't' &&
9094           name[7] == 'o' &&
9095           name[8] == 'b' &&
9096           name[9] == 'y' &&
9097           name[10] == 'n' &&
9098           name[11] == 'u' &&
9099           name[12] == 'm' &&
9100           name[13] == 'b' &&
9101           name[14] == 'e' &&
9102           name[15] == 'r')
9103       {                                           /* getprotobynumber */
9104         return -KEY_getprotobynumber;
9105       }
9106
9107       goto unknown;
9108
9109     default:
9110       goto unknown;
9111   }
9112
9113 unknown:
9114   return 0;
9115 }
9116
9117 STATIC void
9118 S_checkcomma(pTHX_ register char *s, const char *name, const char *what)
9119 {
9120     const char *w;
9121
9122     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
9123         if (ckWARN(WARN_SYNTAX)) {
9124             int level = 1;
9125             for (w = s+2; *w && level; w++) {
9126                 if (*w == '(')
9127                     ++level;
9128                 else if (*w == ')')
9129                     --level;
9130             }
9131             if (*w)
9132                 for (; *w && isSPACE(*w); w++) ;
9133             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
9134                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9135                             "%s (...) interpreted as function",name);
9136         }
9137     }
9138     while (s < PL_bufend && isSPACE(*s))
9139         s++;
9140     if (*s == '(')
9141         s++;
9142     while (s < PL_bufend && isSPACE(*s))
9143         s++;
9144     if (isIDFIRST_lazy_if(s,UTF)) {
9145         w = s++;
9146         while (isALNUM_lazy_if(s,UTF))
9147             s++;
9148         while (s < PL_bufend && isSPACE(*s))
9149             s++;
9150         if (*s == ',') {
9151             I32 kw;
9152             *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */
9153             kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
9154             *s = ',';
9155             if (kw)
9156                 return;
9157             Perl_croak(aTHX_ "No comma allowed after %s", what);
9158         }
9159     }
9160 }
9161
9162 /* Either returns sv, or mortalizes sv and returns a new SV*.
9163    Best used as sv=new_constant(..., sv, ...).
9164    If s, pv are NULL, calls subroutine with one argument,
9165    and type is used with error messages only. */
9166
9167 STATIC SV *
9168 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
9169                const char *type)
9170 {
9171     dVAR; dSP;
9172     HV * const table = GvHV(PL_hintgv);          /* ^H */
9173     SV *res;
9174     SV **cvp;
9175     SV *cv, *typesv;
9176     const char *why1 = "", *why2 = "", *why3 = "";
9177
9178     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9179         SV *msg;
9180
9181         why2 = strEQ(key,"charnames")
9182                ? "(possibly a missing \"use charnames ...\")"
9183                : "";
9184         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
9185                             (type ? type: "undef"), why2);
9186
9187         /* This is convoluted and evil ("goto considered harmful")
9188          * but I do not understand the intricacies of all the different
9189          * failure modes of %^H in here.  The goal here is to make
9190          * the most probable error message user-friendly. --jhi */
9191
9192         goto msgdone;
9193
9194     report:
9195         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
9196                             (type ? type: "undef"), why1, why2, why3);
9197     msgdone:
9198         yyerror(SvPVX_const(msg));
9199         SvREFCNT_dec(msg);
9200         return sv;
9201     }
9202     cvp = hv_fetch(table, key, strlen(key), FALSE);
9203     if (!cvp || !SvOK(*cvp)) {
9204         why1 = "$^H{";
9205         why2 = key;
9206         why3 = "} is not defined";
9207         goto report;
9208     }
9209     sv_2mortal(sv);                     /* Parent created it permanently */
9210     cv = *cvp;
9211     if (!pv && s)
9212         pv = sv_2mortal(newSVpvn(s, len));
9213     if (type && pv)
9214         typesv = sv_2mortal(newSVpv(type, 0));
9215     else
9216         typesv = &PL_sv_undef;
9217
9218     PUSHSTACKi(PERLSI_OVERLOAD);
9219     ENTER ;
9220     SAVETMPS;
9221
9222     PUSHMARK(SP) ;
9223     EXTEND(sp, 3);
9224     if (pv)
9225         PUSHs(pv);
9226     PUSHs(sv);
9227     if (pv)
9228         PUSHs(typesv);
9229     PUTBACK;
9230     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9231
9232     SPAGAIN ;
9233
9234     /* Check the eval first */
9235     if (!PL_in_eval && SvTRUE(ERRSV)) {
9236         sv_catpv(ERRSV, "Propagated");
9237         yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
9238         (void)POPs;
9239         res = SvREFCNT_inc(sv);
9240     }
9241     else {
9242         res = POPs;
9243         (void)SvREFCNT_inc(res);
9244     }
9245
9246     PUTBACK ;
9247     FREETMPS ;
9248     LEAVE ;
9249     POPSTACK;
9250
9251     if (!SvOK(res)) {
9252         why1 = "Call to &{$^H{";
9253         why2 = key;
9254         why3 = "}} did not return a defined value";
9255         sv = res;
9256         goto report;
9257     }
9258
9259     return res;
9260 }
9261
9262 /* Returns a NUL terminated string, with the length of the string written to
9263    *slp
9264    */
9265 STATIC char *
9266 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9267 {
9268     register char *d = dest;
9269     register char * const e = d + destlen - 3;  /* two-character token, ending NUL */
9270     for (;;) {
9271         if (d >= e)
9272             Perl_croak(aTHX_ ident_too_long);
9273         if (isALNUM(*s))        /* UTF handled below */
9274             *d++ = *s++;
9275         else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
9276             *d++ = ':';
9277             *d++ = ':';
9278             s++;
9279         }
9280         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
9281             *d++ = *s++;
9282             *d++ = *s++;
9283         }
9284         else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9285             char *t = s + UTF8SKIP(s);
9286             while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9287                 t += UTF8SKIP(t);
9288             if (d + (t - s) > e)
9289                 Perl_croak(aTHX_ ident_too_long);
9290             Copy(s, d, t - s, char);
9291             d += t - s;
9292             s = t;
9293         }
9294         else {
9295             *d = '\0';
9296             *slp = d - dest;
9297             return s;
9298         }
9299     }
9300 }
9301
9302 STATIC char *
9303 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9304 {
9305     register char *d;
9306     register char *e;
9307     char *bracket = Nullch;
9308     char funny = *s++;
9309
9310     if (isSPACE(*s))
9311         s = skipspace(s);
9312     d = dest;
9313     e = d + destlen - 3;        /* two-character token, ending NUL */
9314     if (isDIGIT(*s)) {
9315         while (isDIGIT(*s)) {
9316             if (d >= e)
9317                 Perl_croak(aTHX_ ident_too_long);
9318             *d++ = *s++;
9319         }
9320     }
9321     else {
9322         for (;;) {
9323             if (d >= e)
9324                 Perl_croak(aTHX_ ident_too_long);
9325             if (isALNUM(*s))    /* UTF handled below */
9326                 *d++ = *s++;
9327             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
9328                 *d++ = ':';
9329                 *d++ = ':';
9330                 s++;
9331             }
9332             else if (*s == ':' && s[1] == ':') {
9333                 *d++ = *s++;
9334                 *d++ = *s++;
9335             }
9336             else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9337                 char *t = s + UTF8SKIP(s);
9338                 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9339                     t += UTF8SKIP(t);
9340                 if (d + (t - s) > e)
9341                     Perl_croak(aTHX_ ident_too_long);
9342                 Copy(s, d, t - s, char);
9343                 d += t - s;
9344                 s = t;
9345             }
9346             else
9347                 break;
9348         }
9349     }
9350     *d = '\0';
9351     d = dest;
9352     if (*d) {
9353         if (PL_lex_state != LEX_NORMAL)
9354             PL_lex_state = LEX_INTERPENDMAYBE;
9355         return s;
9356     }
9357     if (*s == '$' && s[1] &&
9358         (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
9359     {
9360         return s;
9361     }
9362     if (*s == '{') {
9363         bracket = s;
9364         s++;
9365     }
9366     else if (ck_uni)
9367         check_uni();
9368     if (s < send)
9369         *d = *s++;
9370     d[1] = '\0';
9371     if (*d == '^' && *s && isCONTROLVAR(*s)) {
9372         *d = toCTRL(*s);
9373         s++;
9374     }
9375     if (bracket) {
9376         if (isSPACE(s[-1])) {
9377             while (s < send) {
9378                 const char ch = *s++;
9379                 if (!SPACE_OR_TAB(ch)) {
9380                     *d = ch;
9381                     break;
9382                 }
9383             }
9384         }
9385         if (isIDFIRST_lazy_if(d,UTF)) {
9386             d++;
9387             if (UTF) {
9388                 e = s;
9389                 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
9390                     e += UTF8SKIP(e);
9391                     while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
9392                         e += UTF8SKIP(e);
9393                 }
9394                 Copy(s, d, e - s, char);
9395                 d += e - s;
9396                 s = e;
9397             }
9398             else {
9399                 while ((isALNUM(*s) || *s == ':') && d < e)
9400                     *d++ = *s++;
9401                 if (d >= e)
9402                     Perl_croak(aTHX_ ident_too_long);
9403             }
9404             *d = '\0';
9405             while (s < send && SPACE_OR_TAB(*s)) s++;
9406             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9407                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
9408                     const char *brack = *s == '[' ? "[...]" : "{...}";
9409                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9410                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9411                         funny, dest, brack, funny, dest, brack);
9412                 }
9413                 bracket++;
9414                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9415                 return s;
9416             }
9417         }
9418         /* Handle extended ${^Foo} variables
9419          * 1999-02-27 mjd-perl-patch@plover.com */
9420         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
9421                  && isALNUM(*s))
9422         {
9423             d++;
9424             while (isALNUM(*s) && d < e) {
9425                 *d++ = *s++;
9426             }
9427             if (d >= e)
9428                 Perl_croak(aTHX_ ident_too_long);
9429             *d = '\0';
9430         }
9431         if (*s == '}') {
9432             s++;
9433             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9434                 PL_lex_state = LEX_INTERPEND;
9435                 PL_expect = XREF;
9436             }
9437             if (funny == '#')
9438                 funny = '@';
9439             if (PL_lex_state == LEX_NORMAL) {
9440                 if (ckWARN(WARN_AMBIGUOUS) &&
9441                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
9442                 {
9443                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9444                         "Ambiguous use of %c{%s} resolved to %c%s",
9445                         funny, dest, funny, dest);
9446                 }
9447             }
9448         }
9449         else {
9450             s = bracket;                /* let the parser handle it */
9451             *dest = '\0';
9452         }
9453     }
9454     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9455         PL_lex_state = LEX_INTERPEND;
9456     return s;
9457 }
9458
9459 void
9460 Perl_pmflag(pTHX_ U32* pmfl, int ch)
9461 {
9462     if (ch == 'i')
9463         *pmfl |= PMf_FOLD;
9464     else if (ch == 'g')
9465         *pmfl |= PMf_GLOBAL;
9466     else if (ch == 'c')
9467         *pmfl |= PMf_CONTINUE;
9468     else if (ch == 'o')
9469         *pmfl |= PMf_KEEP;
9470     else if (ch == 'm')
9471         *pmfl |= PMf_MULTILINE;
9472     else if (ch == 's')
9473         *pmfl |= PMf_SINGLELINE;
9474     else if (ch == 'x')
9475         *pmfl |= PMf_EXTENDED;
9476 }
9477
9478 STATIC char *
9479 S_scan_pat(pTHX_ char *start, I32 type)
9480 {
9481     PMOP *pm;
9482     char *s = scan_str(start,FALSE,FALSE);
9483
9484     if (!s) {
9485         char * const delimiter = skipspace(start);
9486         Perl_croak(aTHX_ *delimiter == '?'
9487                    ? "Search pattern not terminated or ternary operator parsed as search pattern"
9488                    : "Search pattern not terminated" );
9489     }
9490
9491     pm = (PMOP*)newPMOP(type, 0);
9492     if (PL_multi_open == '?')
9493         pm->op_pmflags |= PMf_ONCE;
9494     if(type == OP_QR) {
9495         while (*s && strchr("iomsx", *s))
9496             pmflag(&pm->op_pmflags,*s++);
9497     }
9498     else {
9499         while (*s && strchr("iogcmsx", *s))
9500             pmflag(&pm->op_pmflags,*s++);
9501     }
9502     /* issue a warning if /c is specified,but /g is not */
9503     if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
9504             && ckWARN(WARN_REGEXP))
9505     {
9506         Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
9507     }
9508
9509     pm->op_pmpermflags = pm->op_pmflags;
9510
9511     PL_lex_op = (OP*)pm;
9512     yylval.ival = OP_MATCH;
9513     return s;
9514 }
9515
9516 STATIC char *
9517 S_scan_subst(pTHX_ char *start)
9518 {
9519     dVAR;
9520     register char *s;
9521     register PMOP *pm;
9522     I32 first_start;
9523     I32 es = 0;
9524
9525     yylval.ival = OP_NULL;
9526
9527     s = scan_str(start,FALSE,FALSE);
9528
9529     if (!s)
9530         Perl_croak(aTHX_ "Substitution pattern not terminated");
9531
9532     if (s[-1] == PL_multi_open)
9533         s--;
9534
9535     first_start = PL_multi_start;
9536     s = scan_str(s,FALSE,FALSE);
9537     if (!s) {
9538         if (PL_lex_stuff) {
9539             SvREFCNT_dec(PL_lex_stuff);
9540             PL_lex_stuff = Nullsv;
9541         }
9542         Perl_croak(aTHX_ "Substitution replacement not terminated");
9543     }
9544     PL_multi_start = first_start;       /* so whole substitution is taken together */
9545
9546     pm = (PMOP*)newPMOP(OP_SUBST, 0);
9547     while (*s) {
9548         if (*s == 'e') {
9549             s++;
9550             es++;
9551         }
9552         else if (strchr("iogcmsx", *s))
9553             pmflag(&pm->op_pmflags,*s++);
9554         else
9555             break;
9556     }
9557
9558     if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
9559         Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9560     }
9561
9562     if (es) {
9563         SV *repl;
9564         PL_sublex_info.super_bufptr = s;
9565         PL_sublex_info.super_bufend = PL_bufend;
9566         PL_multi_end = 0;
9567         pm->op_pmflags |= PMf_EVAL;
9568         repl = newSVpvn("",0);
9569         while (es-- > 0)
9570             sv_catpv(repl, es ? "eval " : "do ");
9571         sv_catpvn(repl, "{ ", 2);
9572         sv_catsv(repl, PL_lex_repl);
9573         sv_catpvn(repl, " };", 2);
9574         SvEVALED_on(repl);
9575         SvREFCNT_dec(PL_lex_repl);
9576         PL_lex_repl = repl;
9577     }
9578
9579     pm->op_pmpermflags = pm->op_pmflags;
9580     PL_lex_op = (OP*)pm;
9581     yylval.ival = OP_SUBST;
9582     return s;
9583 }
9584
9585 STATIC char *
9586 S_scan_trans(pTHX_ char *start)
9587 {
9588     register char* s;
9589     OP *o;
9590     short *tbl;
9591     I32 squash;
9592     I32 del;
9593     I32 complement;
9594
9595     yylval.ival = OP_NULL;
9596
9597     s = scan_str(start,FALSE,FALSE);
9598     if (!s)
9599         Perl_croak(aTHX_ "Transliteration pattern not terminated");
9600     if (s[-1] == PL_multi_open)
9601         s--;
9602
9603     s = scan_str(s,FALSE,FALSE);
9604     if (!s) {
9605         if (PL_lex_stuff) {
9606             SvREFCNT_dec(PL_lex_stuff);
9607             PL_lex_stuff = Nullsv;
9608         }
9609         Perl_croak(aTHX_ "Transliteration replacement not terminated");
9610     }
9611
9612     complement = del = squash = 0;
9613     while (1) {
9614         switch (*s) {
9615         case 'c':
9616             complement = OPpTRANS_COMPLEMENT;
9617             break;
9618         case 'd':
9619             del = OPpTRANS_DELETE;
9620             break;
9621         case 's':
9622             squash = OPpTRANS_SQUASH;
9623             break;
9624         default:
9625             goto no_more;
9626         }
9627         s++;
9628     }
9629   no_more:
9630
9631     Newx(tbl, complement&&!del?258:256, short);
9632     o = newPVOP(OP_TRANS, 0, (char*)tbl);
9633     o->op_private &= ~OPpTRANS_ALL;
9634     o->op_private |= del|squash|complement|
9635       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9636       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
9637
9638     PL_lex_op = o;
9639     yylval.ival = OP_TRANS;
9640     return s;
9641 }
9642
9643 STATIC char *
9644 S_scan_heredoc(pTHX_ register char *s)
9645 {
9646     SV *herewas;
9647     I32 op_type = OP_SCALAR;
9648     I32 len;
9649     SV *tmpstr;
9650     char term;
9651     const char newline[] = "\n";
9652     const char *found_newline;
9653     register char *d;
9654     register char *e;
9655     char *peek;
9656     const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9657
9658     s += 2;
9659     d = PL_tokenbuf;
9660     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9661     if (!outer)
9662         *d++ = '\n';
9663     for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
9664     if (*peek == '`' || *peek == '\'' || *peek =='"') {
9665         s = peek;
9666         term = *s++;
9667         s = delimcpy(d, e, s, PL_bufend, term, &len);
9668         d += len;
9669         if (s < PL_bufend)
9670             s++;
9671     }
9672     else {
9673         if (*s == '\\')
9674             s++, term = '\'';
9675         else
9676             term = '"';
9677         if (!isALNUM_lazy_if(s,UTF))
9678             deprecate_old("bare << to mean <<\"\"");
9679         for (; isALNUM_lazy_if(s,UTF); s++) {
9680             if (d < e)
9681                 *d++ = *s;
9682         }
9683     }
9684     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9685         Perl_croak(aTHX_ "Delimiter for here document is too long");
9686     *d++ = '\n';
9687     *d = '\0';
9688     len = d - PL_tokenbuf;
9689 #ifndef PERL_STRICT_CR
9690     d = strchr(s, '\r');
9691     if (d) {
9692         char * const olds = s;
9693         s = d;
9694         while (s < PL_bufend) {
9695             if (*s == '\r') {
9696                 *d++ = '\n';
9697                 if (*++s == '\n')
9698                     s++;
9699             }
9700             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
9701                 *d++ = *s++;
9702                 s++;
9703             }
9704             else
9705                 *d++ = *s++;
9706         }
9707         *d = '\0';
9708         PL_bufend = d;
9709         SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9710         s = olds;
9711     }
9712 #endif
9713     if ( outer || !(found_newline = ninstr(s,PL_bufend,newline,newline+1)) ) {
9714         herewas = newSVpvn(s,PL_bufend-s);
9715     }
9716     else {
9717         s--;
9718         herewas = newSVpvn(s,found_newline-s);
9719     }
9720     s += SvCUR(herewas);
9721
9722     tmpstr = NEWSV(87,79);
9723     sv_upgrade(tmpstr, SVt_PVIV);
9724     if (term == '\'') {
9725         op_type = OP_CONST;
9726         SvIV_set(tmpstr, -1);
9727     }
9728     else if (term == '`') {
9729         op_type = OP_BACKTICK;
9730         SvIV_set(tmpstr, '\\');
9731     }
9732
9733     CLINE;
9734     PL_multi_start = CopLINE(PL_curcop);
9735     PL_multi_open = PL_multi_close = '<';
9736     term = *PL_tokenbuf;
9737     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9738         char *bufptr = PL_sublex_info.super_bufptr;
9739         char *bufend = PL_sublex_info.super_bufend;
9740         char * const olds = s - SvCUR(herewas);
9741         s = strchr(bufptr, '\n');
9742         if (!s)
9743             s = bufend;
9744         d = s;
9745         while (s < bufend &&
9746           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9747             if (*s++ == '\n')
9748                 CopLINE_inc(PL_curcop);
9749         }
9750         if (s >= bufend) {
9751             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9752             missingterm(PL_tokenbuf);
9753         }
9754         sv_setpvn(herewas,bufptr,d-bufptr+1);
9755         sv_setpvn(tmpstr,d+1,s-d);
9756         s += len - 1;
9757         sv_catpvn(herewas,s,bufend-s);
9758         Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9759
9760         s = olds;
9761         goto retval;
9762     }
9763     else if (!outer) {
9764         d = s;
9765         while (s < PL_bufend &&
9766           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9767             if (*s++ == '\n')
9768                 CopLINE_inc(PL_curcop);
9769         }
9770         if (s >= PL_bufend) {
9771             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9772             missingterm(PL_tokenbuf);
9773         }
9774         sv_setpvn(tmpstr,d+1,s-d);
9775         s += len - 1;
9776         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9777
9778         sv_catpvn(herewas,s,PL_bufend-s);
9779         sv_setsv(PL_linestr,herewas);
9780         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9781         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9782         PL_last_lop = PL_last_uni = Nullch;
9783     }
9784     else
9785         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
9786     while (s >= PL_bufend) {    /* multiple line string? */
9787         if (!outer ||
9788          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
9789             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9790             missingterm(PL_tokenbuf);
9791         }
9792         CopLINE_inc(PL_curcop);
9793         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9794         PL_last_lop = PL_last_uni = Nullch;
9795 #ifndef PERL_STRICT_CR
9796         if (PL_bufend - PL_linestart >= 2) {
9797             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9798                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9799             {
9800                 PL_bufend[-2] = '\n';
9801                 PL_bufend--;
9802                 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9803             }
9804             else if (PL_bufend[-1] == '\r')
9805                 PL_bufend[-1] = '\n';
9806         }
9807         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9808             PL_bufend[-1] = '\n';
9809 #endif
9810         if (PERLDB_LINE && PL_curstash != PL_debstash) {
9811             SV *sv = NEWSV(88,0);
9812
9813             sv_upgrade(sv, SVt_PVMG);
9814             sv_setsv(sv,PL_linestr);
9815             (void)SvIOK_on(sv);
9816             SvIV_set(sv, 0);
9817             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
9818         }
9819         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9820             STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
9821             *(SvPVX(PL_linestr) + off ) = ' ';
9822             sv_catsv(PL_linestr,herewas);
9823             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9824             s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9825         }
9826         else {
9827             s = PL_bufend;
9828             sv_catsv(tmpstr,PL_linestr);
9829         }
9830     }
9831     s++;
9832 retval:
9833     PL_multi_end = CopLINE(PL_curcop);
9834     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9835         SvPV_shrink_to_cur(tmpstr);
9836     }
9837     SvREFCNT_dec(herewas);
9838     if (!IN_BYTES) {
9839         if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9840             SvUTF8_on(tmpstr);
9841         else if (PL_encoding)
9842             sv_recode_to_utf8(tmpstr, PL_encoding);
9843     }
9844     PL_lex_stuff = tmpstr;
9845     yylval.ival = op_type;
9846     return s;
9847 }
9848
9849 /* scan_inputsymbol
9850    takes: current position in input buffer
9851    returns: new position in input buffer
9852    side-effects: yylval and lex_op are set.
9853
9854    This code handles:
9855
9856    <>           read from ARGV
9857    <FH>         read from filehandle
9858    <pkg::FH>    read from package qualified filehandle
9859    <pkg'FH>     read from package qualified filehandle
9860    <$fh>        read from filehandle in $fh
9861    <*.h>        filename glob
9862
9863 */
9864
9865 STATIC char *
9866 S_scan_inputsymbol(pTHX_ char *start)
9867 {
9868     register char *s = start;           /* current position in buffer */
9869     register char *d;
9870     const char *e;
9871     char *end;
9872     I32 len;
9873
9874     d = PL_tokenbuf;                    /* start of temp holding space */
9875     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
9876     end = strchr(s, '\n');
9877     if (!end)
9878         end = PL_bufend;
9879     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
9880
9881     /* die if we didn't have space for the contents of the <>,
9882        or if it didn't end, or if we see a newline
9883     */
9884
9885     if (len >= sizeof PL_tokenbuf)
9886         Perl_croak(aTHX_ "Excessively long <> operator");
9887     if (s >= end)
9888         Perl_croak(aTHX_ "Unterminated <> operator");
9889
9890     s++;
9891
9892     /* check for <$fh>
9893        Remember, only scalar variables are interpreted as filehandles by
9894        this code.  Anything more complex (e.g., <$fh{$num}>) will be
9895        treated as a glob() call.
9896        This code makes use of the fact that except for the $ at the front,
9897        a scalar variable and a filehandle look the same.
9898     */
9899     if (*d == '$' && d[1]) d++;
9900
9901     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9902     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9903         d++;
9904
9905     /* If we've tried to read what we allow filehandles to look like, and
9906        there's still text left, then it must be a glob() and not a getline.
9907        Use scan_str to pull out the stuff between the <> and treat it
9908        as nothing more than a string.
9909     */
9910
9911     if (d - PL_tokenbuf != len) {
9912         yylval.ival = OP_GLOB;
9913         set_csh();
9914         s = scan_str(start,FALSE,FALSE);
9915         if (!s)
9916            Perl_croak(aTHX_ "Glob not terminated");
9917         return s;
9918     }
9919     else {
9920         bool readline_overriden = FALSE;
9921         GV *gv_readline = Nullgv;
9922         GV **gvp;
9923         /* we're in a filehandle read situation */
9924         d = PL_tokenbuf;
9925
9926         /* turn <> into <ARGV> */
9927         if (!len)
9928             Copy("ARGV",d,5,char);
9929
9930         /* Check whether readline() is overriden */
9931         if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
9932                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9933                 ||
9934                 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
9935                 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
9936                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9937             readline_overriden = TRUE;
9938
9939         /* if <$fh>, create the ops to turn the variable into a
9940            filehandle
9941         */
9942         if (*d == '$') {
9943             I32 tmp;
9944
9945             /* try to find it in the pad for this block, otherwise find
9946                add symbol table ops
9947             */
9948             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
9949                 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
9950                     HV *stash = PAD_COMPNAME_OURSTASH(tmp);
9951                     HEK *stashname = HvNAME_HEK(stash);
9952                     SV *sym = sv_2mortal(newSVhek(stashname));
9953                     sv_catpvn(sym, "::", 2);
9954                     sv_catpv(sym, d+1);
9955                     d = SvPVX(sym);
9956                     goto intro_sym;
9957                 }
9958                 else {
9959                     OP *o = newOP(OP_PADSV, 0);
9960                     o->op_targ = tmp;
9961                     PL_lex_op = readline_overriden
9962                         ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9963                                 append_elem(OP_LIST, o,
9964                                     newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9965                         : (OP*)newUNOP(OP_READLINE, 0, o);
9966                 }
9967             }
9968             else {
9969                 GV *gv;
9970                 ++d;
9971 intro_sym:
9972                 gv = gv_fetchpv(d,
9973                                 (PL_in_eval
9974                                  ? (GV_ADDMULTI | GV_ADDINEVAL)
9975                                  : GV_ADDMULTI),
9976                                 SVt_PV);
9977                 PL_lex_op = readline_overriden
9978                     ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9979                             append_elem(OP_LIST,
9980                                 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9981                                 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9982                     : (OP*)newUNOP(OP_READLINE, 0,
9983                             newUNOP(OP_RV2SV, 0,
9984                                 newGVOP(OP_GV, 0, gv)));
9985             }
9986             if (!readline_overriden)
9987                 PL_lex_op->op_flags |= OPf_SPECIAL;
9988             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
9989             yylval.ival = OP_NULL;
9990         }
9991
9992         /* If it's none of the above, it must be a literal filehandle
9993            (<Foo::BAR> or <FOO>) so build a simple readline OP */
9994         else {
9995             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
9996             PL_lex_op = readline_overriden
9997                 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9998                         append_elem(OP_LIST,
9999                             newGVOP(OP_GV, 0, gv),
10000                             newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10001                 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
10002             yylval.ival = OP_NULL;
10003         }
10004     }
10005
10006     return s;
10007 }
10008
10009
10010 /* scan_str
10011    takes: start position in buffer
10012           keep_quoted preserve \ on the embedded delimiter(s)
10013           keep_delims preserve the delimiters around the string
10014    returns: position to continue reading from buffer
10015    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10016         updates the read buffer.
10017
10018    This subroutine pulls a string out of the input.  It is called for:
10019         q               single quotes           q(literal text)
10020         '               single quotes           'literal text'
10021         qq              double quotes           qq(interpolate $here please)
10022         "               double quotes           "interpolate $here please"
10023         qx              backticks               qx(/bin/ls -l)
10024         `               backticks               `/bin/ls -l`
10025         qw              quote words             @EXPORT_OK = qw( func() $spam )
10026         m//             regexp match            m/this/
10027         s///            regexp substitute       s/this/that/
10028         tr///           string transliterate    tr/this/that/
10029         y///            string transliterate    y/this/that/
10030         ($*@)           sub prototypes          sub foo ($)
10031         (stuff)         sub attr parameters     sub foo : attr(stuff)
10032         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
10033
10034    In most of these cases (all but <>, patterns and transliterate)
10035    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
10036    calls scan_str().  s/// makes yylex() call scan_subst() which calls
10037    scan_str().  tr/// and y/// make yylex() call scan_trans() which
10038    calls scan_str().
10039
10040    It skips whitespace before the string starts, and treats the first
10041    character as the delimiter.  If the delimiter is one of ([{< then
10042    the corresponding "close" character )]}> is used as the closing
10043    delimiter.  It allows quoting of delimiters, and if the string has
10044    balanced delimiters ([{<>}]) it allows nesting.
10045
10046    On success, the SV with the resulting string is put into lex_stuff or,
10047    if that is already non-NULL, into lex_repl. The second case occurs only
10048    when parsing the RHS of the special constructs s/// and tr/// (y///).
10049    For convenience, the terminating delimiter character is stuffed into
10050    SvIVX of the SV.
10051 */
10052
10053 STATIC char *
10054 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
10055 {
10056     SV *sv;                             /* scalar value: string */
10057     char *tmps;                         /* temp string, used for delimiter matching */
10058     register char *s = start;           /* current position in the buffer */
10059     register char term;                 /* terminating character */
10060     register char *to;                  /* current position in the sv's data */
10061     I32 brackets = 1;                   /* bracket nesting level */
10062     bool has_utf8 = FALSE;              /* is there any utf8 content? */
10063     I32 termcode;                       /* terminating char. code */
10064     U8 termstr[UTF8_MAXBYTES];          /* terminating string */
10065     STRLEN termlen;                     /* length of terminating string */
10066     char *last = NULL;                  /* last position for nesting bracket */
10067
10068     /* skip space before the delimiter */
10069     if (isSPACE(*s))
10070         s = skipspace(s);
10071
10072     /* mark where we are, in case we need to report errors */
10073     CLINE;
10074
10075     /* after skipping whitespace, the next character is the terminator */
10076     term = *s;
10077     if (!UTF) {
10078         termcode = termstr[0] = term;
10079         termlen = 1;
10080     }
10081     else {
10082         termcode = utf8_to_uvchr((U8*)s, &termlen);
10083         Copy(s, termstr, termlen, U8);
10084         if (!UTF8_IS_INVARIANT(term))
10085             has_utf8 = TRUE;
10086     }
10087
10088     /* mark where we are */
10089     PL_multi_start = CopLINE(PL_curcop);
10090     PL_multi_open = term;
10091
10092     /* find corresponding closing delimiter */
10093     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
10094         termcode = termstr[0] = term = tmps[5];
10095
10096     PL_multi_close = term;
10097
10098     /* create a new SV to hold the contents.  87 is leak category, I'm
10099        assuming.  79 is the SV's initial length.  What a random number. */
10100     sv = NEWSV(87,79);
10101     sv_upgrade(sv, SVt_PVIV);
10102     SvIV_set(sv, termcode);
10103     (void)SvPOK_only(sv);               /* validate pointer */
10104
10105     /* move past delimiter and try to read a complete string */
10106     if (keep_delims)
10107         sv_catpvn(sv, s, termlen);
10108     s += termlen;
10109     for (;;) {
10110         if (PL_encoding && !UTF) {
10111             bool cont = TRUE;
10112
10113             while (cont) {
10114                 int offset = s - SvPVX_const(PL_linestr);
10115                 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
10116                                            &offset, (char*)termstr, termlen);
10117                 const char *ns = SvPVX_const(PL_linestr) + offset;
10118                 char *svlast = SvEND(sv) - 1;
10119
10120                 for (; s < ns; s++) {
10121                     if (*s == '\n' && !PL_rsfp)
10122                         CopLINE_inc(PL_curcop);
10123                 }
10124                 if (!found)
10125                     goto read_more_line;
10126                 else {
10127                     /* handle quoted delimiters */
10128                     if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
10129                         const char *t;
10130                         for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
10131                             t--;
10132                         if ((svlast-1 - t) % 2) {
10133                             if (!keep_quoted) {
10134                                 *(svlast-1) = term;
10135                                 *svlast = '\0';
10136                                 SvCUR_set(sv, SvCUR(sv) - 1);
10137                             }
10138                             continue;
10139                         }
10140                     }
10141                     if (PL_multi_open == PL_multi_close) {
10142                         cont = FALSE;
10143                     }
10144                     else {
10145                         const char *t;
10146                         char *w;
10147                         if (!last)
10148                             last = SvPVX(sv);
10149                         for (t = w = last; t < svlast; w++, t++) {
10150                             /* At here, all closes are "was quoted" one,
10151                                so we don't check PL_multi_close. */
10152                             if (*t == '\\') {
10153                                 if (!keep_quoted && *(t+1) == PL_multi_open)
10154                                     t++;
10155                                 else
10156                                     *w++ = *t++;
10157                             }
10158                             else if (*t == PL_multi_open)
10159                                 brackets++;
10160
10161                             *w = *t;
10162                         }
10163                         if (w < t) {
10164                             *w++ = term;
10165                             *w = '\0';
10166                             SvCUR_set(sv, w - SvPVX_const(sv));
10167                         }
10168                         last = w;
10169                         if (--brackets <= 0)
10170                             cont = FALSE;
10171                     }
10172                 }
10173             }
10174             if (!keep_delims) {
10175                 SvCUR_set(sv, SvCUR(sv) - 1);
10176                 *SvEND(sv) = '\0';
10177             }
10178             break;
10179         }
10180
10181         /* extend sv if need be */
10182         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10183         /* set 'to' to the next character in the sv's string */
10184         to = SvPVX(sv)+SvCUR(sv);
10185
10186         /* if open delimiter is the close delimiter read unbridle */
10187         if (PL_multi_open == PL_multi_close) {
10188             for (; s < PL_bufend; s++,to++) {
10189                 /* embedded newlines increment the current line number */
10190                 if (*s == '\n' && !PL_rsfp)
10191                     CopLINE_inc(PL_curcop);
10192                 /* handle quoted delimiters */
10193                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10194                     if (!keep_quoted && s[1] == term)
10195                         s++;
10196                 /* any other quotes are simply copied straight through */
10197                     else
10198                         *to++ = *s++;
10199                 }
10200                 /* terminate when run out of buffer (the for() condition), or
10201                    have found the terminator */
10202                 else if (*s == term) {
10203                     if (termlen == 1)
10204                         break;
10205                     if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10206                         break;
10207                 }
10208                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10209                     has_utf8 = TRUE;
10210                 *to = *s;
10211             }
10212         }
10213
10214         /* if the terminator isn't the same as the start character (e.g.,
10215            matched brackets), we have to allow more in the quoting, and
10216            be prepared for nested brackets.
10217         */
10218         else {
10219             /* read until we run out of string, or we find the terminator */
10220             for (; s < PL_bufend; s++,to++) {
10221                 /* embedded newlines increment the line count */
10222                 if (*s == '\n' && !PL_rsfp)
10223                     CopLINE_inc(PL_curcop);
10224                 /* backslashes can escape the open or closing characters */
10225                 if (*s == '\\' && s+1 < PL_bufend) {
10226                     if (!keep_quoted &&
10227                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10228                         s++;
10229                     else
10230                         *to++ = *s++;
10231                 }
10232                 /* allow nested opens and closes */
10233                 else if (*s == PL_multi_close && --brackets <= 0)
10234                     break;
10235                 else if (*s == PL_multi_open)
10236                     brackets++;
10237                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10238                     has_utf8 = TRUE;
10239                 *to = *s;
10240             }
10241         }
10242         /* terminate the copied string and update the sv's end-of-string */
10243         *to = '\0';
10244         SvCUR_set(sv, to - SvPVX_const(sv));
10245
10246         /*
10247          * this next chunk reads more into the buffer if we're not done yet
10248          */
10249
10250         if (s < PL_bufend)
10251             break;              /* handle case where we are done yet :-) */
10252
10253 #ifndef PERL_STRICT_CR
10254         if (to - SvPVX_const(sv) >= 2) {
10255             if ((to[-2] == '\r' && to[-1] == '\n') ||
10256                 (to[-2] == '\n' && to[-1] == '\r'))
10257             {
10258                 to[-2] = '\n';
10259                 to--;
10260                 SvCUR_set(sv, to - SvPVX_const(sv));
10261             }
10262             else if (to[-1] == '\r')
10263                 to[-1] = '\n';
10264         }
10265         else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10266             to[-1] = '\n';
10267 #endif
10268
10269      read_more_line:
10270         /* if we're out of file, or a read fails, bail and reset the current
10271            line marker so we can report where the unterminated string began
10272         */
10273         if (!PL_rsfp ||
10274          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
10275             sv_free(sv);
10276             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10277             return Nullch;
10278         }
10279         /* we read a line, so increment our line counter */
10280         CopLINE_inc(PL_curcop);
10281
10282         /* update debugger info */
10283         if (PERLDB_LINE && PL_curstash != PL_debstash) {
10284             SV *sv = NEWSV(88,0);
10285
10286             sv_upgrade(sv, SVt_PVMG);
10287             sv_setsv(sv,PL_linestr);
10288             (void)SvIOK_on(sv);
10289             SvIV_set(sv, 0);
10290             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
10291         }
10292
10293         /* having changed the buffer, we must update PL_bufend */
10294         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10295         PL_last_lop = PL_last_uni = Nullch;
10296     }
10297
10298     /* at this point, we have successfully read the delimited string */
10299
10300     if (!PL_encoding || UTF) {
10301         if (keep_delims)
10302             sv_catpvn(sv, s, termlen);
10303         s += termlen;
10304     }
10305     if (has_utf8 || PL_encoding)
10306         SvUTF8_on(sv);
10307
10308     PL_multi_end = CopLINE(PL_curcop);
10309
10310     /* if we allocated too much space, give some back */
10311     if (SvCUR(sv) + 5 < SvLEN(sv)) {
10312         SvLEN_set(sv, SvCUR(sv) + 1);
10313         SvPV_renew(sv, SvLEN(sv));
10314     }
10315
10316     /* decide whether this is the first or second quoted string we've read
10317        for this op
10318     */
10319
10320     if (PL_lex_stuff)
10321         PL_lex_repl = sv;
10322     else
10323         PL_lex_stuff = sv;
10324     return s;
10325 }
10326
10327 /*
10328   scan_num
10329   takes: pointer to position in buffer
10330   returns: pointer to new position in buffer
10331   side-effects: builds ops for the constant in yylval.op
10332
10333   Read a number in any of the formats that Perl accepts:
10334
10335   \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)      12 12.34 12.
10336   \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                     .34
10337   0b[01](_?[01])*
10338   0[0-7](_?[0-7])*
10339   0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10340
10341   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10342   thing it reads.
10343
10344   If it reads a number without a decimal point or an exponent, it will
10345   try converting the number to an integer and see if it can do so
10346   without loss of precision.
10347 */
10348
10349 char *
10350 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10351 {
10352     register const char *s = start;     /* current position in buffer */
10353     register char *d;                   /* destination in temp buffer */
10354     register char *e;                   /* end of temp buffer */
10355     NV nv;                              /* number read, as a double */
10356     SV *sv = Nullsv;                    /* place to put the converted number */
10357     bool floatit;                       /* boolean: int or float? */
10358     const char *lastub = 0;             /* position of last underbar */
10359     static char const number_too_long[] = "Number too long";
10360
10361     /* We use the first character to decide what type of number this is */
10362
10363     switch (*s) {
10364     default:
10365       Perl_croak(aTHX_ "panic: scan_num");
10366
10367     /* if it starts with a 0, it could be an octal number, a decimal in
10368        0.13 disguise, or a hexadecimal number, or a binary number. */
10369     case '0':
10370         {
10371           /* variables:
10372              u          holds the "number so far"
10373              shift      the power of 2 of the base
10374                         (hex == 4, octal == 3, binary == 1)
10375              overflowed was the number more than we can hold?
10376
10377              Shift is used when we add a digit.  It also serves as an "are
10378              we in octal/hex/binary?" indicator to disallow hex characters
10379              when in octal mode.
10380            */
10381             NV n = 0.0;
10382             UV u = 0;
10383             I32 shift;
10384             bool overflowed = FALSE;
10385             bool just_zero  = TRUE;     /* just plain 0 or binary number? */
10386             static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10387             static const char* const bases[5] =
10388               { "", "binary", "", "octal", "hexadecimal" };
10389             static const char* const Bases[5] =
10390               { "", "Binary", "", "Octal", "Hexadecimal" };
10391             static const char* const maxima[5] =
10392               { "",
10393                 "0b11111111111111111111111111111111",
10394                 "",
10395                 "037777777777",
10396                 "0xffffffff" };
10397             const char *base, *Base, *max;
10398
10399             /* check for hex */
10400             if (s[1] == 'x') {
10401                 shift = 4;
10402                 s += 2;
10403                 just_zero = FALSE;
10404             } else if (s[1] == 'b') {
10405                 shift = 1;
10406                 s += 2;
10407                 just_zero = FALSE;
10408             }
10409             /* check for a decimal in disguise */
10410             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10411                 goto decimal;
10412             /* so it must be octal */
10413             else {
10414                 shift = 3;
10415                 s++;
10416             }
10417
10418             if (*s == '_') {
10419                if (ckWARN(WARN_SYNTAX))
10420                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10421                                "Misplaced _ in number");
10422                lastub = s++;
10423             }
10424
10425             base = bases[shift];
10426             Base = Bases[shift];
10427             max  = maxima[shift];
10428
10429             /* read the rest of the number */
10430             for (;;) {
10431                 /* x is used in the overflow test,
10432                    b is the digit we're adding on. */
10433                 UV x, b;
10434
10435                 switch (*s) {
10436
10437                 /* if we don't mention it, we're done */
10438                 default:
10439                     goto out;
10440
10441                 /* _ are ignored -- but warned about if consecutive */
10442                 case '_':
10443                     if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10444                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10445                                     "Misplaced _ in number");
10446                     lastub = s++;
10447                     break;
10448
10449                 /* 8 and 9 are not octal */
10450                 case '8': case '9':
10451                     if (shift == 3)
10452                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10453                     /* FALL THROUGH */
10454
10455                 /* octal digits */
10456                 case '2': case '3': case '4':
10457                 case '5': case '6': case '7':
10458                     if (shift == 1)
10459                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10460                     /* FALL THROUGH */
10461
10462                 case '0': case '1':
10463                     b = *s++ & 15;              /* ASCII digit -> value of digit */
10464                     goto digit;
10465
10466                 /* hex digits */
10467                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10468                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10469                     /* make sure they said 0x */
10470                     if (shift != 4)
10471                         goto out;
10472                     b = (*s++ & 7) + 9;
10473
10474                     /* Prepare to put the digit we have onto the end
10475                        of the number so far.  We check for overflows.
10476                     */
10477
10478                   digit:
10479                     just_zero = FALSE;
10480                     if (!overflowed) {
10481                         x = u << shift; /* make room for the digit */
10482
10483                         if ((x >> shift) != u
10484                             && !(PL_hints & HINT_NEW_BINARY)) {
10485                             overflowed = TRUE;
10486                             n = (NV) u;
10487                             if (ckWARN_d(WARN_OVERFLOW))
10488                                 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
10489                                             "Integer overflow in %s number",
10490                                             base);
10491                         } else
10492                             u = x | b;          /* add the digit to the end */
10493                     }
10494                     if (overflowed) {
10495                         n *= nvshift[shift];
10496                         /* If an NV has not enough bits in its
10497                          * mantissa to represent an UV this summing of
10498                          * small low-order numbers is a waste of time
10499                          * (because the NV cannot preserve the
10500                          * low-order bits anyway): we could just
10501                          * remember when did we overflow and in the
10502                          * end just multiply n by the right
10503                          * amount. */
10504                         n += (NV) b;
10505                     }
10506                     break;
10507                 }
10508             }
10509
10510           /* if we get here, we had success: make a scalar value from
10511              the number.
10512           */
10513           out:
10514
10515             /* final misplaced underbar check */
10516             if (s[-1] == '_') {
10517                 if (ckWARN(WARN_SYNTAX))
10518                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10519             }
10520
10521             sv = NEWSV(92,0);
10522             if (overflowed) {
10523                 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
10524                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10525                                 "%s number > %s non-portable",
10526                                 Base, max);
10527                 sv_setnv(sv, n);
10528             }
10529             else {
10530 #if UVSIZE > 4
10531                 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
10532                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10533                                 "%s number > %s non-portable",
10534                                 Base, max);
10535 #endif
10536                 sv_setuv(sv, u);
10537             }
10538             if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10539                 sv = new_constant(start, s - start, "integer",
10540                                   sv, Nullsv, NULL);
10541             else if (PL_hints & HINT_NEW_BINARY)
10542                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
10543         }
10544         break;
10545
10546     /*
10547       handle decimal numbers.
10548       we're also sent here when we read a 0 as the first digit
10549     */
10550     case '1': case '2': case '3': case '4': case '5':
10551     case '6': case '7': case '8': case '9': case '.':
10552       decimal:
10553         d = PL_tokenbuf;
10554         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10555         floatit = FALSE;
10556
10557         /* read next group of digits and _ and copy into d */
10558         while (isDIGIT(*s) || *s == '_') {
10559             /* skip underscores, checking for misplaced ones
10560                if -w is on
10561             */
10562             if (*s == '_') {
10563                 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10564                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10565                                 "Misplaced _ in number");
10566                 lastub = s++;
10567             }
10568             else {
10569                 /* check for end of fixed-length buffer */
10570                 if (d >= e)
10571                     Perl_croak(aTHX_ number_too_long);
10572                 /* if we're ok, copy the character */
10573                 *d++ = *s++;
10574             }
10575         }
10576
10577         /* final misplaced underbar check */
10578         if (lastub && s == lastub + 1) {
10579             if (ckWARN(WARN_SYNTAX))
10580                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10581         }
10582
10583         /* read a decimal portion if there is one.  avoid
10584            3..5 being interpreted as the number 3. followed
10585            by .5
10586         */
10587         if (*s == '.' && s[1] != '.') {
10588             floatit = TRUE;
10589             *d++ = *s++;
10590
10591             if (*s == '_') {
10592                 if (ckWARN(WARN_SYNTAX))
10593                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10594                                 "Misplaced _ in number");
10595                 lastub = s;
10596             }
10597
10598             /* copy, ignoring underbars, until we run out of digits.
10599             */
10600             for (; isDIGIT(*s) || *s == '_'; s++) {
10601                 /* fixed length buffer check */
10602                 if (d >= e)
10603                     Perl_croak(aTHX_ number_too_long);
10604                 if (*s == '_') {
10605                    if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10606                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10607                                    "Misplaced _ in number");
10608                    lastub = s;
10609                 }
10610                 else
10611                     *d++ = *s;
10612             }
10613             /* fractional part ending in underbar? */
10614             if (s[-1] == '_') {
10615                 if (ckWARN(WARN_SYNTAX))
10616                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10617                                 "Misplaced _ in number");
10618             }
10619             if (*s == '.' && isDIGIT(s[1])) {
10620                 /* oops, it's really a v-string, but without the "v" */
10621                 s = start;
10622                 goto vstring;
10623             }
10624         }
10625
10626         /* read exponent part, if present */
10627         if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10628             floatit = TRUE;
10629             s++;
10630
10631             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10632             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
10633
10634             /* stray preinitial _ */
10635             if (*s == '_') {
10636                 if (ckWARN(WARN_SYNTAX))
10637                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10638                                 "Misplaced _ in number");
10639                 lastub = s++;
10640             }
10641
10642             /* allow positive or negative exponent */
10643             if (*s == '+' || *s == '-')
10644                 *d++ = *s++;
10645
10646             /* stray initial _ */
10647             if (*s == '_') {
10648                 if (ckWARN(WARN_SYNTAX))
10649                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10650                                 "Misplaced _ in number");
10651                 lastub = s++;
10652             }
10653
10654             /* read digits of exponent */
10655             while (isDIGIT(*s) || *s == '_') {
10656                 if (isDIGIT(*s)) {
10657                     if (d >= e)
10658                         Perl_croak(aTHX_ number_too_long);
10659                     *d++ = *s++;
10660                 }
10661                 else {
10662                    if (((lastub && s == lastub + 1) ||
10663                         (!isDIGIT(s[1]) && s[1] != '_'))
10664                     && ckWARN(WARN_SYNTAX))
10665                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10666                                    "Misplaced _ in number");
10667                    lastub = s++;
10668                 }
10669             }
10670         }
10671
10672
10673         /* make an sv from the string */
10674         sv = NEWSV(92,0);
10675
10676         /*
10677            We try to do an integer conversion first if no characters
10678            indicating "float" have been found.
10679          */
10680
10681         if (!floatit) {
10682             UV uv;
10683             int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10684
10685             if (flags == IS_NUMBER_IN_UV) {
10686               if (uv <= IV_MAX)
10687                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
10688               else
10689                 sv_setuv(sv, uv);
10690             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10691               if (uv <= (UV) IV_MIN)
10692                 sv_setiv(sv, -(IV)uv);
10693               else
10694                 floatit = TRUE;
10695             } else
10696               floatit = TRUE;
10697         }
10698         if (floatit) {
10699             /* terminate the string */
10700             *d = '\0';
10701             nv = Atof(PL_tokenbuf);
10702             sv_setnv(sv, nv);
10703         }
10704
10705         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
10706                        (PL_hints & HINT_NEW_INTEGER) )
10707             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
10708                               (floatit ? "float" : "integer"),
10709                               sv, Nullsv, NULL);
10710         break;
10711
10712     /* if it starts with a v, it could be a v-string */
10713     case 'v':
10714 vstring:
10715                 sv = NEWSV(92,5); /* preallocate storage space */
10716                 s = scan_vstring(s,sv);
10717         break;
10718     }
10719
10720     /* make the op for the constant and return */
10721
10722     if (sv)
10723         lvalp->opval = newSVOP(OP_CONST, 0, sv);
10724     else
10725         lvalp->opval = Nullop;
10726
10727     return (char *)s;
10728 }
10729
10730 STATIC char *
10731 S_scan_formline(pTHX_ register char *s)
10732 {
10733     register char *eol;
10734     register char *t;
10735     SV *stuff = newSVpvn("",0);
10736     bool needargs = FALSE;
10737     bool eofmt = FALSE;
10738
10739     while (!needargs) {
10740         if (*s == '.') {
10741 #ifdef PERL_STRICT_CR
10742             for (t = s+1;SPACE_OR_TAB(*t); t++) ;
10743 #else
10744             for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
10745 #endif
10746             if (*t == '\n' || t == PL_bufend) {
10747                 eofmt = TRUE;
10748                 break;
10749             }
10750         }
10751         if (PL_in_eval && !PL_rsfp) {
10752             eol = (char *) memchr(s,'\n',PL_bufend-s);
10753             if (!eol++)
10754                 eol = PL_bufend;
10755         }
10756         else
10757             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10758         if (*s != '#') {
10759             for (t = s; t < eol; t++) {
10760                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10761                     needargs = FALSE;
10762                     goto enough;        /* ~~ must be first line in formline */
10763                 }
10764                 if (*t == '@' || *t == '^')
10765                     needargs = TRUE;
10766             }
10767             if (eol > s) {
10768                 sv_catpvn(stuff, s, eol-s);
10769 #ifndef PERL_STRICT_CR
10770                 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10771                     char *end = SvPVX(stuff) + SvCUR(stuff);
10772                     end[-2] = '\n';
10773                     end[-1] = '\0';
10774                     SvCUR_set(stuff, SvCUR(stuff) - 1);
10775                 }
10776 #endif
10777             }
10778             else
10779               break;
10780         }
10781         s = (char*)eol;
10782         if (PL_rsfp) {
10783             s = filter_gets(PL_linestr, PL_rsfp, 0);
10784             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
10785             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
10786             PL_last_lop = PL_last_uni = Nullch;
10787             if (!s) {
10788                 s = PL_bufptr;
10789                 break;
10790             }
10791         }
10792         incline(s);
10793     }
10794   enough:
10795     if (SvCUR(stuff)) {
10796         PL_expect = XTERM;
10797         if (needargs) {
10798             PL_lex_state = LEX_NORMAL;
10799             PL_nextval[PL_nexttoke].ival = 0;
10800             force_next(',');
10801         }
10802         else
10803             PL_lex_state = LEX_FORMLINE;
10804         if (!IN_BYTES) {
10805             if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10806                 SvUTF8_on(stuff);
10807             else if (PL_encoding)
10808                 sv_recode_to_utf8(stuff, PL_encoding);
10809         }
10810         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10811         force_next(THING);
10812         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
10813         force_next(LSTOP);
10814     }
10815     else {
10816         SvREFCNT_dec(stuff);
10817         if (eofmt)
10818             PL_lex_formbrack = 0;
10819         PL_bufptr = s;
10820     }
10821     return s;
10822 }
10823
10824 STATIC void
10825 S_set_csh(pTHX)
10826 {
10827 #ifdef CSH
10828     if (!PL_cshlen)
10829         PL_cshlen = strlen(PL_cshname);
10830 #endif
10831 }
10832
10833 I32
10834 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10835 {
10836     const I32 oldsavestack_ix = PL_savestack_ix;
10837     CV* outsidecv = PL_compcv;
10838
10839     if (PL_compcv) {
10840         assert(SvTYPE(PL_compcv) == SVt_PVCV);
10841     }
10842     SAVEI32(PL_subline);
10843     save_item(PL_subname);
10844     SAVESPTR(PL_compcv);
10845
10846     PL_compcv = (CV*)NEWSV(1104,0);
10847     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
10848     CvFLAGS(PL_compcv) |= flags;
10849
10850     PL_subline = CopLINE(PL_curcop);
10851     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10852     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
10853     CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10854
10855     return oldsavestack_ix;
10856 }
10857
10858 #ifdef __SC__
10859 #pragma segment Perl_yylex
10860 #endif
10861 int
10862 Perl_yywarn(pTHX_ const char *s)
10863 {
10864     PL_in_eval |= EVAL_WARNONLY;
10865     yyerror(s);
10866     PL_in_eval &= ~EVAL_WARNONLY;
10867     return 0;
10868 }
10869
10870 int
10871 Perl_yyerror(pTHX_ const char *s)
10872 {
10873     const char *where = NULL;
10874     const char *context = NULL;
10875     int contlen = -1;
10876     SV *msg;
10877
10878     if (!yychar || (yychar == ';' && !PL_rsfp))
10879         where = "at EOF";
10880     else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10881       PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10882       PL_oldbufptr != PL_bufptr) {
10883         /*
10884                 Only for NetWare:
10885                 The code below is removed for NetWare because it abends/crashes on NetWare
10886                 when the script has error such as not having the closing quotes like:
10887                     if ($var eq "value)
10888                 Checking of white spaces is anyway done in NetWare code.
10889         */
10890 #ifndef NETWARE
10891         while (isSPACE(*PL_oldoldbufptr))
10892             PL_oldoldbufptr++;
10893 #endif
10894         context = PL_oldoldbufptr;
10895         contlen = PL_bufptr - PL_oldoldbufptr;
10896     }
10897     else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10898       PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10899         /*
10900                 Only for NetWare:
10901                 The code below is removed for NetWare because it abends/crashes on NetWare
10902                 when the script has error such as not having the closing quotes like:
10903                     if ($var eq "value)
10904                 Checking of white spaces is anyway done in NetWare code.
10905         */
10906 #ifndef NETWARE
10907         while (isSPACE(*PL_oldbufptr))
10908             PL_oldbufptr++;
10909 #endif
10910         context = PL_oldbufptr;
10911         contlen = PL_bufptr - PL_oldbufptr;
10912     }
10913     else if (yychar > 255)
10914         where = "next token ???";
10915     else if (yychar == -2) { /* YYEMPTY */
10916         if (PL_lex_state == LEX_NORMAL ||
10917            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10918             where = "at end of line";
10919         else if (PL_lex_inpat)
10920             where = "within pattern";
10921         else
10922             where = "within string";
10923     }
10924     else {
10925         SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
10926         if (yychar < 32)
10927             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10928         else if (isPRINT_LC(yychar))
10929             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
10930         else
10931             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10932         where = SvPVX_const(where_sv);
10933     }
10934     msg = sv_2mortal(newSVpv(s, 0));
10935     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10936         OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10937     if (context)
10938         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10939     else
10940         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10941     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10942         Perl_sv_catpvf(aTHX_ msg,
10943         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10944                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10945         PL_multi_end = 0;
10946     }
10947     if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
10948         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
10949     else
10950         qerror(msg);
10951     if (PL_error_count >= 10) {
10952         if (PL_in_eval && SvCUR(ERRSV))
10953             Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10954             ERRSV, OutCopFILE(PL_curcop));
10955         else
10956             Perl_croak(aTHX_ "%s has too many errors.\n",
10957             OutCopFILE(PL_curcop));
10958     }
10959     PL_in_my = 0;
10960     PL_in_my_stash = NULL;
10961     return 0;
10962 }
10963 #ifdef __SC__
10964 #pragma segment Main
10965 #endif
10966
10967 STATIC char*
10968 S_swallow_bom(pTHX_ U8 *s)
10969 {
10970     const STRLEN slen = SvCUR(PL_linestr);
10971     switch (s[0]) {
10972     case 0xFF:
10973         if (s[1] == 0xFE) {
10974             /* UTF-16 little-endian? (or UTF32-LE?) */
10975             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
10976                 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
10977 #ifndef PERL_NO_UTF16_FILTER
10978             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
10979             s += 2;
10980         utf16le:
10981             if (PL_bufend > (char*)s) {
10982                 U8 *news;
10983                 I32 newlen;
10984
10985                 filter_add(utf16rev_textfilter, NULL);
10986                 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10987                 utf16_to_utf8_reversed(s, news,
10988                                        PL_bufend - (char*)s - 1,
10989                                        &newlen);
10990                 sv_setpvn(PL_linestr, (const char*)news, newlen);
10991                 Safefree(news);
10992                 SvUTF8_on(PL_linestr);
10993                 s = (U8*)SvPVX(PL_linestr);
10994                 PL_bufend = SvPVX(PL_linestr) + newlen;
10995             }
10996 #else
10997             Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
10998 #endif
10999         }
11000         break;
11001     case 0xFE:
11002         if (s[1] == 0xFF) {   /* UTF-16 big-endian? */
11003 #ifndef PERL_NO_UTF16_FILTER
11004             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11005             s += 2;
11006         utf16be:
11007             if (PL_bufend > (char *)s) {
11008                 U8 *news;
11009                 I32 newlen;
11010
11011                 filter_add(utf16_textfilter, NULL);
11012                 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
11013                 utf16_to_utf8(s, news,
11014                               PL_bufend - (char*)s,
11015                               &newlen);
11016                 sv_setpvn(PL_linestr, (const char*)news, newlen);
11017                 Safefree(news);
11018                 SvUTF8_on(PL_linestr);
11019                 s = (U8*)SvPVX(PL_linestr);
11020                 PL_bufend = SvPVX(PL_linestr) + newlen;
11021             }
11022 #else
11023             Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
11024 #endif
11025         }
11026         break;
11027     case 0xEF:
11028         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
11029             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11030             s += 3;                      /* UTF-8 */
11031         }
11032         break;
11033     case 0:
11034         if (slen > 3) {
11035              if (s[1] == 0) {
11036                   if (s[2] == 0xFE && s[3] == 0xFF) {
11037                        /* UTF-32 big-endian */
11038                        Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
11039                   }
11040              }
11041              else if (s[2] == 0 && s[3] != 0) {
11042                   /* Leading bytes
11043                    * 00 xx 00 xx
11044                    * are a good indicator of UTF-16BE. */
11045                   if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11046                   goto utf16be;
11047              }
11048         }
11049     default:
11050          if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11051                   /* Leading bytes
11052                    * xx 00 xx 00
11053                    * are a good indicator of UTF-16LE. */
11054               if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11055               goto utf16le;
11056          }
11057     }
11058     return (char*)s;
11059 }
11060
11061 /*
11062  * restore_rsfp
11063  * Restore a source filter.
11064  */
11065
11066 static void
11067 restore_rsfp(pTHX_ void *f)
11068 {
11069     PerlIO * const fp = (PerlIO*)f;
11070
11071     if (PL_rsfp == PerlIO_stdin())
11072         PerlIO_clearerr(PL_rsfp);
11073     else if (PL_rsfp && (PL_rsfp != fp))
11074         PerlIO_close(PL_rsfp);
11075     PL_rsfp = fp;
11076 }
11077
11078 #ifndef PERL_NO_UTF16_FILTER
11079 static I32
11080 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11081 {
11082     const STRLEN old = SvCUR(sv);
11083     const I32 count = FILTER_READ(idx+1, sv, maxlen);
11084     DEBUG_P(PerlIO_printf(Perl_debug_log,
11085                           "utf16_textfilter(%p): %d %d (%d)\n",
11086                           utf16_textfilter, idx, maxlen, (int) count));
11087     if (count) {
11088         U8* tmps;
11089         I32 newlen;
11090         Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
11091         Copy(SvPVX_const(sv), tmps, old, char);
11092         utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
11093                       SvCUR(sv) - old, &newlen);
11094         sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
11095     }
11096     DEBUG_P({sv_dump(sv);});
11097     return SvCUR(sv);
11098 }
11099
11100 static I32
11101 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11102 {
11103     const STRLEN old = SvCUR(sv);
11104     const I32 count = FILTER_READ(idx+1, sv, maxlen);
11105     DEBUG_P(PerlIO_printf(Perl_debug_log,
11106                           "utf16rev_textfilter(%p): %d %d (%d)\n",
11107                           utf16rev_textfilter, idx, maxlen, (int) count));
11108     if (count) {
11109         U8* tmps;
11110         I32 newlen;
11111         Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
11112         Copy(SvPVX_const(sv), tmps, old, char);
11113         utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
11114                       SvCUR(sv) - old, &newlen);
11115         sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
11116     }
11117     DEBUG_P({ sv_dump(sv); });
11118     return count;
11119 }
11120 #endif
11121
11122 /*
11123 Returns a pointer to the next character after the parsed
11124 vstring, as well as updating the passed in sv.
11125
11126 Function must be called like
11127
11128         sv = NEWSV(92,5);
11129         s = scan_vstring(s,sv);
11130
11131 The sv should already be large enough to store the vstring
11132 passed in, for performance reasons.
11133
11134 */
11135
11136 char *
11137 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
11138 {
11139     const char *pos = s;
11140     const char *start = s;
11141     if (*pos == 'v') pos++;  /* get past 'v' */
11142     while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11143         pos++;
11144     if ( *pos != '.') {
11145         /* this may not be a v-string if followed by => */
11146         const char *next = pos;
11147         while (next < PL_bufend && isSPACE(*next))
11148             ++next;
11149         if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
11150             /* return string not v-string */
11151             sv_setpvn(sv,(char *)s,pos-s);
11152             return (char *)pos;
11153         }
11154     }
11155
11156     if (!isALPHA(*pos)) {
11157         U8 tmpbuf[UTF8_MAXBYTES+1];
11158
11159         if (*s == 'v') s++;  /* get past 'v' */
11160
11161         sv_setpvn(sv, "", 0);
11162
11163         for (;;) {
11164             U8 *tmpend;
11165             UV rev = 0;
11166             {
11167                 /* this is atoi() that tolerates underscores */
11168                 const char *end = pos;
11169                 UV mult = 1;
11170                 while (--end >= s) {
11171                     UV orev;
11172                     if (*end == '_')
11173                         continue;
11174                     orev = rev;
11175                     rev += (*end - '0') * mult;
11176                     mult *= 10;
11177                     if (orev > rev && ckWARN_d(WARN_OVERFLOW))
11178                         Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11179                                     "Integer overflow in decimal number");
11180                 }
11181             }
11182 #ifdef EBCDIC
11183             if (rev > 0x7FFFFFFF)
11184                  Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11185 #endif
11186             /* Append native character for the rev point */
11187             tmpend = uvchr_to_utf8(tmpbuf, rev);
11188             sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11189             if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11190                  SvUTF8_on(sv);
11191             if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
11192                  s = ++pos;
11193             else {
11194                  s = pos;
11195                  break;
11196             }
11197             while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11198                  pos++;
11199         }
11200         SvPOK_on(sv);
11201         sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11202         SvRMAGICAL_on(sv);
11203     }
11204     return (char *)s;
11205 }
11206
11207 /*
11208  * Local variables:
11209  * c-indentation-style: bsd
11210  * c-basic-offset: 4
11211  * indent-tabs-mode: t
11212  * End:
11213  *
11214  * ex: set ts=8 sts=4 sw=4 noet:
11215  */