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