toke.c

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