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