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