toke.c

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