toke.c

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