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