toke.c

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