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