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