toke.c

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