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 = newSVpvn("",0);
 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 = newSVpvn("",0);
 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 = newSVpvn("",0);
 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 = newSVpvn("",0);
 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 = newSVpvn("",0);
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('^', newSVpvn("",0));
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))
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 = newSVpvn("",0);
1678                 sv_catsv(PL_endwhite, PL_thiswhite);
1679                 PL_thiswhite = 0;
1680             }
1681             if (PL_thistoken)
1682                 sv_setpvn(PL_thistoken,"",0);
1683             else
1684                 PL_realtokenstart = -1;
1685         }
1686 #endif
1687         LEAVE;
1688         PL_bufend = SvPVX(PL_linestr);
1689         PL_bufend += SvCUR(PL_linestr);
1690         PL_expect = XOPERATOR;
1691         PL_sublex_info.sub_inwhat = 0;
1692         return ')';
1693     }
1694 }
1695
1696 /*
1697   scan_const
1698
1699   Extracts a pattern, double-quoted string, or transliteration.  This
1700   is terrifying code.
1701
1702   It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1703   processing a pattern (PL_lex_inpat is true), a transliteration
1704   (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1705
1706   Returns a pointer to the character scanned up to. If this is
1707   advanced from the start pointer supplied (i.e. if anything was
1708   successfully parsed), will leave an OP for the substring scanned
1709   in yylval. Caller must intuit reason for not parsing further
1710   by looking at the next characters herself.
1711
1712   In patterns:
1713     backslashes:
1714       double-quoted style: \r and \n
1715       regexp special ones: \D \s
1716       constants: \x31
1717       backrefs: \1
1718       case and quoting: \U \Q \E
1719     stops on @ and $, but not for $ as tail anchor
1720
1721   In transliterations:
1722     characters are VERY literal, except for - not at the start or end
1723     of the string, which indicates a range. If the range is in bytes,
1724     scan_const expands the range to the full set of intermediate
1725     characters. If the range is in utf8, the hyphen is replaced with
1726     a certain range mark which will be handled by pmtrans() in op.c.
1727
1728   In double-quoted strings:
1729     backslashes:
1730       double-quoted style: \r and \n
1731       constants: \x31
1732       deprecated backrefs: \1 (in substitution replacements)
1733       case and quoting: \U \Q \E
1734     stops on @ and $
1735
1736   scan_const does *not* construct ops to handle interpolated strings.
1737   It stops processing as soon as it finds an embedded $ or @ variable
1738   and leaves it to the caller to work out what's going on.
1739
1740   embedded arrays (whether in pattern or not) could be:
1741       @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1742
1743   $ in double-quoted strings must be the symbol of an embedded scalar.
1744
1745   $ in pattern could be $foo or could be tail anchor.  Assumption:
1746   it's a tail anchor if $ is the last thing in the string, or if it's
1747   followed by one of "()| \r\n\t"
1748
1749   \1 (backreferences) are turned into $1
1750
1751   The structure of the code is
1752       while (there's a character to process) {
1753           handle transliteration ranges
1754           skip regexp comments /(?#comment)/ and codes /(?{code})/
1755           skip #-initiated comments in //x patterns
1756           check for embedded arrays
1757           check for embedded scalars
1758           if (backslash) {
1759               leave intact backslashes from leaveit (below)
1760               deprecate \1 in substitution replacements
1761               handle string-changing backslashes \l \U \Q \E, etc.
1762               switch (what was escaped) {
1763                   handle \- in a transliteration (becomes a literal -)
1764                   handle \132 (octal characters)
1765                   handle \x15 and \x{1234} (hex characters)
1766                   handle \N{name} (named characters)
1767                   handle \cV (control characters)
1768                   handle printf-style backslashes (\f, \r, \n, etc)
1769               } (end switch)
1770           } (end if backslash)
1771     } (end while character to read)
1772
1773 */
1774
1775 STATIC char *
1776 S_scan_const(pTHX_ char *start)
1777 {
1778     dVAR;
1779     register char *send = PL_bufend;            /* end of the constant */
1780     SV *sv = newSV(send - start);               /* sv for the constant */
1781     register char *s = start;                   /* start of the constant */
1782     register char *d = SvPVX(sv);               /* destination for copies */
1783     bool dorange = FALSE;                       /* are we in a translit range? */
1784     bool didrange = FALSE;                      /* did we just finish a range? */
1785     I32  has_utf8 = FALSE;                      /* Output constant is UTF8 */
1786     I32  this_utf8 = UTF;                       /* The source string is assumed to be UTF8 */
1787     UV uv;
1788 #ifdef EBCDIC
1789     UV literal_endpoint = 0;
1790     bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1791 #endif
1792
1793     const char * const leaveit = /* set of acceptably-backslashed characters */
1794         (const char *)
1795         (PL_lex_inpat
1796          ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1797          : "");
1798
1799     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1800         /* If we are doing a trans and we know we want UTF8 set expectation */
1801         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1802         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1803     }
1804
1805
1806     while (s < send || dorange) {
1807         /* get transliterations out of the way (they're most literal) */
1808         if (PL_lex_inwhat == OP_TRANS) {
1809             /* expand a range A-Z to the full set of characters.  AIE! */
1810             if (dorange) {
1811                 I32 i;                          /* current expanded character */
1812                 I32 min;                        /* first character in range */
1813                 I32 max;                        /* last character in range */
1814
1815 #ifdef EBCDIC
1816                 UV uvmax = 0;
1817 #endif
1818
1819                 if (has_utf8
1820 #ifdef EBCDIC
1821                     && !native_range
1822 #endif
1823                     ) {
1824                     char * const c = (char*)utf8_hop((U8*)d, -1);
1825                     char *e = d++;
1826                     while (e-- > c)
1827                         *(e + 1) = *e;
1828                     *c = (char)UTF_TO_NATIVE(0xff);
1829                     /* mark the range as done, and continue */
1830                     dorange = FALSE;
1831                     didrange = TRUE;
1832                     continue;
1833                 }
1834
1835                 i = d - SvPVX_const(sv);                /* remember current offset */
1836 #ifdef EBCDIC
1837                 SvGROW(sv,
1838                        SvLEN(sv) + (has_utf8 ?
1839                                     (512 - UTF_CONTINUATION_MARK +
1840                                      UNISKIP(0x100))
1841                                     : 256));
1842                 /* How many two-byte within 0..255: 128 in UTF-8,
1843                  * 96 in UTF-8-mod. */
1844 #else
1845                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
1846 #endif
1847                 d = SvPVX(sv) + i;              /* refresh d after realloc */
1848 #ifdef EBCDIC
1849                 if (has_utf8) {
1850                     int j;
1851                     for (j = 0; j <= 1; j++) {
1852                         char * const c = (char*)utf8_hop((U8*)d, -1);
1853                         const UV uv    = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
1854                         if (j)
1855                             min = (U8)uv;
1856                         else if (uv < 256)
1857                             max = (U8)uv;
1858                         else {
1859                             max = (U8)0xff; /* only to \xff */
1860                             uvmax = uv; /* \x{100} to uvmax */
1861                         }
1862                         d = c; /* eat endpoint chars */
1863                      }
1864                 }
1865                else {
1866 #endif
1867                    d -= 2;              /* eat the first char and the - */
1868                    min = (U8)*d;        /* first char in range */
1869                    max = (U8)d[1];      /* last char in range  */
1870 #ifdef EBCDIC
1871                }
1872 #endif
1873
1874                 if (min > max) {
1875                     Perl_croak(aTHX_
1876                                "Invalid range \"%c-%c\" in transliteration operator",
1877                                (char)min, (char)max);
1878                 }
1879
1880 #ifdef EBCDIC
1881                 if (literal_endpoint == 2 &&
1882                     ((isLOWER(min) && isLOWER(max)) ||
1883                      (isUPPER(min) && isUPPER(max)))) {
1884                     if (isLOWER(min)) {
1885                         for (i = min; i <= max; i++)
1886                             if (isLOWER(i))
1887                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1888                     } else {
1889                         for (i = min; i <= max; i++)
1890                             if (isUPPER(i))
1891                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1892                     }
1893                 }
1894                 else
1895 #endif
1896                     for (i = min; i <= max; i++)
1897 #ifdef EBCDIC
1898                         if (has_utf8) {
1899                             const U8 ch = (U8)NATIVE_TO_UTF(i);
1900                             if (UNI_IS_INVARIANT(ch))
1901                                 *d++ = (U8)i;
1902                             else {
1903                                 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
1904                                 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
1905                             }
1906                         }
1907                         else
1908 #endif
1909                             *d++ = (char)i;
1910
1911 #ifdef EBCDIC
1912                 if (uvmax) {
1913                     d = (char*)uvchr_to_utf8((U8*)d, 0x100);
1914                     if (uvmax > 0x101)
1915                         *d++ = (char)UTF_TO_NATIVE(0xff);
1916                     if (uvmax > 0x100)
1917                         d = (char*)uvchr_to_utf8((U8*)d, uvmax);
1918                 }
1919 #endif
1920
1921                 /* mark the range as done, and continue */
1922                 dorange = FALSE;
1923                 didrange = TRUE;
1924 #ifdef EBCDIC
1925                 literal_endpoint = 0;
1926 #endif
1927                 continue;
1928             }
1929
1930             /* range begins (ignore - as first or last char) */
1931             else if (*s == '-' && s+1 < send  && s != start) {
1932                 if (didrange) {
1933                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1934                 }
1935                 if (has_utf8
1936 #ifdef EBCDIC
1937                     && !native_range
1938 #endif
1939                     ) {
1940                     *d++ = (char)UTF_TO_NATIVE(0xff);   /* use illegal utf8 byte--see pmtrans */
1941                     s++;
1942                     continue;
1943                 }
1944                 dorange = TRUE;
1945                 s++;
1946             }
1947             else {
1948                 didrange = FALSE;
1949 #ifdef EBCDIC
1950                 literal_endpoint = 0;
1951                 native_range = TRUE;
1952 #endif
1953             }
1954         }
1955
1956         /* if we get here, we're not doing a transliteration */
1957
1958         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1959            except for the last char, which will be done separately. */
1960         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1961             if (s[2] == '#') {
1962                 while (s+1 < send && *s != ')')
1963                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1964             }
1965             else if (s[2] == '{' /* This should match regcomp.c */
1966                      || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1967             {
1968                 I32 count = 1;
1969                 char *regparse = s + (s[2] == '{' ? 3 : 4);
1970                 char c;
1971
1972                 while (count && (c = *regparse)) {
1973                     if (c == '\\' && regparse[1])
1974                         regparse++;
1975                     else if (c == '{')
1976                         count++;
1977                     else if (c == '}')
1978                         count--;
1979                     regparse++;
1980                 }
1981                 if (*regparse != ')')
1982                     regparse--;         /* Leave one char for continuation. */
1983                 while (s < regparse)
1984                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1985             }
1986         }
1987
1988         /* likewise skip #-initiated comments in //x patterns */
1989         else if (*s == '#' && PL_lex_inpat &&
1990           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1991             while (s+1 < send && *s != '\n')
1992                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1993         }
1994
1995         /* check for embedded arrays
1996            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1997            */
1998         else if (*s == '@' && s[1]) {
1999             if (isALNUM_lazy_if(s+1,UTF))
2000                 break;
2001             if (strchr(":'{$", s[1]))
2002                 break;
2003             if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2004                 break; /* in regexp, neither @+ nor @- are interpolated */
2005         }
2006
2007         /* check for embedded scalars.  only stop if we're sure it's a
2008            variable.
2009         */
2010         else if (*s == '$') {
2011             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
2012                 break;
2013             if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
2014                 break;          /* in regexp, $ might be tail anchor */
2015         }
2016
2017         /* End of else if chain - OP_TRANS rejoin rest */
2018
2019         /* backslashes */
2020         if (*s == '\\' && s+1 < send) {
2021             s++;
2022
2023             /* some backslashes we leave behind */
2024             if (*leaveit && *s && strchr(leaveit, *s)) {
2025                 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2026                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2027                 continue;
2028             }
2029
2030             /* deprecate \1 in strings and substitution replacements */
2031             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2032                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2033             {
2034                 if (ckWARN(WARN_SYNTAX))
2035                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2036                 *--s = '$';
2037                 break;
2038             }
2039
2040             /* string-change backslash escapes */
2041             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2042                 --s;
2043                 break;
2044             }
2045
2046             /* if we get here, it's either a quoted -, or a digit */
2047             switch (*s) {
2048
2049             /* quoted - in transliterations */
2050             case '-':
2051                 if (PL_lex_inwhat == OP_TRANS) {
2052                     *d++ = *s++;
2053                     continue;
2054                 }
2055                 /* FALL THROUGH */
2056             default:
2057                 {
2058                     if ((isALPHA(*s) || isDIGIT(*s)) &&
2059                         ckWARN(WARN_MISC))
2060                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2061                                     "Unrecognized escape \\%c passed through",
2062                                     *s);
2063                     /* default action is to copy the quoted character */
2064                     goto default_action;
2065                 }
2066
2067             /* \132 indicates an octal constant */
2068             case '0': case '1': case '2': case '3':
2069             case '4': case '5': case '6': case '7':
2070                 {
2071                     I32 flags = 0;
2072                     STRLEN len = 3;
2073                     uv = grok_oct(s, &len, &flags, NULL);
2074                     s += len;
2075                 }
2076                 goto NUM_ESCAPE_INSERT;
2077
2078             /* \x24 indicates a hex constant */
2079             case 'x':
2080                 ++s;
2081                 if (*s == '{') {
2082                     char* const e = strchr(s, '}');
2083                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2084                       PERL_SCAN_DISALLOW_PREFIX;
2085                     STRLEN len;
2086
2087                     ++s;
2088                     if (!e) {
2089                         yyerror("Missing right brace on \\x{}");
2090                         continue;
2091                     }
2092                     len = e - s;
2093                     uv = grok_hex(s, &len, &flags, NULL);
2094                     s = e + 1;
2095                 }
2096                 else {
2097                     {
2098                         STRLEN len = 2;
2099                         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2100                         uv = grok_hex(s, &len, &flags, NULL);
2101                         s += len;
2102                     }
2103                 }
2104
2105               NUM_ESCAPE_INSERT:
2106                 /* Insert oct or hex escaped character.
2107                  * There will always enough room in sv since such
2108                  * escapes will be longer than any UTF-8 sequence
2109                  * they can end up as. */
2110
2111                 /* We need to map to chars to ASCII before doing the tests
2112                    to cover EBCDIC
2113                 */
2114                 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
2115                     if (!has_utf8 && uv > 255) {
2116                         /* Might need to recode whatever we have
2117                          * accumulated so far if it contains any
2118                          * hibit chars.
2119                          *
2120                          * (Can't we keep track of that and avoid
2121                          *  this rescan? --jhi)
2122                          */
2123                         int hicount = 0;
2124                         U8 *c;
2125                         for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
2126                             if (!NATIVE_IS_INVARIANT(*c)) {
2127                                 hicount++;
2128                             }
2129                         }
2130                         if (hicount) {
2131                             const STRLEN offset = d - SvPVX_const(sv);
2132                             U8 *src, *dst;
2133                             d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
2134                             src = (U8 *)d - 1;
2135                             dst = src+hicount;
2136                             d  += hicount;
2137                             while (src >= (const U8 *)SvPVX_const(sv)) {
2138                                 if (!NATIVE_IS_INVARIANT(*src)) {
2139                                     const U8 ch = NATIVE_TO_ASCII(*src);
2140                                     *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
2141                                     *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
2142                                 }
2143                                 else {
2144                                     *dst-- = *src;
2145                                 }
2146                                 src--;
2147                             }
2148                         }
2149                     }
2150
2151                     if (has_utf8 || uv > 255) {
2152                         d = (char*)uvchr_to_utf8((U8*)d, uv);
2153                         has_utf8 = TRUE;
2154                         if (PL_lex_inwhat == OP_TRANS &&
2155                             PL_sublex_info.sub_op) {
2156                             PL_sublex_info.sub_op->op_private |=
2157                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
2158                                              : OPpTRANS_TO_UTF);
2159                         }
2160 #ifdef EBCDIC
2161                         if (uv > 255 && !dorange)
2162                             native_range = FALSE;
2163 #endif
2164                     }
2165                     else {
2166                         *d++ = (char)uv;
2167                     }
2168                 }
2169                 else {
2170                     *d++ = (char) uv;
2171                 }
2172                 continue;
2173
2174             /* \N{LATIN SMALL LETTER A} is a named character */
2175             case 'N':
2176                 ++s;
2177                 if (*s == '{') {
2178                     char* e = strchr(s, '}');
2179                     SV *res;
2180                     STRLEN len;
2181                     const char *str;
2182
2183                     if (!e) {
2184                         yyerror("Missing right brace on \\N{}");
2185                         e = s - 1;
2186                         goto cont_scan;
2187                     }
2188                     if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2189                         /* \N{U+...} */
2190                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2191                           PERL_SCAN_DISALLOW_PREFIX;
2192                         s += 3;
2193                         len = e - s;
2194                         uv = grok_hex(s, &len, &flags, NULL);
2195                         s = e + 1;
2196                         goto NUM_ESCAPE_INSERT;
2197                     }
2198                     res = newSVpvn(s + 1, e - s - 1);
2199                     res = new_constant( NULL, 0, "charnames",
2200                                         res, NULL, "\\N{...}" );
2201                     if (has_utf8)
2202                         sv_utf8_upgrade(res);
2203                     str = SvPV_const(res,len);
2204 #ifdef EBCDIC_NEVER_MIND
2205                     /* charnames uses pack U and that has been
2206                      * recently changed to do the below uni->native
2207                      * mapping, so this would be redundant (and wrong,
2208                      * the code point would be doubly converted).
2209                      * But leave this in just in case the pack U change
2210                      * gets revoked, but the semantics is still
2211                      * desireable for charnames. --jhi */
2212                     {
2213                          UV uv = utf8_to_uvchr((const U8*)str, 0);
2214
2215                          if (uv < 0x100) {
2216                               U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2217
2218                               d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2219                               sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2220                               str = SvPV_const(res, len);
2221                          }
2222                     }
2223 #endif
2224                     if (!has_utf8 && SvUTF8(res)) {
2225                         const char * const ostart = SvPVX_const(sv);
2226                         SvCUR_set(sv, d - ostart);
2227                         SvPOK_on(sv);
2228                         *d = '\0';
2229                         sv_utf8_upgrade(sv);
2230                         /* this just broke our allocation above... */
2231                         SvGROW(sv, (STRLEN)(send - start));
2232                         d = SvPVX(sv) + SvCUR(sv);
2233                         has_utf8 = TRUE;
2234                     }
2235                     if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2236                         const char * const odest = SvPVX_const(sv);
2237
2238                         SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
2239                         d = SvPVX(sv) + (d - odest);
2240                     }
2241 #ifdef EBCDIC
2242                     if (!dorange)
2243                         native_range = FALSE; /* \N{} is guessed to be Unicode */
2244 #endif
2245                     Copy(str, d, len, char);
2246                     d += len;
2247                     SvREFCNT_dec(res);
2248                   cont_scan:
2249                     s = e + 1;
2250                 }
2251                 else
2252                     yyerror("Missing braces on \\N{}");
2253                 continue;
2254
2255             /* \c is a control character */
2256             case 'c':
2257                 s++;
2258                 if (s < send) {
2259                     U8 c = *s++;
2260 #ifdef EBCDIC
2261                     if (isLOWER(c))
2262                         c = toUPPER(c);
2263 #endif
2264                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2265                 }
2266                 else {
2267                     yyerror("Missing control char name in \\c");
2268                 }
2269                 continue;
2270
2271             /* printf-style backslashes, formfeeds, newlines, etc */
2272             case 'b':
2273                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2274                 break;
2275             case 'n':
2276                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2277                 break;
2278             case 'r':
2279                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2280                 break;
2281             case 'f':
2282                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2283                 break;
2284             case 't':
2285                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2286                 break;
2287             case 'e':
2288                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2289                 break;
2290             case 'a':
2291                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2292                 break;
2293             } /* end switch */
2294
2295             s++;
2296             continue;
2297         } /* end if (backslash) */
2298 #ifdef EBCDIC
2299         else
2300             literal_endpoint++;
2301 #endif
2302
2303     default_action:
2304         /* If we started with encoded form, or already know we want it
2305            and then encode the next character */
2306         if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
2307             STRLEN len  = 1;
2308             const UV nextuv   = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2309             const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2310             s += len;
2311             if (need > len) {
2312                 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
2313                 const STRLEN off = d - SvPVX_const(sv);
2314                 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
2315             }
2316             d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2317             has_utf8 = TRUE;
2318 #ifdef EBCDIC
2319             if (uv > 255 && !dorange)
2320                 native_range = FALSE;
2321 #endif
2322         }
2323         else {
2324             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2325         }
2326     } /* while loop to process each character */
2327
2328     /* terminate the string and set up the sv */
2329     *d = '\0';
2330     SvCUR_set(sv, d - SvPVX_const(sv));
2331     if (SvCUR(sv) >= SvLEN(sv))
2332         Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2333
2334     SvPOK_on(sv);
2335     if (PL_encoding && !has_utf8) {
2336         sv_recode_to_utf8(sv, PL_encoding);
2337         if (SvUTF8(sv))
2338             has_utf8 = TRUE;
2339     }
2340     if (has_utf8) {
2341         SvUTF8_on(sv);
2342         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2343             PL_sublex_info.sub_op->op_private |=
2344                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2345         }
2346     }
2347
2348     /* shrink the sv if we allocated more than we used */
2349     if (SvCUR(sv) + 5 < SvLEN(sv)) {
2350         SvPV_shrink_to_cur(sv);
2351     }
2352
2353     /* return the substring (via yylval) only if we parsed anything */
2354     if (s > PL_bufptr) {
2355         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
2356             sv = new_constant(start, s - start,
2357                               (const char *)(PL_lex_inpat ? "qr" : "q"),
2358                               sv, NULL,
2359                               (const char *)
2360                               (( PL_lex_inwhat == OP_TRANS
2361                                  ? "tr"
2362                                  : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
2363                                      ? "s"
2364                                      : "qq"))));
2365         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2366     } else
2367         SvREFCNT_dec(sv);
2368     return s;
2369 }
2370
2371 /* S_intuit_more
2372  * Returns TRUE if there's more to the expression (e.g., a subscript),
2373  * FALSE otherwise.
2374  *
2375  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2376  *
2377  * ->[ and ->{ return TRUE
2378  * { and [ outside a pattern are always subscripts, so return TRUE
2379  * if we're outside a pattern and it's not { or [, then return FALSE
2380  * if we're in a pattern and the first char is a {
2381  *   {4,5} (any digits around the comma) returns FALSE
2382  * if we're in a pattern and the first char is a [
2383  *   [] returns FALSE
2384  *   [SOMETHING] has a funky algorithm to decide whether it's a
2385  *      character class or not.  It has to deal with things like
2386  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2387  * anything else returns TRUE
2388  */
2389
2390 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2391
2392 STATIC int
2393 S_intuit_more(pTHX_ register char *s)
2394 {
2395     dVAR;
2396     if (PL_lex_brackets)
2397         return TRUE;
2398     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2399         return TRUE;
2400     if (*s != '{' && *s != '[')
2401         return FALSE;
2402     if (!PL_lex_inpat)
2403         return TRUE;
2404
2405     /* In a pattern, so maybe we have {n,m}. */
2406     if (*s == '{') {
2407         s++;
2408         if (!isDIGIT(*s))
2409             return TRUE;
2410         while (isDIGIT(*s))
2411             s++;
2412         if (*s == ',')
2413             s++;
2414         while (isDIGIT(*s))
2415             s++;
2416         if (*s == '}')
2417             return FALSE;
2418         return TRUE;
2419
2420     }
2421
2422     /* On the other hand, maybe we have a character class */
2423
2424     s++;
2425     if (*s == ']' || *s == '^')
2426         return FALSE;
2427     else {
2428         /* this is terrifying, and it works */
2429         int weight = 2;         /* let's weigh the evidence */
2430         char seen[256];
2431         unsigned char un_char = 255, last_un_char;
2432         const char * const send = strchr(s,']');
2433         char tmpbuf[sizeof PL_tokenbuf * 4];
2434
2435         if (!send)              /* has to be an expression */
2436             return TRUE;
2437
2438         Zero(seen,256,char);
2439         if (*s == '$')
2440             weight -= 3;
2441         else if (isDIGIT(*s)) {
2442             if (s[1] != ']') {
2443                 if (isDIGIT(s[1]) && s[2] == ']')
2444                     weight -= 10;
2445             }
2446             else
2447                 weight -= 100;
2448         }
2449         for (; s < send; s++) {
2450             last_un_char = un_char;
2451             un_char = (unsigned char)*s;
2452             switch (*s) {
2453             case '@':
2454             case '&':
2455             case '$':
2456                 weight -= seen[un_char] * 10;
2457                 if (isALNUM_lazy_if(s+1,UTF)) {
2458                     int len;
2459                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2460                     len = (int)strlen(tmpbuf);
2461                     if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2462                         weight -= 100;
2463                     else
2464                         weight -= 10;
2465                 }
2466                 else if (*s == '$' && s[1] &&
2467                   strchr("[#!%*<>()-=",s[1])) {
2468                     if (/*{*/ strchr("])} =",s[2]))
2469                         weight -= 10;
2470                     else
2471                         weight -= 1;
2472                 }
2473                 break;
2474             case '\\':
2475                 un_char = 254;
2476                 if (s[1]) {
2477                     if (strchr("wds]",s[1]))
2478                         weight += 100;
2479                     else if (seen[(U8)'\''] || seen[(U8)'"'])
2480                         weight += 1;
2481                     else if (strchr("rnftbxcav",s[1]))
2482                         weight += 40;
2483                     else if (isDIGIT(s[1])) {
2484                         weight += 40;
2485                         while (s[1] && isDIGIT(s[1]))
2486                             s++;
2487                     }
2488                 }
2489                 else
2490                     weight += 100;
2491                 break;
2492             case '-':
2493                 if (s[1] == '\\')
2494                     weight += 50;
2495                 if (strchr("aA01! ",last_un_char))
2496                     weight += 30;
2497                 if (strchr("zZ79~",s[1]))
2498                     weight += 30;
2499                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2500                     weight -= 5;        /* cope with negative subscript */
2501                 break;
2502             default:
2503                 if (!isALNUM(last_un_char)
2504                     && !(last_un_char == '$' || last_un_char == '@'
2505                          || last_un_char == '&')
2506                     && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2507                     char *d = tmpbuf;
2508                     while (isALPHA(*s))
2509                         *d++ = *s++;
2510                     *d = '\0';
2511                     if (keyword(tmpbuf, d - tmpbuf))
2512                         weight -= 150;
2513                 }
2514                 if (un_char == last_un_char + 1)
2515                     weight += 5;
2516                 weight -= seen[un_char];
2517                 break;
2518             }
2519             seen[un_char]++;
2520         }
2521         if (weight >= 0)        /* probably a character class */
2522             return FALSE;
2523     }
2524
2525     return TRUE;
2526 }
2527
2528 /*
2529  * S_intuit_method
2530  *
2531  * Does all the checking to disambiguate
2532  *   foo bar
2533  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
2534  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2535  *
2536  * First argument is the stuff after the first token, e.g. "bar".
2537  *
2538  * Not a method if bar is a filehandle.
2539  * Not a method if foo is a subroutine prototyped to take a filehandle.
2540  * Not a method if it's really "Foo $bar"
2541  * Method if it's "foo $bar"
2542  * Not a method if it's really "print foo $bar"
2543  * Method if it's really "foo package::" (interpreted as package->foo)
2544  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2545  * Not a method if bar is a filehandle or package, but is quoted with
2546  *   =>
2547  */
2548
2549 STATIC int
2550 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2551 {
2552     dVAR;
2553     char *s = start + (*start == '$');
2554     char tmpbuf[sizeof PL_tokenbuf];
2555     STRLEN len;
2556     GV* indirgv;
2557 #ifdef PERL_MAD
2558     int soff;
2559 #endif
2560
2561     if (gv) {
2562         if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2563             return 0;
2564         if (cv) {
2565             if (SvPOK(cv)) {
2566                 const char *proto = SvPVX_const(cv);
2567                 if (proto) {
2568                     if (*proto == ';')
2569                         proto++;
2570                     if (*proto == '*')
2571                         return 0;
2572                 }
2573             }
2574         } else
2575             gv = NULL;
2576     }
2577     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2578     /* start is the beginning of the possible filehandle/object,
2579      * and s is the end of it
2580      * tmpbuf is a copy of it
2581      */
2582
2583     if (*start == '$') {
2584         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2585             return 0;
2586 #ifdef PERL_MAD
2587         len = start - SvPVX(PL_linestr);
2588 #endif
2589         s = PEEKSPACE(s);
2590 #ifdef PERLMAD
2591         start = SvPVX(PL_linestr) + len;
2592 #endif
2593         PL_bufptr = start;
2594         PL_expect = XREF;
2595         return *s == '(' ? FUNCMETH : METHOD;
2596     }
2597     if (!keyword(tmpbuf, len)) {
2598         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2599             len -= 2;
2600             tmpbuf[len] = '\0';
2601 #ifdef PERL_MAD
2602             soff = s - SvPVX(PL_linestr);
2603 #endif
2604             goto bare_package;
2605         }
2606         indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2607         if (indirgv && GvCVu(indirgv))
2608             return 0;
2609         /* filehandle or package name makes it a method */
2610         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2611 #ifdef PERL_MAD
2612             soff = s - SvPVX(PL_linestr);
2613 #endif
2614             s = PEEKSPACE(s);
2615             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2616                 return 0;       /* no assumptions -- "=>" quotes bearword */
2617       bare_package:
2618             start_force(PL_curforce);
2619             NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2620                                                    newSVpvn(tmpbuf,len));
2621             NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2622             if (PL_madskills)
2623                 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2624             PL_expect = XTERM;
2625             force_next(WORD);
2626             PL_bufptr = s;
2627 #ifdef PERL_MAD
2628             PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2629 #endif
2630             return *s == '(' ? FUNCMETH : METHOD;
2631         }
2632     }
2633     return 0;
2634 }
2635
2636 /*
2637  * S_incl_perldb
2638  * Return a string of Perl code to load the debugger.  If PERL5DB
2639  * is set, it will return the contents of that, otherwise a
2640  * compile-time require of perl5db.pl.
2641  */
2642
2643 STATIC const char*
2644 S_incl_perldb(pTHX)
2645 {
2646     dVAR;
2647     if (PL_perldb) {
2648         const char * const pdb = PerlEnv_getenv("PERL5DB");
2649
2650         if (pdb)
2651             return pdb;
2652         SETERRNO(0,SS_NORMAL);
2653         return "BEGIN { require 'perl5db.pl' }";
2654     }
2655     return "";
2656 }
2657
2658
2659 /* Encoded script support. filter_add() effectively inserts a
2660  * 'pre-processing' function into the current source input stream.
2661  * Note that the filter function only applies to the current source file
2662  * (e.g., it will not affect files 'require'd or 'use'd by this one).
2663  *
2664  * The datasv parameter (which may be NULL) can be used to pass
2665  * private data to this instance of the filter. The filter function
2666  * can recover the SV using the FILTER_DATA macro and use it to
2667  * store private buffers and state information.
2668  *
2669  * The supplied datasv parameter is upgraded to a PVIO type
2670  * and the IoDIRP/IoANY field is used to store the function pointer,
2671  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2672  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2673  * private use must be set using malloc'd pointers.
2674  */
2675
2676 SV *
2677 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2678 {
2679     dVAR;
2680     if (!funcp)
2681         return NULL;
2682
2683     if (!PL_rsfp_filters)
2684         PL_rsfp_filters = newAV();
2685     if (!datasv)
2686         datasv = newSV(0);
2687     SvUPGRADE(datasv, SVt_PVIO);
2688     IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2689     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2690     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2691                           FPTR2DPTR(void *, IoANY(datasv)),
2692                           SvPV_nolen(datasv)));
2693     av_unshift(PL_rsfp_filters, 1);
2694     av_store(PL_rsfp_filters, 0, datasv) ;
2695     return(datasv);
2696 }
2697
2698
2699 /* Delete most recently added instance of this filter function. */
2700 void
2701 Perl_filter_del(pTHX_ filter_t funcp)
2702 {
2703     dVAR;
2704     SV *datasv;
2705
2706 #ifdef DEBUGGING
2707     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2708                           FPTR2DPTR(void*, funcp)));
2709 #endif
2710     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2711         return;
2712     /* if filter is on top of stack (usual case) just pop it off */
2713     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2714     if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2715         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2716         IoANY(datasv) = (void *)NULL;
2717         sv_free(av_pop(PL_rsfp_filters));
2718
2719         return;
2720     }
2721     /* we need to search for the correct entry and clear it     */
2722     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2723 }
2724
2725
2726 /* Invoke the idxth filter function for the current rsfp.        */
2727 /* maxlen 0 = read one text line */
2728 I32
2729 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2730 {
2731     dVAR;
2732     filter_t funcp;
2733     SV *datasv = NULL;
2734     /* This API is bad. It should have been using unsigned int for maxlen.
2735        Not sure if we want to change the API, but if not we should sanity
2736        check the value here.  */
2737     const unsigned int correct_length
2738         = maxlen < 0 ?
2739 #ifdef PERL_MICRO
2740         0x7FFFFFFF
2741 #else
2742         INT_MAX
2743 #endif
2744         : maxlen;
2745
2746     if (!PL_rsfp_filters)
2747         return -1;
2748     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
2749         /* Provide a default input filter to make life easy.    */
2750         /* Note that we append to the line. This is handy.      */
2751         DEBUG_P(PerlIO_printf(Perl_debug_log,
2752                               "filter_read %d: from rsfp\n", idx));
2753         if (correct_length) {
2754             /* Want a block */
2755             int len ;
2756             const int old_len = SvCUR(buf_sv);
2757
2758             /* ensure buf_sv is large enough */
2759             SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2760             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2761                                    correct_length)) <= 0) {
2762                 if (PerlIO_error(PL_rsfp))
2763                     return -1;          /* error */
2764                 else
2765                     return 0 ;          /* end of file */
2766             }
2767             SvCUR_set(buf_sv, old_len + len) ;
2768         } else {
2769             /* Want a line */
2770             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2771                 if (PerlIO_error(PL_rsfp))
2772                     return -1;          /* error */
2773                 else
2774                     return 0 ;          /* end of file */
2775             }
2776         }
2777         return SvCUR(buf_sv);
2778     }
2779     /* Skip this filter slot if filter has been deleted */
2780     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2781         DEBUG_P(PerlIO_printf(Perl_debug_log,
2782                               "filter_read %d: skipped (filter deleted)\n",
2783                               idx));
2784         return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2785     }
2786     /* Get function pointer hidden within datasv        */
2787     funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2788     DEBUG_P(PerlIO_printf(Perl_debug_log,
2789                           "filter_read %d: via function %p (%s)\n",
2790                           idx, (void*)datasv, SvPV_nolen_const(datasv)));
2791     /* Call function. The function is expected to       */
2792     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2793     /* Return: <0:error, =0:eof, >0:not eof             */
2794     return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2795 }
2796
2797 STATIC char *
2798 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2799 {
2800     dVAR;
2801 #ifdef PERL_CR_FILTER
2802     if (!PL_rsfp_filters) {
2803         filter_add(S_cr_textfilter,NULL);
2804     }
2805 #endif
2806     if (PL_rsfp_filters) {
2807         if (!append)
2808             SvCUR_set(sv, 0);   /* start with empty line        */
2809         if (FILTER_READ(0, sv, 0) > 0)
2810             return ( SvPVX(sv) ) ;
2811         else
2812             return NULL ;
2813     }
2814     else
2815         return (sv_gets(sv, fp, append));
2816 }
2817
2818 STATIC HV *
2819 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2820 {
2821     dVAR;
2822     GV *gv;
2823
2824     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2825         return PL_curstash;
2826
2827     if (len > 2 &&
2828         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2829         (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
2830     {
2831         return GvHV(gv);                        /* Foo:: */
2832     }
2833
2834     /* use constant CLASS => 'MyClass' */
2835     gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
2836     if (gv && GvCV(gv)) {
2837         SV * const sv = cv_const_sv(GvCV(gv));
2838         if (sv)
2839             pkgname = SvPV_nolen_const(sv);
2840     }
2841
2842     return gv_stashpv(pkgname, FALSE);
2843 }
2844
2845 #ifdef PERL_MAD
2846  /*
2847  * Perl_madlex
2848  * The intent of this yylex wrapper is to minimize the changes to the
2849  * tokener when we aren't interested in collecting madprops.  It remains
2850  * to be seen how successful this strategy will be...
2851  */
2852
2853 int
2854 Perl_madlex(pTHX)
2855 {
2856     int optype;
2857     char *s = PL_bufptr;
2858
2859     /* make sure PL_thiswhite is initialized */
2860     PL_thiswhite = 0;
2861     PL_thismad = 0;
2862
2863     /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
2864     if (PL_pending_ident)
2865         return S_pending_ident(aTHX);
2866
2867     /* previous token ate up our whitespace? */
2868     if (!PL_lasttoke && PL_nextwhite) {
2869         PL_thiswhite = PL_nextwhite;
2870         PL_nextwhite = 0;
2871     }
2872
2873     /* isolate the token, and figure out where it is without whitespace */
2874     PL_realtokenstart = -1;
2875     PL_thistoken = 0;
2876     optype = yylex();
2877     s = PL_bufptr;
2878     assert(PL_curforce < 0);
2879
2880     if (!PL_thismad || PL_thismad->mad_key == '^') {    /* not forced already? */
2881         if (!PL_thistoken) {
2882             if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
2883                 PL_thistoken = newSVpvn("",0);
2884             else {
2885                 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
2886                 PL_thistoken = newSVpvn(tstart, s - tstart);
2887             }
2888         }
2889         if (PL_thismad) /* install head */
2890             CURMAD('X', PL_thistoken);
2891     }
2892
2893     /* last whitespace of a sublex? */
2894     if (optype == ')' && PL_endwhite) {
2895         CURMAD('X', PL_endwhite);
2896     }
2897
2898     if (!PL_thismad) {
2899
2900         /* if no whitespace and we're at EOF, bail.  Otherwise fake EOF below. */
2901         if (!PL_thiswhite && !PL_endwhite && !optype) {
2902             sv_free(PL_thistoken);
2903             PL_thistoken = 0;
2904             return 0;
2905         }
2906
2907         /* put off final whitespace till peg */
2908         if (optype == ';' && !PL_rsfp) {
2909             PL_nextwhite = PL_thiswhite;
2910             PL_thiswhite = 0;
2911         }
2912         else if (PL_thisopen) {
2913             CURMAD('q', PL_thisopen);
2914             if (PL_thistoken)
2915                 sv_free(PL_thistoken);
2916             PL_thistoken = 0;
2917         }
2918         else {
2919             /* Store actual token text as madprop X */
2920             CURMAD('X', PL_thistoken);
2921         }
2922
2923         if (PL_thiswhite) {
2924             /* add preceding whitespace as madprop _ */
2925             CURMAD('_', PL_thiswhite);
2926         }
2927
2928         if (PL_thisstuff) {
2929             /* add quoted material as madprop = */
2930             CURMAD('=', PL_thisstuff);
2931         }
2932
2933         if (PL_thisclose) {
2934             /* add terminating quote as madprop Q */
2935             CURMAD('Q', PL_thisclose);
2936         }
2937     }
2938
2939     /* special processing based on optype */
2940
2941     switch (optype) {
2942
2943     /* opval doesn't need a TOKEN since it can already store mp */
2944     case WORD:
2945     case METHOD:
2946     case FUNCMETH:
2947     case THING:
2948     case PMFUNC:
2949     case PRIVATEREF:
2950     case FUNC0SUB:
2951     case UNIOPSUB:
2952     case LSTOPSUB:
2953         if (yylval.opval)
2954             append_madprops(PL_thismad, yylval.opval, 0);
2955         PL_thismad = 0;
2956         return optype;
2957
2958     /* fake EOF */
2959     case 0:
2960         optype = PEG;
2961         if (PL_endwhite) {
2962             addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
2963             PL_endwhite = 0;
2964         }
2965         break;
2966
2967     case ']':
2968     case '}':
2969         if (PL_faketokens)
2970             break;
2971         /* remember any fake bracket that lexer is about to discard */
2972         if (PL_lex_brackets == 1 &&
2973             ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
2974         {
2975             s = PL_bufptr;
2976             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2977                 s++;
2978             if (*s == '}') {
2979                 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
2980                 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
2981                 PL_thiswhite = 0;
2982                 PL_bufptr = s - 1;
2983                 break;  /* don't bother looking for trailing comment */
2984             }
2985             else
2986                 s = PL_bufptr;
2987         }
2988         if (optype == ']')
2989             break;
2990         /* FALLTHROUGH */
2991
2992     /* attach a trailing comment to its statement instead of next token */
2993     case ';':
2994         if (PL_faketokens)
2995             break;
2996         if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
2997             s = PL_bufptr;
2998             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2999                 s++;
3000             if (*s == '\n' || *s == '#') {
3001                 while (s < PL_bufend && *s != '\n')
3002                     s++;
3003                 if (s < PL_bufend)
3004                     s++;
3005                 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3006                 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3007                 PL_thiswhite = 0;
3008                 PL_bufptr = s;
3009             }
3010         }
3011         break;
3012
3013     /* pval */
3014     case LABEL:
3015         break;
3016
3017     /* ival */
3018     default:
3019         break;
3020
3021     }
3022
3023     /* Create new token struct.  Note: opvals return early above. */
3024     yylval.tkval = newTOKEN(optype, yylval, PL_thismad);
3025     PL_thismad = 0;
3026     return optype;
3027 }
3028 #endif
3029
3030 STATIC char *
3031 S_tokenize_use(pTHX_ int is_use, char *s) {
3032     dVAR;
3033     if (PL_expect != XSTATE)
3034         yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3035                     is_use ? "use" : "no"));
3036     s = SKIPSPACE1(s);
3037     if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3038         s = force_version(s, TRUE);
3039         if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3040             start_force(PL_curforce);
3041             NEXTVAL_NEXTTOKE.opval = NULL;
3042             force_next(WORD);
3043         }
3044         else if (*s == 'v') {
3045             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3046             s = force_version(s, FALSE);
3047         }
3048     }
3049     else {
3050         s = force_word(s,WORD,FALSE,TRUE,FALSE);
3051         s = force_version(s, FALSE);
3052     }
3053     yylval.ival = is_use;
3054     return s;
3055 }
3056 #ifdef DEBUGGING
3057     static const char* const exp_name[] =
3058         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3059           "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3060         };
3061 #endif
3062
3063 /*
3064   yylex
3065
3066   Works out what to call the token just pulled out of the input
3067   stream.  The yacc parser takes care of taking the ops we return and
3068   stitching them into a tree.
3069
3070   Returns:
3071     PRIVATEREF
3072
3073   Structure:
3074       if read an identifier
3075           if we're in a my declaration
3076               croak if they tried to say my($foo::bar)
3077               build the ops for a my() declaration
3078           if it's an access to a my() variable
3079               are we in a sort block?
3080                   croak if my($a); $a <=> $b
3081               build ops for access to a my() variable
3082           if in a dq string, and they've said @foo and we can't find @foo
3083               croak
3084           build ops for a bareword
3085       if we already built the token before, use it.
3086 */
3087
3088
3089 #ifdef __SC__
3090 #pragma segment Perl_yylex
3091 #endif
3092 int
3093 Perl_yylex(pTHX)
3094 {
3095     dVAR;
3096     register char *s = PL_bufptr;
3097     register char *d;
3098     STRLEN len;
3099     bool bof = FALSE;
3100
3101     /* orig_keyword, gvp, and gv are initialized here because
3102      * jump to the label just_a_word_zero can bypass their
3103      * initialization later. */
3104     I32 orig_keyword = 0;
3105     GV *gv = NULL;
3106     GV **gvp = NULL;
3107
3108     DEBUG_T( {
3109         SV* tmp = newSVpvs("");
3110         PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3111             (IV)CopLINE(PL_curcop),
3112             lex_state_names[PL_lex_state],
3113             exp_name[PL_expect],
3114             pv_display(tmp, s, strlen(s), 0, 60));
3115         SvREFCNT_dec(tmp);
3116     } );
3117     /* check if there's an identifier for us to look at */
3118     if (PL_pending_ident)
3119         return REPORT(S_pending_ident(aTHX));
3120
3121     /* no identifier pending identification */
3122
3123     switch (PL_lex_state) {
3124 #ifdef COMMENTARY
3125     case LEX_NORMAL:            /* Some compilers will produce faster */
3126     case LEX_INTERPNORMAL:      /* code if we comment these out. */
3127         break;
3128 #endif
3129
3130     /* when we've already built the next token, just pull it out of the queue */
3131     case LEX_KNOWNEXT:
3132 #ifdef PERL_MAD
3133         PL_lasttoke--;
3134         yylval = PL_nexttoke[PL_lasttoke].next_val;
3135         if (PL_madskills) {
3136             PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3137             PL_nexttoke[PL_lasttoke].next_mad = 0;
3138             if (PL_thismad && PL_thismad->mad_key == '_') {
3139                 PL_thiswhite = (SV*)PL_thismad->mad_val;
3140                 PL_thismad->mad_val = 0;
3141                 mad_free(PL_thismad);
3142                 PL_thismad = 0;
3143             }
3144         }
3145         if (!PL_lasttoke) {
3146             PL_lex_state = PL_lex_defer;
3147             PL_expect = PL_lex_expect;
3148             PL_lex_defer = LEX_NORMAL;
3149             if (!PL_nexttoke[PL_lasttoke].next_type)
3150                 return yylex();
3151         }
3152 #else
3153         PL_nexttoke--;
3154         yylval = PL_nextval[PL_nexttoke];
3155         if (!PL_nexttoke) {
3156             PL_lex_state = PL_lex_defer;
3157             PL_expect = PL_lex_expect;
3158             PL_lex_defer = LEX_NORMAL;
3159         }
3160 #endif
3161 #ifdef PERL_MAD
3162         /* FIXME - can these be merged?  */
3163         return(PL_nexttoke[PL_lasttoke].next_type);
3164 #else
3165         return REPORT(PL_nexttype[PL_nexttoke]);
3166 #endif
3167
3168     /* interpolated case modifiers like \L \U, including \Q and \E.
3169        when we get here, PL_bufptr is at the \
3170     */
3171     case LEX_INTERPCASEMOD:
3172 #ifdef DEBUGGING
3173         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3174             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3175 #endif
3176         /* handle \E or end of string */
3177         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3178             /* if at a \E */
3179             if (PL_lex_casemods) {
3180                 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3181                 PL_lex_casestack[PL_lex_casemods] = '\0';
3182
3183                 if (PL_bufptr != PL_bufend
3184                     && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3185                     PL_bufptr += 2;
3186                     PL_lex_state = LEX_INTERPCONCAT;
3187 #ifdef PERL_MAD
3188                     if (PL_madskills)
3189                         PL_thistoken = newSVpvn("\\E",2);
3190 #endif
3191                 }
3192                 return REPORT(')');
3193             }
3194 #ifdef PERL_MAD
3195             while (PL_bufptr != PL_bufend &&
3196               PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3197                 if (!PL_thiswhite)
3198                     PL_thiswhite = newSVpvn("",0);
3199                 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3200                 PL_bufptr += 2;
3201             }
3202 #else
3203             if (PL_bufptr != PL_bufend)
3204                 PL_bufptr += 2;
3205 #endif
3206             PL_lex_state = LEX_INTERPCONCAT;
3207             return yylex();
3208         }
3209         else {
3210             DEBUG_T({ PerlIO_printf(Perl_debug_log,
3211               "### Saw case modifier\n"); });
3212             s = PL_bufptr + 1;
3213             if (s[1] == '\\' && s[2] == 'E') {
3214 #ifdef PERL_MAD
3215                 if (!PL_thiswhite)
3216                     PL_thiswhite = newSVpvn("",0);
3217                 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3218 #endif
3219                 PL_bufptr = s + 3;
3220                 PL_lex_state = LEX_INTERPCONCAT;
3221                 return yylex();
3222             }
3223             else {
3224                 I32 tmp;
3225                 if (!PL_madskills) /* when just compiling don't need correct */
3226                     if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3227                         tmp = *s, *s = s[2], s[2] = (char)tmp;  /* misordered... */
3228                 if ((*s == 'L' || *s == 'U') &&
3229                     (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3230                     PL_lex_casestack[--PL_lex_casemods] = '\0';
3231                     return REPORT(')');
3232                 }
3233                 if (PL_lex_casemods > 10)
3234                     Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3235                 PL_lex_casestack[PL_lex_casemods++] = *s;
3236                 PL_lex_casestack[PL_lex_casemods] = '\0';
3237                 PL_lex_state = LEX_INTERPCONCAT;
3238                 start_force(PL_curforce);
3239                 NEXTVAL_NEXTTOKE.ival = 0;
3240                 force_next('(');
3241                 start_force(PL_curforce);
3242                 if (*s == 'l')
3243                     NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3244                 else if (*s == 'u')
3245                     NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3246                 else if (*s == 'L')
3247                     NEXTVAL_NEXTTOKE.ival = OP_LC;
3248                 else if (*s == 'U')
3249                     NEXTVAL_NEXTTOKE.ival = OP_UC;
3250                 else if (*s == 'Q')
3251                     NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3252                 else
3253                     Perl_croak(aTHX_ "panic: yylex");
3254                 if (PL_madskills) {
3255                     SV* const tmpsv = newSVpvn("",0);
3256                     Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
3257                     curmad('_', tmpsv);
3258                 }
3259                 PL_bufptr = s + 1;
3260             }
3261             force_next(FUNC);
3262             if (PL_lex_starts) {
3263                 s = PL_bufptr;
3264                 PL_lex_starts = 0;
3265 #ifdef PERL_MAD
3266                 if (PL_madskills) {
3267                     if (PL_thistoken)
3268                         sv_free(PL_thistoken);
3269                     PL_thistoken = newSVpvn("",0);
3270                 }
3271 #endif
3272                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3273                 if (PL_lex_casemods == 1 && PL_lex_inpat)
3274                     OPERATOR(',');
3275                 else
3276                     Aop(OP_CONCAT);
3277             }
3278             else
3279                 return yylex();
3280         }
3281
3282     case LEX_INTERPPUSH:
3283         return REPORT(sublex_push());
3284
3285     case LEX_INTERPSTART:
3286         if (PL_bufptr == PL_bufend)
3287             return REPORT(sublex_done());
3288         DEBUG_T({ PerlIO_printf(Perl_debug_log,
3289               "### Interpolated variable\n"); });
3290         PL_expect = XTERM;
3291         PL_lex_dojoin = (*PL_bufptr == '@');
3292         PL_lex_state = LEX_INTERPNORMAL;
3293         if (PL_lex_dojoin) {
3294             start_force(PL_curforce);
3295             NEXTVAL_NEXTTOKE.ival = 0;
3296             force_next(',');
3297             start_force(PL_curforce);
3298             force_ident("\"", '$');
3299             start_force(PL_curforce);
3300             NEXTVAL_NEXTTOKE.ival = 0;
3301             force_next('$');
3302             start_force(PL_curforce);
3303             NEXTVAL_NEXTTOKE.ival = 0;
3304             force_next('(');
3305             start_force(PL_curforce);
3306             NEXTVAL_NEXTTOKE.ival = OP_JOIN;    /* emulate join($", ...) */
3307             force_next(FUNC);
3308         }
3309         if (PL_lex_starts++) {
3310             s = PL_bufptr;
3311 #ifdef PERL_MAD
3312             if (PL_madskills) {
3313                 if (PL_thistoken)
3314                     sv_free(PL_thistoken);
3315                 PL_thistoken = newSVpvn("",0);
3316             }
3317 #endif
3318             /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3319             if (!PL_lex_casemods && PL_lex_inpat)
3320                 OPERATOR(',');
3321             else
3322                 Aop(OP_CONCAT);
3323         }
3324         return yylex();
3325
3326     case LEX_INTERPENDMAYBE:
3327         if (intuit_more(PL_bufptr)) {
3328             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
3329             break;
3330         }
3331         /* FALL THROUGH */
3332
3333     case LEX_INTERPEND:
3334         if (PL_lex_dojoin) {
3335             PL_lex_dojoin = FALSE;
3336             PL_lex_state = LEX_INTERPCONCAT;
3337 #ifdef PERL_MAD
3338             if (PL_madskills) {
3339                 if (PL_thistoken)
3340                     sv_free(PL_thistoken);
3341                 PL_thistoken = newSVpvn("",0);
3342             }
3343 #endif
3344             return REPORT(')');
3345         }
3346         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3347             && SvEVALED(PL_lex_repl))
3348         {
3349             if (PL_bufptr != PL_bufend)
3350                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3351             PL_lex_repl = NULL;
3352         }
3353         /* FALLTHROUGH */
3354     case LEX_INTERPCONCAT:
3355 #ifdef DEBUGGING
3356         if (PL_lex_brackets)
3357             Perl_croak(aTHX_ "panic: INTERPCONCAT");
3358 #endif
3359         if (PL_bufptr == PL_bufend)
3360             return REPORT(sublex_done());
3361
3362         if (SvIVX(PL_linestr) == '\'') {
3363             SV *sv = newSVsv(PL_linestr);
3364             if (!PL_lex_inpat)
3365                 sv = tokeq(sv);
3366             else if ( PL_hints & HINT_NEW_RE )
3367                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
3368             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3369             s = PL_bufend;
3370         }
3371         else {
3372             s = scan_const(PL_bufptr);
3373             if (*s == '\\')
3374                 PL_lex_state = LEX_INTERPCASEMOD;
3375             else
3376                 PL_lex_state = LEX_INTERPSTART;
3377         }
3378
3379         if (s != PL_bufptr) {
3380             start_force(PL_curforce);
3381             if (PL_madskills) {
3382                 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3383             }
3384             NEXTVAL_NEXTTOKE = yylval;
3385             PL_expect = XTERM;
3386             force_next(THING);
3387             if (PL_lex_starts++) {
3388 #ifdef PERL_MAD
3389                 if (PL_madskills) {
3390                     if (PL_thistoken)
3391                         sv_free(PL_thistoken);
3392                     PL_thistoken = newSVpvn("",0);
3393                 }
3394 #endif
3395                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3396                 if (!PL_lex_casemods && PL_lex_inpat)
3397                     OPERATOR(',');
3398                 else
3399                     Aop(OP_CONCAT);
3400             }
3401             else {
3402                 PL_bufptr = s;
3403                 return yylex();
3404             }
3405         }
3406
3407         return yylex();
3408     case LEX_FORMLINE:
3409         PL_lex_state = LEX_NORMAL;
3410         s = scan_formline(PL_bufptr);
3411         if (!PL_lex_formbrack)
3412             goto rightbracket;
3413         OPERATOR(';');
3414     }
3415
3416     s = PL_bufptr;
3417     PL_oldoldbufptr = PL_oldbufptr;
3418     PL_oldbufptr = s;
3419
3420   retry:
3421 #ifdef PERL_MAD
3422     if (PL_thistoken) {
3423         sv_free(PL_thistoken);
3424         PL_thistoken = 0;
3425     }
3426     PL_realtokenstart = s - SvPVX(PL_linestr);  /* assume but undo on ws */
3427 #endif
3428     switch (*s) {
3429     default:
3430         if (isIDFIRST_lazy_if(s,UTF))
3431             goto keylookup;
3432         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
3433     case 4:
3434     case 26:
3435         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
3436     case 0:
3437 #ifdef PERL_MAD
3438         if (PL_madskills)
3439             PL_faketokens = 0;
3440 #endif
3441         if (!PL_rsfp) {
3442             PL_last_uni = 0;
3443             PL_last_lop = 0;
3444             if (PL_lex_brackets) {
3445                 yyerror((const char *)
3446                         (PL_lex_formbrack
3447                          ? "Format not terminated"
3448                          : "Missing right curly or square bracket"));
3449             }
3450             DEBUG_T( { PerlIO_printf(Perl_debug_log,
3451                         "### Tokener got EOF\n");
3452             } );
3453             TOKEN(0);
3454         }
3455         if (s++ < PL_bufend)
3456             goto retry;                 /* ignore stray nulls */
3457         PL_last_uni = 0;
3458         PL_last_lop = 0;
3459         if (!PL_in_eval && !PL_preambled) {
3460             PL_preambled = TRUE;
3461 #ifdef PERL_MAD
3462             if (PL_madskills)
3463                 PL_faketokens = 1;
3464 #endif
3465             sv_setpv(PL_linestr,incl_perldb());
3466             if (SvCUR(PL_linestr))
3467                 sv_catpvs(PL_linestr,";");
3468             if (PL_preambleav){
3469                 while(AvFILLp(PL_preambleav) >= 0) {
3470                     SV *tmpsv = av_shift(PL_preambleav);
3471                     sv_catsv(PL_linestr, tmpsv);
3472                     sv_catpvs(PL_linestr, ";");
3473                     sv_free(tmpsv);
3474                 }
3475                 sv_free((SV*)PL_preambleav);
3476                 PL_preambleav = NULL;
3477             }
3478             if (PL_minus_n || PL_minus_p) {
3479                 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3480                 if (PL_minus_l)
3481                     sv_catpvs(PL_linestr,"chomp;");
3482                 if (PL_minus_a) {
3483                     if (PL_minus_F) {
3484                         if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3485                              || *PL_splitstr == '"')
3486                               && strchr(PL_splitstr + 1, *PL_splitstr))
3487                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3488                         else {
3489                             /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3490                                bytes can be used as quoting characters.  :-) */
3491                             const char *splits = PL_splitstr;
3492                             sv_catpvs(PL_linestr, "our @F=split(q\0");
3493                             do {
3494                                 /* Need to \ \s  */
3495                                 if (*splits == '\\')
3496                                     sv_catpvn(PL_linestr, splits, 1);
3497                                 sv_catpvn(PL_linestr, splits, 1);
3498                             } while (*splits++);
3499                             /* This loop will embed the trailing NUL of
3500                                PL_linestr as the last thing it does before
3501                                terminating.  */
3502                             sv_catpvs(PL_linestr, ");");
3503                         }
3504                     }
3505                     else
3506                         sv_catpvs(PL_linestr,"our @F=split(' ');");
3507                 }
3508             }
3509             if (PL_minus_E)
3510                 sv_catpvs(PL_linestr,"use feature ':5.10';");
3511             sv_catpvs(PL_linestr, "\n");
3512             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3513             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3514             PL_last_lop = PL_last_uni = NULL;
3515             if (PERLDB_LINE && PL_curstash != PL_debstash) {
3516                 SV * const sv = newSV(0);
3517
3518                 sv_upgrade(sv, SVt_PVMG);
3519                 sv_setsv(sv,PL_linestr);
3520                 (void)SvIOK_on(sv);
3521                 SvIV_set(sv, 0);
3522                 av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
3523             }
3524             goto retry;
3525         }
3526         do {
3527             bof = PL_rsfp ? TRUE : FALSE;
3528             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3529               fake_eof:
3530 #ifdef PERL_MAD
3531                 PL_realtokenstart = -1;
3532 #endif
3533                 if (PL_rsfp) {
3534                     if (PL_preprocess && !PL_in_eval)
3535                         (void)PerlProc_pclose(PL_rsfp);
3536                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3537                         PerlIO_clearerr(PL_rsfp);
3538                     else
3539                         (void)PerlIO_close(PL_rsfp);
3540                     PL_rsfp = NULL;
3541                     PL_doextract = FALSE;
3542                 }
3543                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3544 #ifdef PERL_MAD
3545                     if (PL_madskills)
3546                         PL_faketokens = 1;
3547 #endif
3548                     sv_setpv(PL_linestr,
3549                              (const char *)
3550                              (PL_minus_p
3551                               ? ";}continue{print;}" : ";}"));
3552                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3553                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3554                     PL_last_lop = PL_last_uni = NULL;
3555                     PL_minus_n = PL_minus_p = 0;
3556                     goto retry;
3557                 }
3558                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3559                 PL_last_lop = PL_last_uni = NULL;
3560                 sv_setpvn(PL_linestr,"",0);
3561                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
3562             }
3563             /* If it looks like the start of a BOM or raw UTF-16,
3564              * check if it in fact is. */
3565             else if (bof &&
3566                      (*s == 0 ||
3567                       *(U8*)s == 0xEF ||
3568                       *(U8*)s >= 0xFE ||
3569                       s[1] == 0)) {
3570 #ifdef PERLIO_IS_STDIO
3571 #  ifdef __GNU_LIBRARY__
3572 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3573 #      define FTELL_FOR_PIPE_IS_BROKEN
3574 #    endif
3575 #  else
3576 #    ifdef __GLIBC__
3577 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3578 #        define FTELL_FOR_PIPE_IS_BROKEN
3579 #      endif
3580 #    endif
3581 #  endif
3582 #endif
3583 #ifdef FTELL_FOR_PIPE_IS_BROKEN
3584                 /* This loses the possibility to detect the bof
3585                  * situation on perl -P when the libc5 is being used.
3586                  * Workaround?  Maybe attach some extra state to PL_rsfp?
3587                  */
3588                 if (!PL_preprocess)
3589                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
3590 #else
3591                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3592 #endif
3593                 if (bof) {
3594                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3595                     s = swallow_bom((U8*)s);
3596                 }
3597             }
3598             if (PL_doextract) {
3599                 /* Incest with pod. */
3600 #ifdef PERL_MAD
3601                 if (PL_madskills)
3602                     sv_catsv(PL_thiswhite, PL_linestr);
3603 #endif
3604                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
3605                     sv_setpvn(PL_linestr, "", 0);
3606                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3607                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3608                     PL_last_lop = PL_last_uni = NULL;
3609                     PL_doextract = FALSE;
3610                 }
3611             }
3612             incline(s);
3613         } while (PL_doextract);
3614         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3615         if (PERLDB_LINE && PL_curstash != PL_debstash) {
3616             SV * const sv = newSV(0);
3617
3618             sv_upgrade(sv, SVt_PVMG);
3619             sv_setsv(sv,PL_linestr);
3620             (void)SvIOK_on(sv);
3621             SvIV_set(sv, 0);
3622             av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
3623         }
3624         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3625         PL_last_lop = PL_last_uni = NULL;
3626         if (CopLINE(PL_curcop) == 1) {
3627             while (s < PL_bufend && isSPACE(*s))
3628                 s++;
3629             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3630                 s++;
3631 #ifdef PERL_MAD
3632             if (PL_madskills)
3633                 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3634 #endif
3635             d = NULL;
3636             if (!PL_in_eval) {
3637                 if (*s == '#' && *(s+1) == '!')
3638                     d = s + 2;
3639 #ifdef ALTERNATE_SHEBANG
3640                 else {
3641                     static char const as[] = ALTERNATE_SHEBANG;
3642                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3643                         d = s + (sizeof(as) - 1);
3644                 }
3645 #endif /* ALTERNATE_SHEBANG */
3646             }
3647             if (d) {
3648                 char *ipath;
3649                 char *ipathend;
3650
3651                 while (isSPACE(*d))
3652                     d++;
3653                 ipath = d;
3654                 while (*d && !isSPACE(*d))
3655                     d++;
3656                 ipathend = d;
3657
3658 #ifdef ARG_ZERO_IS_SCRIPT
3659                 if (ipathend > ipath) {
3660                     /*
3661                      * HP-UX (at least) sets argv[0] to the script name,
3662                      * which makes $^X incorrect.  And Digital UNIX and Linux,
3663                      * at least, set argv[0] to the basename of the Perl
3664                      * interpreter. So, having found "#!", we'll set it right.
3665                      */
3666                     SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3667                                                     SVt_PV)); /* $^X */
3668                     assert(SvPOK(x) || SvGMAGICAL(x));
3669                     if (sv_eq(x, CopFILESV(PL_curcop))) {
3670                         sv_setpvn(x, ipath, ipathend - ipath);
3671                         SvSETMAGIC(x);
3672                     }
3673                     else {
3674                         STRLEN blen;
3675                         STRLEN llen;
3676                         const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3677                         const char * const lstart = SvPV_const(x,llen);
3678                         if (llen < blen) {
3679                             bstart += blen - llen;
3680                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3681                                 sv_setpvn(x, ipath, ipathend - ipath);
3682                                 SvSETMAGIC(x);
3683                             }
3684                         }
3685                     }
3686                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
3687                 }
3688 #endif /* ARG_ZERO_IS_SCRIPT */
3689
3690                 /*
3691                  * Look for options.
3692                  */
3693                 d = instr(s,"perl -");
3694                 if (!d) {
3695                     d = instr(s,"perl");
3696 #if defined(DOSISH)
3697                     /* avoid getting into infinite loops when shebang
3698                      * line contains "Perl" rather than "perl" */
3699                     if (!d) {
3700                         for (d = ipathend-4; d >= ipath; --d) {
3701                             if ((*d == 'p' || *d == 'P')
3702                                 && !ibcmp(d, "perl", 4))
3703                             {
3704                                 break;
3705                             }
3706                         }
3707                         if (d < ipath)
3708                             d = NULL;
3709                     }
3710 #endif
3711                 }
3712 #ifdef ALTERNATE_SHEBANG
3713                 /*
3714                  * If the ALTERNATE_SHEBANG on this system starts with a
3715                  * character that can be part of a Perl expression, then if
3716                  * we see it but not "perl", we're probably looking at the
3717                  * start of Perl code, not a request to hand off to some
3718                  * other interpreter.  Similarly, if "perl" is there, but
3719                  * not in the first 'word' of the line, we assume the line
3720                  * contains the start of the Perl program.
3721                  */
3722                 if (d && *s != '#') {
3723                     const char *c = ipath;
3724                     while (*c && !strchr("; \t\r\n\f\v#", *c))
3725                         c++;
3726                     if (c < d)
3727                         d = NULL;       /* "perl" not in first word; ignore */
3728                     else
3729                         *s = '#';       /* Don't try to parse shebang line */
3730                 }
3731 #endif /* ALTERNATE_SHEBANG */
3732 #ifndef MACOS_TRADITIONAL
3733                 if (!d &&
3734                     *s == '#' &&
3735                     ipathend > ipath &&
3736                     !PL_minus_c &&
3737                     !instr(s,"indir") &&
3738                     instr(PL_origargv[0],"perl"))
3739                 {
3740                     dVAR;
3741                     char **newargv;
3742
3743                     *ipathend = '\0';
3744                     s = ipathend + 1;
3745                     while (s < PL_bufend && isSPACE(*s))
3746                         s++;
3747                     if (s < PL_bufend) {
3748                         Newxz(newargv,PL_origargc+3,char*);
3749                         newargv[1] = s;
3750                         while (s < PL_bufend && !isSPACE(*s))
3751                             s++;
3752                         *s = '\0';
3753                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3754                     }
3755                     else
3756                         newargv = PL_origargv;
3757                     newargv[0] = ipath;
3758                     PERL_FPU_PRE_EXEC
3759                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3760                     PERL_FPU_POST_EXEC
3761                     Perl_croak(aTHX_ "Can't exec %s", ipath);
3762                 }
3763 #endif
3764                 if (d) {
3765                     while (*d && !isSPACE(*d))
3766                         d++;
3767                     while (SPACE_OR_TAB(*d))
3768                         d++;
3769
3770                     if (*d++ == '-') {
3771                         const bool switches_done = PL_doswitches;
3772                         const U32 oldpdb = PL_perldb;
3773                         const bool oldn = PL_minus_n;
3774                         const bool oldp = PL_minus_p;
3775
3776                         do {
3777                             if (*d == 'M' || *d == 'm' || *d == 'C') {
3778                                 const char * const m = d;
3779                                 while (*d && !isSPACE(*d))
3780                                     d++;
3781                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3782                                       (int)(d - m), m);
3783                             }
3784                             d = moreswitches(d);
3785                         } while (d);
3786                         if (PL_doswitches && !switches_done) {
3787                             int argc = PL_origargc;
3788                             char **argv = PL_origargv;
3789                             do {
3790                                 argc--,argv++;
3791                             } while (argc && argv[0][0] == '-' && argv[0][1]);
3792                             init_argv_symbols(argc,argv);
3793                         }
3794                         if ((PERLDB_LINE && !oldpdb) ||
3795                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
3796                               /* if we have already added "LINE: while (<>) {",
3797                                  we must not do it again */
3798                         {
3799                             sv_setpvn(PL_linestr, "", 0);
3800                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3801                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3802                             PL_last_lop = PL_last_uni = NULL;
3803                             PL_preambled = FALSE;
3804                             if (PERLDB_LINE)
3805                                 (void)gv_fetchfile(PL_origfilename);
3806                             goto retry;
3807                         }
3808                     }
3809                 }
3810             }
3811         }
3812         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3813             PL_bufptr = s;
3814             PL_lex_state = LEX_FORMLINE;
3815             return yylex();
3816         }
3817         goto retry;
3818     case '\r':
3819 #ifdef PERL_STRICT_CR
3820         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3821         Perl_croak(aTHX_
3822       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3823 #endif
3824     case ' ': case '\t': case '\f': case 013:
3825 #ifdef MACOS_TRADITIONAL
3826     case '\312':
3827 #endif
3828 #ifdef PERL_MAD
3829         PL_realtokenstart = -1;
3830         s = SKIPSPACE0(s);
3831 #else
3832         s++;
3833 #endif
3834         goto retry;
3835     case '#':
3836     case '\n':
3837 #ifdef PERL_MAD
3838         PL_realtokenstart = -1;
3839         if (PL_madskills)
3840             PL_faketokens = 0;
3841 #endif
3842         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3843             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3844                 /* handle eval qq[#line 1 "foo"\n ...] */
3845                 CopLINE_dec(PL_curcop);
3846                 incline(s);
3847             }
3848             if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
3849                 s = SKIPSPACE0(s);
3850                 if (!PL_in_eval || PL_rsfp)
3851                     incline(s);
3852             }
3853             else {
3854                 d = s;
3855                 while (d < PL_bufend && *d != '\n')
3856                     d++;
3857                 if (d < PL_bufend)
3858                     d++;
3859                 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3860                   Perl_croak(aTHX_ "panic: input overflow");
3861 #ifdef PERL_MAD
3862                 if (PL_madskills)
3863                     PL_thiswhite = newSVpvn(s, d - s);
3864 #endif
3865                 s = d;
3866                 incline(s);
3867             }
3868             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3869                 PL_bufptr = s;
3870                 PL_lex_state = LEX_FORMLINE;
3871                 return yylex();
3872             }
3873         }
3874         else {
3875 #ifdef PERL_MAD
3876             if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
3877                 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
3878                     PL_faketokens = 0;
3879                     s = SKIPSPACE0(s);
3880                     TOKEN(PEG); /* make sure any #! line is accessible */
3881                 }
3882                 s = SKIPSPACE0(s);
3883             }
3884             else {
3885 /*              if (PL_madskills && PL_lex_formbrack) { */
3886                     d = s;
3887                     while (d < PL_bufend && *d != '\n')
3888                         d++;
3889                     if (d < PL_bufend)
3890                         d++;
3891                     else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3892                       Perl_croak(aTHX_ "panic: input overflow");
3893                     if (PL_madskills && CopLINE(PL_curcop) >= 1) {
3894                         if (!PL_thiswhite)
3895                             PL_thiswhite = newSVpvn("",0);
3896                         if (CopLINE(PL_curcop) == 1) {
3897                             sv_setpvn(PL_thiswhite, "", 0);
3898                             PL_faketokens = 0;
3899                         }
3900                         sv_catpvn(PL_thiswhite, s, d - s);
3901                     }
3902                     s = d;
3903 /*              }
3904                 *s = '\0';
3905                 PL_bufend = s; */
3906             }
3907 #else
3908             *s = '\0';
3909             PL_bufend = s;
3910 #endif
3911         }
3912         goto retry;
3913     case '-':
3914         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
3915             I32 ftst = 0;
3916             char tmp;
3917
3918             s++;
3919             PL_bufptr = s;
3920             tmp = *s++;
3921
3922             while (s < PL_bufend && SPACE_OR_TAB(*s))
3923                 s++;
3924
3925             if (strnEQ(s,"=>",2)) {
3926                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
3927                 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
3928                 OPERATOR('-');          /* unary minus */
3929             }
3930             PL_last_uni = PL_oldbufptr;
3931             switch (tmp) {
3932             case 'r': ftst = OP_FTEREAD;        break;
3933             case 'w': ftst = OP_FTEWRITE;       break;
3934             case 'x': ftst = OP_FTEEXEC;        break;
3935             case 'o': ftst = OP_FTEOWNED;       break;
3936             case 'R': ftst = OP_FTRREAD;        break;
3937             case 'W': ftst = OP_FTRWRITE;       break;
3938             case 'X': ftst = OP_FTREXEC;        break;
3939             case 'O': ftst = OP_FTROWNED;       break;
3940             case 'e': ftst = OP_FTIS;           break;
3941             case 'z': ftst = OP_FTZERO;         break;
3942             case 's': ftst = OP_FTSIZE;         break;
3943             case 'f': ftst = OP_FTFILE;         break;
3944             case 'd': ftst = OP_FTDIR;          break;
3945             case 'l': ftst = OP_FTLINK;         break;
3946             case 'p': ftst = OP_FTPIPE;         break;
3947             case 'S': ftst = OP_FTSOCK;         break;
3948             case 'u': ftst = OP_FTSUID;         break;
3949             case 'g': ftst = OP_FTSGID;         break;
3950             case 'k': ftst = OP_FTSVTX;         break;
3951             case 'b': ftst = OP_FTBLK;          break;
3952             case 'c': ftst = OP_FTCHR;          break;
3953             case 't': ftst = OP_FTTTY;          break;
3954             case 'T': ftst = OP_FTTEXT;         break;
3955             case 'B': ftst = OP_FTBINARY;       break;
3956             case 'M': case 'A': case 'C':
3957                 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
3958                 switch (tmp) {
3959                 case 'M': ftst = OP_FTMTIME;    break;
3960                 case 'A': ftst = OP_FTATIME;    break;
3961                 case 'C': ftst = OP_FTCTIME;    break;
3962                 default:                        break;
3963                 }
3964                 break;
3965             default:
3966                 break;
3967             }
3968             if (ftst) {
3969                 PL_last_lop_op = (OPCODE)ftst;
3970                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3971                         "### Saw file test %c\n", (int)tmp);
3972                 } );
3973                 FTST(ftst);
3974             }
3975             else {
3976                 /* Assume it was a minus followed by a one-letter named
3977                  * subroutine call (or a -bareword), then. */
3978                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3979                         "### '-%c' looked like a file test but was not\n",
3980                         (int) tmp);
3981                 } );
3982                 s = --PL_bufptr;
3983             }
3984         }
3985         {
3986             const char tmp = *s++;
3987             if (*s == tmp) {
3988                 s++;
3989                 if (PL_expect == XOPERATOR)
3990                     TERM(POSTDEC);
3991                 else
3992                     OPERATOR(PREDEC);
3993             }
3994             else if (*s == '>') {
3995                 s++;
3996                 s = SKIPSPACE1(s);
3997                 if (isIDFIRST_lazy_if(s,UTF)) {
3998                     s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3999                     TOKEN(ARROW);
4000                 }
4001                 else if (*s == '$')
4002                     OPERATOR(ARROW);
4003                 else
4004                     TERM(ARROW);
4005             }
4006             if (PL_expect == XOPERATOR)
4007                 Aop(OP_SUBTRACT);
4008             else {
4009                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4010                     check_uni();
4011                 OPERATOR('-');          /* unary minus */
4012             }
4013         }
4014
4015     case '+':
4016         {
4017             const char tmp = *s++;
4018             if (*s == tmp) {
4019                 s++;
4020                 if (PL_expect == XOPERATOR)
4021                     TERM(POSTINC);
4022                 else
4023                     OPERATOR(PREINC);
4024             }
4025             if (PL_expect == XOPERATOR)
4026                 Aop(OP_ADD);
4027             else {
4028                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4029                     check_uni();
4030                 OPERATOR('+');
4031             }
4032         }
4033
4034     case '*':
4035         if (PL_expect != XOPERATOR) {
4036             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4037             PL_expect = XOPERATOR;
4038             force_ident(PL_tokenbuf, '*');
4039             if (!*PL_tokenbuf)
4040                 PREREF('*');
4041             TERM('*');
4042         }
4043         s++;
4044         if (*s == '*') {
4045             s++;
4046             PWop(OP_POW);
4047         }
4048         Mop(OP_MULTIPLY);
4049
4050     case '%':
4051         if (PL_expect == XOPERATOR) {
4052             ++s;
4053             Mop(OP_MODULO);
4054         }
4055         PL_tokenbuf[0] = '%';
4056         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
4057         if (!PL_tokenbuf[1]) {
4058             PREREF('%');
4059         }
4060         PL_pending_ident = '%';
4061         TERM('%');
4062
4063     case '^':
4064         s++;
4065         BOop(OP_BIT_XOR);
4066     case '[':
4067         PL_lex_brackets++;
4068         /* FALL THROUGH */
4069     case '~':
4070         if (s[1] == '~'
4071         && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)
4072         && FEATURE_IS_ENABLED("~~"))
4073         {
4074             s += 2;
4075             Eop(OP_SMARTMATCH);
4076         }
4077     case ',':
4078         {
4079             const char tmp = *s++;
4080             OPERATOR(tmp);
4081         }
4082     case ':':
4083         if (s[1] == ':') {
4084             len = 0;
4085             goto just_a_word_zero_gv;
4086         }
4087         s++;
4088         switch (PL_expect) {
4089             OP *attrs;
4090 #ifdef PERL_MAD
4091             I32 stuffstart;
4092 #endif
4093         case XOPERATOR:
4094             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4095                 break;
4096             PL_bufptr = s;      /* update in case we back off */
4097             goto grabattrs;
4098         case XATTRBLOCK:
4099             PL_expect = XBLOCK;
4100             goto grabattrs;
4101         case XATTRTERM:
4102             PL_expect = XTERMBLOCK;
4103          grabattrs:
4104 #ifdef PERL_MAD
4105             stuffstart = s - SvPVX(PL_linestr) - 1;
4106 #endif
4107             s = PEEKSPACE(s);
4108             attrs = NULL;
4109             while (isIDFIRST_lazy_if(s,UTF)) {
4110                 I32 tmp;
4111                 SV *sv;
4112                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4113                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
4114                     if (tmp < 0) tmp = -tmp;
4115                     switch (tmp) {
4116                     case KEY_or:
4117                     case KEY_and:
4118                     case KEY_err:
4119                     case KEY_for:
4120                     case KEY_unless:
4121                     case KEY_if:
4122                     case KEY_while:
4123                     case KEY_until:
4124                         goto got_attrs;
4125                     default:
4126                         break;
4127                     }
4128                 }
4129                 sv = newSVpvn(s, len);
4130                 if (*d == '(') {
4131                     d = scan_str(d,TRUE,TRUE);
4132                     if (!d) {
4133                         /* MUST advance bufptr here to avoid bogus
4134                            "at end of line" context messages from yyerror().
4135                          */
4136                         PL_bufptr = s + len;
4137                         yyerror("Unterminated attribute parameter in attribute list");
4138                         if (attrs)
4139                             op_free(attrs);
4140                         sv_free(sv);
4141                         return REPORT(0);       /* EOF indicator */
4142                     }
4143                 }
4144                 if (PL_lex_stuff) {
4145                     sv_catsv(sv, PL_lex_stuff);
4146                     attrs = append_elem(OP_LIST, attrs,
4147                                         newSVOP(OP_CONST, 0, sv));
4148                     SvREFCNT_dec(PL_lex_stuff);
4149                     PL_lex_stuff = NULL;
4150                 }
4151                 else {
4152                     if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4153                         sv_free(sv);
4154                         if (PL_in_my == KEY_our) {
4155 #ifdef USE_ITHREADS
4156                             GvUNIQUE_on(cGVOPx_gv(yylval.opval));
4157 #else
4158                             /* skip to avoid loading attributes.pm */
4159 #endif
4160                             deprecate(":unique");
4161                         }
4162                         else
4163                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4164                     }
4165
4166                     /* NOTE: any CV attrs applied here need to be part of
4167                        the CVf_BUILTIN_ATTRS define in cv.h! */
4168                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4169                         sv_free(sv);
4170                         CvLVALUE_on(PL_compcv);
4171                     }
4172                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4173                         sv_free(sv);
4174                         CvLOCKED_on(PL_compcv);
4175                     }
4176                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4177                         sv_free(sv);
4178                         CvMETHOD_on(PL_compcv);
4179                     }
4180                     else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) {
4181                         sv_free(sv);
4182                         CvASSERTION_on(PL_compcv);
4183                     }
4184                     /* After we've set the flags, it could be argued that
4185                        we don't need to do the attributes.pm-based setting
4186                        process, and shouldn't bother appending recognized
4187                        flags.  To experiment with that, uncomment the
4188                        following "else".  (Note that's already been
4189                        uncommented.  That keeps the above-applied built-in
4190                        attributes from being intercepted (and possibly
4191                        rejected) by a package's attribute routines, but is
4192                        justified by the performance win for the common case
4193                        of applying only built-in attributes.) */
4194                     else
4195                         attrs = append_elem(OP_LIST, attrs,
4196                                             newSVOP(OP_CONST, 0,
4197                                                     sv));
4198                 }
4199                 s = PEEKSPACE(d);
4200                 if (*s == ':' && s[1] != ':')
4201                     s = PEEKSPACE(s+1);
4202                 else if (s == d)
4203                     break;      /* require real whitespace or :'s */
4204                 /* XXX losing whitespace on sequential attributes here */
4205             }
4206             {
4207                 const char tmp
4208                     = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4209                 if (*s != ';' && *s != '}' && *s != tmp
4210                     && (tmp != '=' || *s != ')')) {
4211                     const char q = ((*s == '\'') ? '"' : '\'');
4212                     /* If here for an expression, and parsed no attrs, back
4213                        off. */
4214                     if (tmp == '=' && !attrs) {
4215                         s = PL_bufptr;
4216                         break;
4217                     }
4218                     /* MUST advance bufptr here to avoid bogus "at end of line"
4219                        context messages from yyerror().
4220                     */
4221                     PL_bufptr = s;
4222                     yyerror( (const char *)
4223                              (*s
4224                               ? Perl_form(aTHX_ "Invalid separator character "
4225                                           "%c%c%c in attribute list", q, *s, q)
4226                               : "Unterminated attribute list" ) );
4227                     if (attrs)
4228                         op_free(attrs);
4229                     OPERATOR(':');
4230                 }
4231             }
4232         got_attrs:
4233             if (attrs) {
4234                 start_force(PL_curforce);
4235                 NEXTVAL_NEXTTOKE.opval = attrs;
4236                 CURMAD('_', PL_nextwhite);
4237                 force_next(THING);
4238             }
4239 #ifdef PERL_MAD
4240             if (PL_madskills) {
4241                 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4242                                      (s - SvPVX(PL_linestr)) - stuffstart);
4243             }
4244 #endif
4245             TOKEN(COLONATTR);
4246         }
4247         OPERATOR(':');
4248     case '(':
4249         s++;
4250         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4251             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
4252         else
4253             PL_expect = XTERM;
4254         s = SKIPSPACE1(s);
4255         TOKEN('(');
4256     case ';':
4257         CLINE;
4258         {
4259             const char tmp = *s++;
4260             OPERATOR(tmp);
4261         }
4262     case ')':
4263         {
4264             const char tmp = *s++;
4265             s = SKIPSPACE1(s);
4266             if (*s == '{')
4267                 PREBLOCK(tmp);
4268             TERM(tmp);
4269         }
4270     case ']':
4271         s++;
4272         if (PL_lex_brackets <= 0)
4273             yyerror("Unmatched right square bracket");
4274         else
4275             --PL_lex_brackets;
4276         if (PL_lex_state == LEX_INTERPNORMAL) {
4277             if (PL_lex_brackets == 0) {
4278                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
4279                     PL_lex_state = LEX_INTERPEND;
4280             }
4281         }
4282         TERM(']');
4283     case '{':
4284       leftbracket:
4285         s++;
4286         if (PL_lex_brackets > 100) {
4287             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4288         }
4289         switch (PL_expect) {
4290         case XTERM:
4291             if (PL_lex_formbrack) {
4292                 s--;
4293                 PRETERMBLOCK(DO);
4294             }
4295             if (PL_oldoldbufptr == PL_last_lop)
4296                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4297             else
4298                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4299             OPERATOR(HASHBRACK);
4300         case XOPERATOR:
4301             while (s < PL_bufend && SPACE_OR_TAB(*s))
4302                 s++;
4303             d = s;
4304             PL_tokenbuf[0] = '\0';
4305             if (d < PL_bufend && *d == '-') {
4306                 PL_tokenbuf[0] = '-';
4307                 d++;
4308                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4309                     d++;
4310             }
4311             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4312                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4313                               FALSE, &len);
4314                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4315                     d++;
4316                 if (*d == '}') {
4317                     const char minus = (PL_tokenbuf[0] == '-');
4318                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4319                     if (minus)
4320                         force_next('-');
4321                 }
4322             }
4323             /* FALL THROUGH */
4324         case XATTRBLOCK:
4325         case XBLOCK:
4326             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4327             PL_expect = XSTATE;
4328             break;
4329         case XATTRTERM:
4330         case XTERMBLOCK:
4331             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4332             PL_expect = XSTATE;
4333             break;
4334         default: {
4335                 const char *t;
4336                 if (PL_oldoldbufptr == PL_last_lop)
4337                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4338                 else
4339                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4340                 s = SKIPSPACE1(s);
4341                 if (*s == '}') {
4342                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4343                         PL_expect = XTERM;
4344                         /* This hack is to get the ${} in the message. */
4345                         PL_bufptr = s+1;
4346                         yyerror("syntax error");
4347                         break;
4348                     }
4349                     OPERATOR(HASHBRACK);
4350                 }
4351                 /* This hack serves to disambiguate a pair of curlies
4352                  * as being a block or an anon hash.  Normally, expectation
4353                  * determines that, but in cases where we're not in a
4354                  * position to expect anything in particular (like inside
4355                  * eval"") we have to resolve the ambiguity.  This code
4356                  * covers the case where the first term in the curlies is a
4357                  * quoted string.  Most other cases need to be explicitly
4358                  * disambiguated by prepending a "+" before the opening
4359                  * curly in order to force resolution as an anon hash.
4360                  *
4361                  * XXX should probably propagate the outer expectation
4362                  * into eval"" to rely less on this hack, but that could
4363                  * potentially break current behavior of eval"".
4364                  * GSAR 97-07-21
4365                  */
4366                 t = s;
4367                 if (*s == '\'' || *s == '"' || *s == '`') {
4368                     /* common case: get past first string, handling escapes */
4369                     for (t++; t < PL_bufend && *t != *s;)
4370                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
4371                             t++;
4372                     t++;
4373                 }
4374                 else if (*s == 'q') {
4375                     if (++t < PL_bufend
4376                         && (!isALNUM(*t)
4377                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4378                                 && !isALNUM(*t))))
4379                     {
4380                         /* skip q//-like construct */
4381                         const char *tmps;
4382                         char open, close, term;
4383                         I32 brackets = 1;
4384
4385                         while (t < PL_bufend && isSPACE(*t))
4386                             t++;
4387                         /* check for q => */
4388                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4389                             OPERATOR(HASHBRACK);
4390                         }
4391                         term = *t;
4392                         open = term;
4393                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4394                             term = tmps[5];
4395                         close = term;
4396                         if (open == close)
4397                             for (t++; t < PL_bufend; t++) {
4398                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4399                                     t++;
4400                                 else if (*t == open)
4401                                     break;
4402                             }
4403                         else {
4404                             for (t++; t < PL_bufend; t++) {
4405                                 if (*t == '\\' && t+1 < PL_bufend)
4406                                     t++;
4407                                 else if (*t == close && --brackets <= 0)
4408                                     break;
4409                                 else if (*t == open)
4410                                     brackets++;
4411                             }
4412                         }
4413                         t++;
4414                     }
4415                     else
4416                         /* skip plain q word */
4417                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4418                              t += UTF8SKIP(t);
4419                 }
4420                 else if (isALNUM_lazy_if(t,UTF)) {
4421                     t += UTF8SKIP(t);
4422                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4423                          t += UTF8SKIP(t);
4424                 }
4425                 while (t < PL_bufend && isSPACE(*t))
4426                     t++;
4427                 /* if comma follows first term, call it an anon hash */
4428                 /* XXX it could be a comma expression with loop modifiers */
4429                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4430                                    || (*t == '=' && t[1] == '>')))
4431                     OPERATOR(HASHBRACK);
4432                 if (PL_expect == XREF)
4433                     PL_expect = XTERM;
4434                 else {
4435                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4436                     PL_expect = XSTATE;
4437                 }
4438             }
4439             break;
4440         }
4441         yylval.ival = CopLINE(PL_curcop);
4442         if (isSPACE(*s) || *s == '#')
4443             PL_copline = NOLINE;   /* invalidate current command line number */
4444         TOKEN('{');
4445     case '}':
4446       rightbracket:
4447         s++;
4448         if (PL_lex_brackets <= 0)
4449             yyerror("Unmatched right curly bracket");
4450         else
4451             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4452         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4453             PL_lex_formbrack = 0;
4454         if (PL_lex_state == LEX_INTERPNORMAL) {
4455             if (PL_lex_brackets == 0) {
4456                 if (PL_expect & XFAKEBRACK) {
4457                     PL_expect &= XENUMMASK;
4458                     PL_lex_state = LEX_INTERPEND;
4459                     PL_bufptr = s;
4460 #if 0
4461                     if (PL_madskills) {
4462                         if (!PL_thiswhite)
4463                             PL_thiswhite = newSVpvn("",0);
4464                         sv_catpvn(PL_thiswhite,"}",1);
4465                     }
4466 #endif
4467                     return yylex();     /* ignore fake brackets */
4468                 }
4469                 if (*s == '-' && s[1] == '>')
4470                     PL_lex_state = LEX_INTERPENDMAYBE;
4471                 else if (*s != '[' && *s != '{')
4472                     PL_lex_state = LEX_INTERPEND;
4473             }
4474         }
4475         if (PL_expect & XFAKEBRACK) {
4476             PL_expect &= XENUMMASK;
4477             PL_bufptr = s;
4478             return yylex();             /* ignore fake brackets */
4479         }
4480         start_force(PL_curforce);
4481         if (PL_madskills) {
4482             curmad('X', newSVpvn(s-1,1));
4483             CURMAD('_', PL_thiswhite);
4484         }
4485         force_next('}');
4486 #ifdef PERL_MAD
4487         if (!PL_thistoken)
4488             PL_thistoken = newSVpvn("",0);
4489 #endif
4490         TOKEN(';');
4491     case '&':
4492         s++;
4493         if (*s++ == '&')
4494             AOPERATOR(ANDAND);
4495         s--;
4496         if (PL_expect == XOPERATOR) {
4497             if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4498                 && isIDFIRST_lazy_if(s,UTF))
4499             {
4500                 CopLINE_dec(PL_curcop);
4501                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4502                 CopLINE_inc(PL_curcop);
4503             }
4504             BAop(OP_BIT_AND);
4505         }
4506
4507         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4508         if (*PL_tokenbuf) {
4509             PL_expect = XOPERATOR;
4510             force_ident(PL_tokenbuf, '&');
4511         }
4512         else
4513             PREREF('&');
4514         yylval.ival = (OPpENTERSUB_AMPER<<8);
4515         TERM('&');
4516
4517     case '|':
4518         s++;
4519         if (*s++ == '|')
4520             AOPERATOR(OROR);
4521         s--;
4522         BOop(OP_BIT_OR);
4523     case '=':
4524         s++;
4525         {
4526             const char tmp = *s++;
4527             if (tmp == '=')
4528                 Eop(OP_EQ);
4529             if (tmp == '>')
4530                 OPERATOR(',');
4531             if (tmp == '~')
4532                 PMop(OP_MATCH);
4533             if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4534                 && strchr("+-*/%.^&|<",tmp))
4535                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4536                             "Reversed %c= operator",(int)tmp);
4537             s--;
4538             if (PL_expect == XSTATE && isALPHA(tmp) &&
4539                 (s == PL_linestart+1 || s[-2] == '\n') )
4540                 {
4541                     if (PL_in_eval && !PL_rsfp) {
4542                         d = PL_bufend;
4543                         while (s < d) {
4544                             if (*s++ == '\n') {
4545                                 incline(s);
4546                                 if (strnEQ(s,"=cut",4)) {
4547                                     s = strchr(s,'\n');
4548                                     if (s)
4549                                         s++;
4550                                     else
4551                                         s = d;
4552                                     incline(s);
4553                                     goto retry;
4554                                 }
4555                             }
4556                         }
4557                         goto retry;
4558                     }
4559 #ifdef PERL_MAD
4560                     if (PL_madskills) {
4561                         if (!PL_thiswhite)
4562                             PL_thiswhite = newSVpvn("",0);
4563                         sv_catpvn(PL_thiswhite, PL_linestart,
4564                                   PL_bufend - PL_linestart);
4565                     }
4566 #endif
4567                     s = PL_bufend;
4568                     PL_doextract = TRUE;
4569                     goto retry;
4570                 }
4571         }
4572         if (PL_lex_brackets < PL_lex_formbrack) {
4573             const char *t = s;
4574 #ifdef PERL_STRICT_CR
4575             while (SPACE_OR_TAB(*t))
4576 #else
4577             while (SPACE_OR_TAB(*t) || *t == '\r')
4578 #endif
4579                 t++;
4580             if (*t == '\n' || *t == '#') {
4581                 s--;
4582                 PL_expect = XBLOCK;
4583                 goto leftbracket;
4584             }
4585         }
4586         yylval.ival = 0;
4587         OPERATOR(ASSIGNOP);
4588     case '!':
4589         s++;
4590         {
4591             const char tmp = *s++;
4592             if (tmp == '=') {
4593                 /* was this !=~ where !~ was meant?
4594                  * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4595
4596                 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4597                     const char *t = s+1;
4598
4599                     while (t < PL_bufend && isSPACE(*t))
4600                         ++t;
4601
4602                     if (*t == '/' || *t == '?' ||
4603                         ((*t == 'm' || *t == 's' || *t == 'y')
4604                          && !isALNUM(t[1])) ||
4605                         (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4606                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4607                                     "!=~ should be !~");
4608                 }
4609                 Eop(OP_NE);
4610             }
4611             if (tmp == '~')
4612                 PMop(OP_NOT);
4613         }
4614         s--;
4615         OPERATOR('!');
4616     case '<':
4617         if (PL_expect != XOPERATOR) {
4618             if (s[1] != '<' && !strchr(s,'>'))
4619                 check_uni();
4620             if (s[1] == '<')
4621                 s = scan_heredoc(s);
4622             else
4623                 s = scan_inputsymbol(s);
4624             TERM(sublex_start());
4625         }
4626         s++;
4627         {
4628             char tmp = *s++;
4629             if (tmp == '<')
4630                 SHop(OP_LEFT_SHIFT);
4631             if (tmp == '=') {
4632                 tmp = *s++;
4633                 if (tmp == '>')
4634                     Eop(OP_NCMP);
4635                 s--;
4636                 Rop(OP_LE);
4637             }
4638         }
4639         s--;
4640         Rop(OP_LT);
4641     case '>':
4642         s++;
4643         {
4644             const char tmp = *s++;
4645             if (tmp == '>')
4646                 SHop(OP_RIGHT_SHIFT);
4647             else if (tmp == '=')
4648                 Rop(OP_GE);
4649         }
4650         s--;
4651         Rop(OP_GT);
4652
4653     case '$':
4654         CLINE;
4655
4656         if (PL_expect == XOPERATOR) {
4657             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4658                 PL_expect = XTERM;
4659                 deprecate_old(commaless_variable_list);
4660                 return REPORT(','); /* grandfather non-comma-format format */
4661             }
4662         }
4663
4664         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4665             PL_tokenbuf[0] = '@';
4666             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4667                            sizeof PL_tokenbuf - 1, FALSE);
4668             if (PL_expect == XOPERATOR)
4669                 no_op("Array length", s);
4670             if (!PL_tokenbuf[1])
4671                 PREREF(DOLSHARP);
4672             PL_expect = XOPERATOR;
4673             PL_pending_ident = '#';
4674             TOKEN(DOLSHARP);
4675         }
4676
4677         PL_tokenbuf[0] = '$';
4678         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4679                        sizeof PL_tokenbuf - 1, FALSE);
4680         if (PL_expect == XOPERATOR)
4681             no_op("Scalar", s);
4682         if (!PL_tokenbuf[1]) {
4683             if (s == PL_bufend)
4684                 yyerror("Final $ should be \\$ or $name");
4685             PREREF('$');
4686         }
4687
4688         /* This kludge not intended to be bulletproof. */
4689         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4690             yylval.opval = newSVOP(OP_CONST, 0,
4691                                    newSViv(CopARYBASE_get(&PL_compiling)));
4692             yylval.opval->op_private = OPpCONST_ARYBASE;
4693             TERM(THING);
4694         }
4695
4696         d = s;
4697         {
4698             const char tmp = *s;
4699             if (PL_lex_state == LEX_NORMAL)
4700                 s = SKIPSPACE1(s);
4701
4702             if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4703                 && intuit_more(s)) {
4704                 if (*s == '[') {
4705                     PL_tokenbuf[0] = '@';
4706                     if (ckWARN(WARN_SYNTAX)) {
4707                         char *t = s+1;
4708
4709                         while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4710                             t++;
4711                         if (*t++ == ',') {
4712                             PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4713                             while (t < PL_bufend && *t != ']')
4714                                 t++;
4715                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4716                                         "Multidimensional syntax %.*s not supported",
4717                                     (int)((t - PL_bufptr) + 1), PL_bufptr);
4718                         }
4719                     }
4720                 }
4721                 else if (*s == '{') {
4722                     char *t;
4723                     PL_tokenbuf[0] = '%';
4724                     if (strEQ(PL_tokenbuf+1, "SIG")  && ckWARN(WARN_SYNTAX)
4725                         && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4726                         {
4727                             char tmpbuf[sizeof PL_tokenbuf];
4728                             do {
4729                                 t++;
4730                             } while (isSPACE(*t));
4731                             if (isIDFIRST_lazy_if(t,UTF)) {
4732                                 STRLEN dummylen;
4733                                 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4734                                               &dummylen);
4735                                 while (isSPACE(*t))
4736                                     t++;
4737                                 if (*t == ';' && get_cv(tmpbuf, FALSE))
4738                                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4739                                                 "You need to quote \"%s\"",
4740                                                 tmpbuf);
4741                             }
4742                         }
4743                 }
4744             }
4745
4746             PL_expect = XOPERATOR;
4747             if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4748                 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4749                 if (!islop || PL_last_lop_op == OP_GREPSTART)
4750                     PL_expect = XOPERATOR;
4751                 else if (strchr("$@\"'`q", *s))
4752                     PL_expect = XTERM;          /* e.g. print $fh "foo" */
4753                 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4754                     PL_expect = XTERM;          /* e.g. print $fh &sub */
4755                 else if (isIDFIRST_lazy_if(s,UTF)) {
4756                     char tmpbuf[sizeof PL_tokenbuf];
4757                     int t2;
4758                     scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4759                     if ((t2 = keyword(tmpbuf, len))) {
4760                         /* binary operators exclude handle interpretations */
4761                         switch (t2) {
4762                         case -KEY_x:
4763                         case -KEY_eq:
4764                         case -KEY_ne:
4765                         case -KEY_gt:
4766                         case -KEY_lt:
4767                         case -KEY_ge:
4768                         case -KEY_le:
4769                         case -KEY_cmp:
4770                             break;
4771                         default:
4772                             PL_expect = XTERM;  /* e.g. print $fh length() */
4773                             break;
4774                         }
4775                     }
4776                     else {
4777                         PL_expect = XTERM;      /* e.g. print $fh subr() */
4778                     }
4779                 }
4780                 else if (isDIGIT(*s))
4781                     PL_expect = XTERM;          /* e.g. print $fh 3 */
4782                 else if (*s == '.' && isDIGIT(s[1]))
4783                     PL_expect = XTERM;          /* e.g. print $fh .3 */
4784                 else if ((*s == '?' || *s == '-' || *s == '+')
4785                          && !isSPACE(s[1]) && s[1] != '=')
4786                     PL_expect = XTERM;          /* e.g. print $fh -1 */
4787                 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
4788                          && s[1] != '/')
4789                     PL_expect = XTERM;          /* e.g. print $fh /.../
4790                                                    XXX except DORDOR operator
4791                                                 */
4792                 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
4793                          && s[2] != '=')
4794                     PL_expect = XTERM;          /* print $fh <<"EOF" */
4795             }
4796         }
4797         PL_pending_ident = '$';
4798         TOKEN('$');
4799
4800     case '@':
4801         if (PL_expect == XOPERATOR)
4802             no_op("Array", s);
4803         PL_tokenbuf[0] = '@';
4804         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
4805         if (!PL_tokenbuf[1]) {
4806             PREREF('@');
4807         }
4808         if (PL_lex_state == LEX_NORMAL)
4809             s = SKIPSPACE1(s);
4810         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
4811             if (*s == '{')
4812                 PL_tokenbuf[0] = '%';
4813
4814             /* Warn about @ where they meant $. */
4815             if (*s == '[' || *s == '{') {
4816                 if (ckWARN(WARN_SYNTAX)) {
4817                     const char *t = s + 1;
4818                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
4819                         t++;
4820                     if (*t == '}' || *t == ']') {
4821                         t++;
4822                         PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4823                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4824                             "Scalar value %.*s better written as $%.*s",
4825                             (int)(t-PL_bufptr), PL_bufptr,
4826                             (int)(t-PL_bufptr-1), PL_bufptr+1);
4827                     }
4828                 }
4829             }
4830         }
4831         PL_pending_ident = '@';
4832         TERM('@');
4833
4834      case '/':                  /* may be division, defined-or, or pattern */
4835         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
4836             s += 2;
4837             AOPERATOR(DORDOR);
4838         }
4839      case '?':                  /* may either be conditional or pattern */
4840          if(PL_expect == XOPERATOR) {
4841              char tmp = *s++;
4842              if(tmp == '?') {
4843                   OPERATOR('?');
4844              }
4845              else {
4846                  tmp = *s++;
4847                  if(tmp == '/') {
4848                      /* A // operator. */
4849                     AOPERATOR(DORDOR);
4850                  }
4851                  else {
4852                      s--;
4853                      Mop(OP_DIVIDE);
4854                  }
4855              }
4856          }
4857          else {
4858              /* Disable warning on "study /blah/" */
4859              if (PL_oldoldbufptr == PL_last_uni
4860               && (*PL_last_uni != 's' || s - PL_last_uni < 5
4861                   || memNE(PL_last_uni, "study", 5)
4862                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
4863               ))
4864                  check_uni();
4865              s = scan_pat(s,OP_MATCH);
4866              TERM(sublex_start());
4867          }
4868
4869     case '.':
4870         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
4871 #ifdef PERL_STRICT_CR
4872             && s[1] == '\n'
4873 #else
4874             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
4875 #endif
4876             && (s == PL_linestart || s[-1] == '\n') )
4877         {
4878             PL_lex_formbrack = 0;
4879             PL_expect = XSTATE;
4880             goto rightbracket;
4881         }
4882         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
4883             char tmp = *s++;
4884             if (*s == tmp) {
4885                 s++;
4886                 if (*s == tmp) {
4887                     s++;
4888                     yylval.ival = OPf_SPECIAL;
4889                 }
4890                 else
4891                     yylval.ival = 0;
4892                 OPERATOR(DOTDOT);
4893             }
4894             if (PL_expect != XOPERATOR)
4895                 check_uni();
4896             Aop(OP_CONCAT);
4897         }
4898         /* FALL THROUGH */
4899     case '0': case '1': case '2': case '3': case '4':
4900     case '5': case '6': case '7': case '8': case '9':
4901         s = scan_num(s, &yylval);
4902         DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
4903         if (PL_expect == XOPERATOR)
4904             no_op("Number",s);
4905         TERM(THING);
4906
4907     case '\'':
4908         s = scan_str(s,!!PL_madskills,FALSE);
4909         DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
4910         if (PL_expect == XOPERATOR) {
4911             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4912                 PL_expect = XTERM;
4913                 deprecate_old(commaless_variable_list);
4914                 return REPORT(','); /* grandfather non-comma-format format */
4915             }
4916             else
4917                 no_op("String",s);
4918         }
4919         if (!s)
4920             missingterm(NULL);
4921         yylval.ival = OP_CONST;
4922         TERM(sublex_start());
4923
4924     case '"':
4925         s = scan_str(s,!!PL_madskills,FALSE);
4926         DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
4927         if (PL_expect == XOPERATOR) {
4928             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4929                 PL_expect = XTERM;
4930                 deprecate_old(commaless_variable_list);
4931                 return REPORT(','); /* grandfather non-comma-format format */
4932             }
4933             else
4934                 no_op("String",s);
4935         }
4936         if (!s)
4937             missingterm(NULL);
4938         yylval.ival = OP_CONST;
4939         /* FIXME. I think that this can be const if char *d is replaced by
4940            more localised variables.  */
4941         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
4942             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
4943                 yylval.ival = OP_STRINGIFY;
4944                 break;
4945             }
4946         }
4947         TERM(sublex_start());
4948
4949     case '`':
4950         s = scan_str(s,!!PL_madskills,FALSE);
4951         DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
4952         if (PL_expect == XOPERATOR)
4953             no_op("Backticks",s);
4954         if (!s)
4955             missingterm(NULL);
4956         yylval.ival = OP_BACKTICK;
4957         set_csh();
4958         TERM(sublex_start());
4959
4960     case '\\':
4961         s++;
4962         if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
4963             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
4964                         *s, *s);
4965         if (PL_expect == XOPERATOR)
4966             no_op("Backslash",s);
4967         OPERATOR(REFGEN);
4968
4969     case 'v':
4970         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
4971             char *start = s + 2;
4972             while (isDIGIT(*start) || *start == '_')
4973                 start++;
4974             if (*start == '.' && isDIGIT(start[1])) {
4975                 s = scan_num(s, &yylval);
4976                 TERM(THING);
4977             }
4978             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
4979             else if (!isALPHA(*start) && (PL_expect == XTERM
4980                         || PL_expect == XREF || PL_expect == XSTATE
4981                         || PL_expect == XTERMORDORDOR)) {
4982                 /* XXX Use gv_fetchpvn rather than stomping on a const string */
4983                 const char c = *start;
4984                 GV *gv;
4985                 *start = '\0';
4986                 gv = gv_fetchpv(s, 0, SVt_PVCV);
4987                 *start = c;
4988                 if (!gv) {
4989                     s = scan_num(s, &yylval);
4990                     TERM(THING);
4991                 }
4992             }
4993         }
4994         goto keylookup;
4995     case 'x':
4996         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
4997             s++;
4998             Mop(OP_REPEAT);
4999         }
5000         goto keylookup;
5001
5002     case '_':
5003     case 'a': case 'A':
5004     case 'b': case 'B':
5005     case 'c': case 'C':
5006     case 'd': case 'D':
5007     case 'e': case 'E':
5008     case 'f': case 'F':
5009     case 'g': case 'G':
5010     case 'h': case 'H':
5011     case 'i': case 'I':
5012     case 'j': case 'J':
5013     case 'k': case 'K':
5014     case 'l': case 'L':
5015     case 'm': case 'M':
5016     case 'n': case 'N':
5017     case 'o': case 'O':
5018     case 'p': case 'P':
5019     case 'q': case 'Q':
5020     case 'r': case 'R':
5021     case 's': case 'S':
5022     case 't': case 'T':
5023     case 'u': case 'U':
5024               case 'V':
5025     case 'w': case 'W':
5026               case 'X':
5027     case 'y': case 'Y':
5028     case 'z': case 'Z':
5029
5030       keylookup: {
5031         I32 tmp;
5032
5033         orig_keyword = 0;
5034         gv = NULL;
5035         gvp = NULL;
5036
5037         PL_bufptr = s;
5038         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5039
5040         /* Some keywords can be followed by any delimiter, including ':' */
5041         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
5042                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
5043                              (PL_tokenbuf[0] == 'q' &&
5044                               strchr("qwxr", PL_tokenbuf[1])))));
5045
5046         /* x::* is just a word, unless x is "CORE" */
5047         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
5048             goto just_a_word;
5049
5050         d = s;
5051         while (d < PL_bufend && isSPACE(*d))
5052                 d++;    /* no comments skipped here, or s### is misparsed */
5053
5054         /* Is this a label? */
5055         if (!tmp && PL_expect == XSTATE
5056               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
5057             s = d + 1;
5058             yylval.pval = savepv(PL_tokenbuf);
5059             CLINE;
5060             TOKEN(LABEL);
5061         }
5062
5063         /* Check for keywords */
5064         tmp = keyword(PL_tokenbuf, len);
5065
5066         /* Is this a word before a => operator? */
5067         if (*d == '=' && d[1] == '>') {
5068             CLINE;
5069             yylval.opval
5070                 = (OP*)newSVOP(OP_CONST, 0,
5071                                S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
5072             yylval.opval->op_private = OPpCONST_BARE;
5073             TERM(WORD);
5074         }
5075
5076         if (tmp < 0) {                  /* second-class keyword? */
5077             GV *ogv = NULL;     /* override (winner) */
5078             GV *hgv = NULL;     /* hidden (loser) */
5079             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5080                 CV *cv;
5081                 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
5082                     (cv = GvCVu(gv)))
5083                 {
5084                     if (GvIMPORTED_CV(gv))
5085                         ogv = gv;
5086                     else if (! CvMETHOD(cv))
5087                         hgv = gv;
5088                 }
5089                 if (!ogv &&
5090                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
5091                     (gv = *gvp) != (GV*)&PL_sv_undef &&
5092                     GvCVu(gv) && GvIMPORTED_CV(gv))
5093                 {
5094                     ogv = gv;
5095                 }
5096             }
5097             if (ogv) {
5098                 orig_keyword = tmp;
5099                 tmp = 0;                /* overridden by import or by GLOBAL */
5100             }
5101             else if (gv && !gvp
5102                      && -tmp==KEY_lock  /* XXX generalizable kludge */
5103                      && GvCVu(gv)
5104                      && !hv_fetchs(GvHVn(PL_incgv), "Thread.pm", FALSE))
5105             {
5106                 tmp = 0;                /* any sub overrides "weak" keyword */
5107             }
5108             else {                      /* no override */
5109                 tmp = -tmp;
5110                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
5111                     Perl_warner(aTHX_ packWARN(WARN_MISC),
5112                             "dump() better written as CORE::dump()");
5113                 }
5114                 gv = NULL;
5115                 gvp = 0;
5116                 if (hgv && tmp != KEY_x && tmp != KEY_CORE
5117                         && ckWARN(WARN_AMBIGUOUS))      /* never ambiguous */
5118                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5119                         "Ambiguous call resolved as CORE::%s(), %s",
5120                          GvENAME(hgv), "qualify as such or use &");
5121             }
5122         }
5123
5124       reserved_word:
5125         switch (tmp) {
5126
5127         default:                        /* not a keyword */
5128             /* Trade off - by using this evil construction we can pull the
5129                variable gv into the block labelled keylookup. If not, then
5130                we have to give it function scope so that the goto from the
5131                earlier ':' case doesn't bypass the initialisation.  */
5132             if (0) {
5133             just_a_word_zero_gv:
5134                 gv = NULL;
5135                 gvp = NULL;
5136                 orig_keyword = 0;
5137             }
5138           just_a_word: {
5139                 SV *sv;
5140                 int pkgname = 0;
5141                 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5142                 CV *cv;
5143 #ifdef PERL_MAD
5144                 SV *nextPL_nextwhite = 0;
5145 #endif
5146
5147
5148                 /* Get the rest if it looks like a package qualifier */
5149
5150                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5151                     STRLEN morelen;
5152                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5153                                   TRUE, &morelen);
5154                     if (!morelen)
5155                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5156                                 *s == '\'' ? "'" : "::");
5157                     len += morelen;
5158                     pkgname = 1;
5159                 }
5160
5161                 if (PL_expect == XOPERATOR) {
5162                     if (PL_bufptr == PL_linestart) {
5163                         CopLINE_dec(PL_curcop);
5164                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
5165                         CopLINE_inc(PL_curcop);
5166                     }
5167                     else
5168                         no_op("Bareword",s);
5169                 }
5170
5171                 /* Look for a subroutine with this name in current package,
5172                    unless name is "Foo::", in which case Foo is a bearword
5173                    (and a package name). */
5174
5175                 if (len > 2 && !PL_madskills &&
5176                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5177                 {
5178                     if (ckWARN(WARN_BAREWORD)
5179                         && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5180                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5181                             "Bareword \"%s\" refers to nonexistent package",
5182                              PL_tokenbuf);
5183                     len -= 2;
5184                     PL_tokenbuf[len] = '\0';
5185                     gv = NULL;
5186                     gvp = 0;
5187                 }
5188                 else {
5189                     if (!gv) {
5190                         /* Mustn't actually add anything to a symbol table.
5191                            But also don't want to "initialise" any placeholder
5192                            constants that might already be there into full
5193                            blown PVGVs with attached PVCV.  */
5194                         gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5195                                                GV_NOADD_NOINIT, SVt_PVCV);
5196                     }
5197                     len = 0;
5198                 }
5199
5200                 /* if we saw a global override before, get the right name */
5201
5202                 if (gvp) {
5203                     sv = newSVpvs("CORE::GLOBAL::");
5204                     sv_catpv(sv,PL_tokenbuf);
5205                 }
5206                 else {
5207                     /* If len is 0, newSVpv does strlen(), which is correct.
5208                        If len is non-zero, then it will be the true length,
5209                        and so the scalar will be created correctly.  */
5210                     sv = newSVpv(PL_tokenbuf,len);
5211                 }
5212 #ifdef PERL_MAD
5213                 if (PL_madskills && !PL_thistoken) {
5214                     char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5215                     PL_thistoken = newSVpv(start,s - start);
5216                     PL_realtokenstart = s - SvPVX(PL_linestr);
5217                 }
5218 #endif
5219
5220                 /* Presume this is going to be a bareword of some sort. */
5221
5222                 CLINE;
5223                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5224                 yylval.opval->op_private = OPpCONST_BARE;
5225                 /* UTF-8 package name? */
5226                 if (UTF && !IN_BYTES &&
5227                     is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5228                     SvUTF8_on(sv);
5229
5230                 /* And if "Foo::", then that's what it certainly is. */
5231
5232                 if (len)
5233                     goto safe_bareword;
5234
5235                 /* Do the explicit type check so that we don't need to force
5236                    the initialisation of the symbol table to have a real GV.
5237                    Beware - gv may not really be a PVGV, cv may not really be
5238                    a PVCV, (because of the space optimisations that gv_init
5239                    understands) But they're true if for this symbol there is
5240                    respectively a typeglob and a subroutine.
5241                 */
5242                 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5243                     /* Real typeglob, so get the real subroutine: */
5244                            ? GvCVu(gv)
5245                     /* A proxy for a subroutine in this package? */
5246                            : SvOK(gv) ? (CV *) gv : NULL)
5247                     : NULL;
5248
5249                 /* See if it's the indirect object for a list operator. */
5250
5251                 if (PL_oldoldbufptr &&
5252                     PL_oldoldbufptr < PL_bufptr &&
5253                     (PL_oldoldbufptr == PL_last_lop
5254                      || PL_oldoldbufptr == PL_last_uni) &&
5255                     /* NO SKIPSPACE BEFORE HERE! */
5256                     (PL_expect == XREF ||
5257                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5258                 {
5259                     bool immediate_paren = *s == '(';
5260
5261                     /* (Now we can afford to cross potential line boundary.) */
5262                     s = SKIPSPACE2(s,nextPL_nextwhite);
5263 #ifdef PERL_MAD
5264                     PL_nextwhite = nextPL_nextwhite;    /* assume no & deception */
5265 #endif
5266
5267                     /* Two barewords in a row may indicate method call. */
5268
5269                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5270                         (tmp = intuit_method(s, gv, cv)))
5271                         return REPORT(tmp);
5272
5273                     /* If not a declared subroutine, it's an indirect object. */
5274                     /* (But it's an indir obj regardless for sort.) */
5275                     /* Also, if "_" follows a filetest operator, it's a bareword */
5276
5277                     if (
5278                         ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5279                          ((!gv || !cv) &&
5280                         (PL_last_lop_op != OP_MAPSTART &&
5281                          PL_last_lop_op != OP_GREPSTART))))
5282                        || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5283                             && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5284                        )
5285                     {
5286                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5287                         goto bareword;
5288                     }
5289                 }
5290
5291                 PL_expect = XOPERATOR;
5292 #ifdef PERL_MAD
5293                 if (isSPACE(*s))
5294                     s = SKIPSPACE2(s,nextPL_nextwhite);
5295                 PL_nextwhite = nextPL_nextwhite;
5296 #else
5297                 s = skipspace(s);
5298 #endif
5299
5300                 /* Is this a word before a => operator? */
5301                 if (*s == '=' && s[1] == '>' && !pkgname) {
5302                     CLINE;
5303                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
5304                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5305                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
5306                     TERM(WORD);
5307                 }
5308
5309                 /* If followed by a paren, it's certainly a subroutine. */
5310                 if (*s == '(') {
5311                     CLINE;
5312                     if (cv) {
5313                         d = s + 1;
5314                         while (SPACE_OR_TAB(*d))
5315                             d++;
5316                         if (*d == ')' && (sv = gv_const_sv(gv))) {
5317                             s = d + 1;
5318 #ifdef PERL_MAD
5319                             if (PL_madskills) {
5320                                 char *par = SvPVX(PL_linestr) + PL_realtokenstart;
5321                                 sv_catpvn(PL_thistoken, par, s - par);
5322                                 if (PL_nextwhite) {
5323                                     sv_free(PL_nextwhite);
5324                                     PL_nextwhite = 0;
5325                                 }
5326                             }
5327 #endif
5328                             goto its_constant;
5329                         }
5330                     }
5331 #ifdef PERL_MAD
5332                     if (PL_madskills) {
5333                         PL_nextwhite = PL_thiswhite;
5334                         PL_thiswhite = 0;
5335                     }
5336                     start_force(PL_curforce);
5337 #endif
5338                     NEXTVAL_NEXTTOKE.opval = yylval.opval;
5339                     PL_expect = XOPERATOR;
5340 #ifdef PERL_MAD
5341                     if (PL_madskills) {
5342                         PL_nextwhite = nextPL_nextwhite;
5343                         curmad('X', PL_thistoken);
5344                         PL_thistoken = newSVpvn("",0);
5345                     }
5346 #endif
5347                     force_next(WORD);
5348                     yylval.ival = 0;
5349                     TOKEN('&');
5350                 }
5351
5352                 /* If followed by var or block, call it a method (unless sub) */
5353
5354                 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5355                     PL_last_lop = PL_oldbufptr;
5356                     PL_last_lop_op = OP_METHOD;
5357                     PREBLOCK(METHOD);
5358                 }
5359
5360                 /* If followed by a bareword, see if it looks like indir obj. */
5361
5362                 if (!orig_keyword
5363                         && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5364                         && (tmp = intuit_method(s, gv, cv)))
5365                     return REPORT(tmp);
5366
5367                 /* Not a method, so call it a subroutine (if defined) */
5368
5369                 if (cv) {
5370                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
5371                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5372                                 "Ambiguous use of -%s resolved as -&%s()",
5373                                 PL_tokenbuf, PL_tokenbuf);
5374                     /* Check for a constant sub */
5375                     if ((sv = gv_const_sv(gv))) {
5376                   its_constant:
5377                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
5378                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5379                         yylval.opval->op_private = 0;
5380                         TOKEN(WORD);
5381                     }
5382
5383                     /* Resolve to GV now. */
5384                     if (SvTYPE(gv) != SVt_PVGV) {
5385                         gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5386                         assert (SvTYPE(gv) == SVt_PVGV);
5387                         /* cv must have been some sort of placeholder, so
5388                            now needs replacing with a real code reference.  */
5389                         cv = GvCV(gv);
5390                     }
5391
5392                     op_free(yylval.opval);
5393                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5394                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5395                     PL_last_lop = PL_oldbufptr;
5396                     PL_last_lop_op = OP_ENTERSUB;
5397                     /* Is there a prototype? */
5398                     if (
5399 #ifdef PERL_MAD
5400                         cv &&
5401 #endif
5402                         SvPOK(cv)) {
5403                         STRLEN protolen;
5404                         const char *proto = SvPV_const((SV*)cv, protolen);
5405                         if (!protolen)
5406                             TERM(FUNC0SUB);
5407                         if (*proto == '$' && proto[1] == '\0')
5408                             OPERATOR(UNIOPSUB);
5409                         while (*proto == ';')
5410                             proto++;
5411                         if (*proto == '&' && *s == '{') {
5412                             sv_setpv(PL_subname,
5413                                      (const char *)
5414                                      (PL_curstash ?
5415                                       "__ANON__" : "__ANON__::__ANON__"));
5416                             PREBLOCK(LSTOPSUB);
5417                         }
5418                     }
5419 #ifdef PERL_MAD
5420                     {
5421                         if (PL_madskills) {
5422                             PL_nextwhite = PL_thiswhite;
5423                             PL_thiswhite = 0;
5424                         }
5425                         start_force(PL_curforce);
5426                         NEXTVAL_NEXTTOKE.opval = yylval.opval;
5427                         PL_expect = XTERM;
5428                         if (PL_madskills) {
5429                             PL_nextwhite = nextPL_nextwhite;
5430                             curmad('X', PL_thistoken);
5431                             PL_thistoken = newSVpvn("",0);
5432                         }
5433                         force_next(WORD);
5434                         TOKEN(NOAMP);
5435                     }
5436                 }
5437
5438                 /* Guess harder when madskills require "best effort". */
5439                 if (PL_madskills && (!gv || !GvCVu(gv))) {
5440                     int probable_sub = 0;
5441                     if (strchr("\"'`$@%0123456789!*+{[<", *s))
5442                         probable_sub = 1;
5443                     else if (isALPHA(*s)) {
5444                         char tmpbuf[1024];
5445                         STRLEN tmplen;
5446                         d = s;
5447                         d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5448                         if (!keyword(tmpbuf,tmplen))
5449                             probable_sub = 1;
5450                         else {
5451                             while (d < PL_bufend && isSPACE(*d))
5452                                 d++;
5453                             if (*d == '=' && d[1] == '>')
5454                                 probable_sub = 1;
5455                         }
5456                     }
5457                     if (probable_sub) {
5458                         gv = gv_fetchpv(PL_tokenbuf, TRUE, SVt_PVCV);
5459                         op_free(yylval.opval);
5460                         yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5461                         yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5462                         PL_last_lop = PL_oldbufptr;
5463                         PL_last_lop_op = OP_ENTERSUB;
5464                         PL_nextwhite = PL_thiswhite;
5465                         PL_thiswhite = 0;
5466                         start_force(PL_curforce);
5467                         NEXTVAL_NEXTTOKE.opval = yylval.opval;
5468                         PL_expect = XTERM;
5469                         PL_nextwhite = nextPL_nextwhite;
5470                         curmad('X', PL_thistoken);
5471                         PL_thistoken = newSVpvn("",0);
5472                         force_next(WORD);
5473                         TOKEN(NOAMP);
5474                     }
5475 #else
5476                     NEXTVAL_NEXTTOKE.opval = yylval.opval;
5477                     PL_expect = XTERM;
5478                     force_next(WORD);
5479                     TOKEN(NOAMP);
5480 #endif
5481                 }
5482
5483                 /* Call it a bare word */
5484
5485                 if (PL_hints & HINT_STRICT_SUBS)
5486                     yylval.opval->op_private |= OPpCONST_STRICT;
5487                 else {
5488                 bareword:
5489                     if (lastchar != '-') {
5490                         if (ckWARN(WARN_RESERVED)) {
5491                             d = PL_tokenbuf;
5492                             while (isLOWER(*d))
5493                                 d++;
5494                             if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
5495                                 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5496                                        PL_tokenbuf);
5497                         }
5498                     }
5499                 }
5500
5501             safe_bareword:
5502                 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
5503                     && ckWARN_d(WARN_AMBIGUOUS)) {
5504                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5505                         "Operator or semicolon missing before %c%s",
5506                         lastchar, PL_tokenbuf);
5507                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5508                         "Ambiguous use of %c resolved as operator %c",
5509                         lastchar, lastchar);
5510                 }
5511                 TOKEN(WORD);
5512             }
5513
5514         case KEY___FILE__:
5515             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5516                                         newSVpv(CopFILE(PL_curcop),0));
5517             TERM(THING);
5518
5519         case KEY___LINE__:
5520             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5521                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5522             TERM(THING);
5523
5524         case KEY___PACKAGE__:
5525             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5526                                         (PL_curstash
5527                                          ? newSVhek(HvNAME_HEK(PL_curstash))
5528                                          : &PL_sv_undef));
5529             TERM(THING);
5530
5531         case KEY___DATA__:
5532         case KEY___END__: {
5533             GV *gv;
5534             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5535                 const char *pname = "main";
5536                 if (PL_tokenbuf[2] == 'D')
5537                     pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5538                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5539                                 SVt_PVIO);
5540                 GvMULTI_on(gv);
5541                 if (!GvIO(gv))
5542                     GvIOp(gv) = newIO();
5543                 IoIFP(GvIOp(gv)) = PL_rsfp;
5544 #if defined(HAS_FCNTL) && defined(F_SETFD)
5545                 {
5546                     const int fd = PerlIO_fileno(PL_rsfp);
5547                     fcntl(fd,F_SETFD,fd >= 3);
5548                 }
5549 #endif
5550                 /* Mark this internal pseudo-handle as clean */
5551                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5552                 if (PL_preprocess)
5553                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
5554                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5555                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5556                 else
5557                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5558 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5559                 /* if the script was opened in binmode, we need to revert
5560                  * it to text mode for compatibility; but only iff it has CRs
5561                  * XXX this is a questionable hack at best. */
5562                 if (PL_bufend-PL_bufptr > 2
5563                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5564                 {
5565                     Off_t loc = 0;
5566                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5567                         loc = PerlIO_tell(PL_rsfp);
5568                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
5569                     }
5570 #ifdef NETWARE
5571                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5572 #else
5573                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5574 #endif  /* NETWARE */
5575 #ifdef PERLIO_IS_STDIO /* really? */
5576 #  if defined(__BORLANDC__)
5577                         /* XXX see note in do_binmode() */
5578                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5579 #  endif
5580 #endif
5581                         if (loc > 0)
5582                             PerlIO_seek(PL_rsfp, loc, 0);
5583                     }
5584                 }
5585 #endif
5586 #ifdef PERLIO_LAYERS
5587                 if (!IN_BYTES) {
5588                     if (UTF)
5589                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5590                     else if (PL_encoding) {
5591                         SV *name;
5592                         dSP;
5593                         ENTER;
5594                         SAVETMPS;
5595                         PUSHMARK(sp);
5596                         EXTEND(SP, 1);
5597                         XPUSHs(PL_encoding);
5598                         PUTBACK;
5599                         call_method("name", G_SCALAR);
5600                         SPAGAIN;
5601                         name = POPs;
5602                         PUTBACK;
5603                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5604                                             Perl_form(aTHX_ ":encoding(%"SVf")",
5605                                                       (void*)name));
5606                         FREETMPS;
5607                         LEAVE;
5608                     }
5609                 }
5610 #endif
5611 #ifdef PERL_MAD
5612                 if (PL_madskills) {
5613                     if (PL_realtokenstart >= 0) {
5614                         char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5615                         if (!PL_endwhite)
5616                             PL_endwhite = newSVpvn("",0);
5617                         sv_catsv(PL_endwhite, PL_thiswhite);
5618                         PL_thiswhite = 0;
5619                         sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5620                         PL_realtokenstart = -1;
5621                     }
5622                     while ((s = filter_gets(PL_endwhite, PL_rsfp,
5623                                  SvCUR(PL_endwhite))) != Nullch) ;
5624                 }
5625 #endif
5626                 PL_rsfp = NULL;
5627             }
5628             goto fake_eof;
5629         }
5630
5631         case KEY_AUTOLOAD:
5632         case KEY_DESTROY:
5633         case KEY_BEGIN:
5634         case KEY_CHECK:
5635         case KEY_INIT:
5636         case KEY_END:
5637             if (PL_expect == XSTATE) {
5638                 s = PL_bufptr;
5639                 goto really_sub;
5640             }
5641             goto just_a_word;
5642
5643         case KEY_CORE:
5644             if (*s == ':' && s[1] == ':') {
5645                 s += 2;
5646                 d = s;
5647                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5648                 if (!(tmp = keyword(PL_tokenbuf, len)))
5649                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5650                 if (tmp < 0)
5651                     tmp = -tmp;
5652                 else if (tmp == KEY_require || tmp == KEY_do)
5653                     /* that's a way to remember we saw "CORE::" */
5654                     orig_keyword = tmp;
5655                 goto reserved_word;
5656             }
5657             goto just_a_word;
5658
5659         case KEY_abs:
5660             UNI(OP_ABS);
5661
5662         case KEY_alarm:
5663             UNI(OP_ALARM);
5664
5665         case KEY_accept:
5666             LOP(OP_ACCEPT,XTERM);
5667
5668         case KEY_and:
5669             OPERATOR(ANDOP);
5670
5671         case KEY_atan2:
5672             LOP(OP_ATAN2,XTERM);
5673
5674         case KEY_bind:
5675             LOP(OP_BIND,XTERM);
5676
5677         case KEY_binmode:
5678             LOP(OP_BINMODE,XTERM);
5679
5680         case KEY_bless:
5681             LOP(OP_BLESS,XTERM);
5682
5683         case KEY_break:
5684             FUN0(OP_BREAK);
5685
5686         case KEY_chop:
5687             UNI(OP_CHOP);
5688
5689         case KEY_continue:
5690             /* When 'use switch' is in effect, continue has a dual
5691                life as a control operator. */
5692             {
5693                 if (!FEATURE_IS_ENABLED("switch"))
5694                     PREBLOCK(CONTINUE);
5695                 else {
5696                     /* We have to disambiguate the two senses of
5697                       "continue". If the next token is a '{' then
5698                       treat it as the start of a continue block;
5699                       otherwise treat it as a control operator.
5700                      */
5701                     s = skipspace(s);
5702                     if (*s == '{')
5703             PREBLOCK(CONTINUE);
5704                     else
5705                         FUN0(OP_CONTINUE);
5706                 }
5707             }
5708
5709         case KEY_chdir:
5710             /* may use HOME */
5711             (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5712             UNI(OP_CHDIR);
5713
5714         case KEY_close:
5715             UNI(OP_CLOSE);
5716
5717         case KEY_closedir:
5718             UNI(OP_CLOSEDIR);
5719
5720         case KEY_cmp:
5721             Eop(OP_SCMP);
5722
5723         case KEY_caller:
5724             UNI(OP_CALLER);
5725
5726         case KEY_crypt:
5727 #ifdef FCRYPT
5728             if (!PL_cryptseen) {
5729                 PL_cryptseen = TRUE;
5730                 init_des();
5731             }
5732 #endif
5733             LOP(OP_CRYPT,XTERM);
5734
5735         case KEY_chmod:
5736             LOP(OP_CHMOD,XTERM);
5737
5738         case KEY_chown:
5739             LOP(OP_CHOWN,XTERM);
5740
5741         case KEY_connect:
5742             LOP(OP_CONNECT,XTERM);
5743
5744         case KEY_chr:
5745             UNI(OP_CHR);
5746
5747         case KEY_cos:
5748             UNI(OP_COS);
5749
5750         case KEY_chroot:
5751             UNI(OP_CHROOT);
5752
5753         case KEY_default:
5754             PREBLOCK(DEFAULT);
5755
5756         case KEY_do:
5757             s = SKIPSPACE1(s);
5758             if (*s == '{')
5759                 PRETERMBLOCK(DO);
5760             if (*s != '\'')
5761                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5762             if (orig_keyword == KEY_do) {
5763                 orig_keyword = 0;
5764                 yylval.ival = 1;
5765             }
5766             else
5767                 yylval.ival = 0;
5768             OPERATOR(DO);
5769
5770         case KEY_die:
5771             PL_hints |= HINT_BLOCK_SCOPE;
5772             LOP(OP_DIE,XTERM);
5773
5774         case KEY_defined:
5775             UNI(OP_DEFINED);
5776
5777         case KEY_delete:
5778             UNI(OP_DELETE);
5779
5780         case KEY_dbmopen:
5781             gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
5782             LOP(OP_DBMOPEN,XTERM);
5783
5784         case KEY_dbmclose:
5785             UNI(OP_DBMCLOSE);
5786
5787         case KEY_dump:
5788             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5789             LOOPX(OP_DUMP);
5790
5791         case KEY_else:
5792             PREBLOCK(ELSE);
5793
5794         case KEY_elsif:
5795             yylval.ival = CopLINE(PL_curcop);
5796             OPERATOR(ELSIF);
5797
5798         case KEY_eq:
5799             Eop(OP_SEQ);
5800
5801         case KEY_exists:
5802             UNI(OP_EXISTS);
5803
5804         case KEY_exit:
5805             if (PL_madskills)
5806                 UNI(OP_INT);
5807             UNI(OP_EXIT);
5808
5809         case KEY_eval:
5810             s = SKIPSPACE1(s);
5811             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
5812             UNIBRACK(OP_ENTEREVAL);
5813
5814         case KEY_eof:
5815             UNI(OP_EOF);
5816
5817         case KEY_err:
5818             OPERATOR(DOROP);
5819
5820         case KEY_exp:
5821             UNI(OP_EXP);
5822
5823         case KEY_each:
5824             UNI(OP_EACH);
5825
5826         case KEY_exec:
5827             set_csh();
5828             LOP(OP_EXEC,XREF);
5829
5830         case KEY_endhostent:
5831             FUN0(OP_EHOSTENT);
5832
5833         case KEY_endnetent:
5834             FUN0(OP_ENETENT);
5835
5836         case KEY_endservent:
5837             FUN0(OP_ESERVENT);
5838
5839         case KEY_endprotoent:
5840             FUN0(OP_EPROTOENT);
5841
5842         case KEY_endpwent:
5843             FUN0(OP_EPWENT);
5844
5845         case KEY_endgrent:
5846             FUN0(OP_EGRENT);
5847
5848         case KEY_for:
5849         case KEY_foreach:
5850             yylval.ival = CopLINE(PL_curcop);
5851             s = SKIPSPACE1(s);
5852             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
5853                 char *p = s;
5854 #ifdef PERL_MAD
5855                 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
5856 #endif
5857
5858                 if ((PL_bufend - p) >= 3 &&
5859                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
5860                     p += 2;
5861                 else if ((PL_bufend - p) >= 4 &&
5862                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
5863                     p += 3;
5864                 p = PEEKSPACE(p);
5865                 if (isIDFIRST_lazy_if(p,UTF)) {
5866                     p = scan_ident(p, PL_bufend,
5867                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5868                     p = PEEKSPACE(p);
5869                 }
5870                 if (*p != '$')
5871                     Perl_croak(aTHX_ "Missing $ on loop variable");
5872 #ifdef PERL_MAD
5873                 s = SvPVX(PL_linestr) + soff;
5874 #endif
5875             }
5876             OPERATOR(FOR);
5877
5878         case KEY_formline:
5879             LOP(OP_FORMLINE,XTERM);
5880
5881         case KEY_fork:
5882             FUN0(OP_FORK);
5883
5884         case KEY_fcntl:
5885             LOP(OP_FCNTL,XTERM);
5886
5887         case KEY_fileno:
5888             UNI(OP_FILENO);
5889
5890         case KEY_flock:
5891             LOP(OP_FLOCK,XTERM);
5892
5893         case KEY_gt:
5894             Rop(OP_SGT);
5895
5896         case KEY_ge:
5897             Rop(OP_SGE);
5898
5899         case KEY_grep:
5900             LOP(OP_GREPSTART, XREF);
5901
5902         case KEY_goto:
5903             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5904             LOOPX(OP_GOTO);
5905
5906         case KEY_gmtime:
5907             UNI(OP_GMTIME);
5908
5909         case KEY_getc:
5910             UNIDOR(OP_GETC);
5911
5912         case KEY_getppid:
5913             FUN0(OP_GETPPID);
5914
5915         case KEY_getpgrp:
5916             UNI(OP_GETPGRP);
5917
5918         case KEY_getpriority:
5919             LOP(OP_GETPRIORITY,XTERM);
5920
5921         case KEY_getprotobyname:
5922             UNI(OP_GPBYNAME);
5923
5924         case KEY_getprotobynumber:
5925             LOP(OP_GPBYNUMBER,XTERM);
5926
5927         case KEY_getprotoent:
5928             FUN0(OP_GPROTOENT);
5929
5930         case KEY_getpwent:
5931             FUN0(OP_GPWENT);
5932
5933         case KEY_getpwnam:
5934             UNI(OP_GPWNAM);
5935
5936         case KEY_getpwuid:
5937             UNI(OP_GPWUID);
5938
5939         case KEY_getpeername:
5940             UNI(OP_GETPEERNAME);
5941
5942         case KEY_gethostbyname:
5943             UNI(OP_GHBYNAME);
5944
5945         case KEY_gethostbyaddr:
5946             LOP(OP_GHBYADDR,XTERM);
5947
5948         case KEY_gethostent:
5949             FUN0(OP_GHOSTENT);
5950
5951         case KEY_getnetbyname:
5952             UNI(OP_GNBYNAME);
5953
5954         case KEY_getnetbyaddr:
5955             LOP(OP_GNBYADDR,XTERM);
5956
5957         case KEY_getnetent:
5958             FUN0(OP_GNETENT);
5959
5960         case KEY_getservbyname:
5961             LOP(OP_GSBYNAME,XTERM);
5962
5963         case KEY_getservbyport:
5964             LOP(OP_GSBYPORT,XTERM);
5965
5966         case KEY_getservent:
5967             FUN0(OP_GSERVENT);
5968
5969         case KEY_getsockname:
5970             UNI(OP_GETSOCKNAME);
5971
5972         case KEY_getsockopt:
5973             LOP(OP_GSOCKOPT,XTERM);
5974
5975         case KEY_getgrent:
5976             FUN0(OP_GGRENT);
5977
5978         case KEY_getgrnam:
5979             UNI(OP_GGRNAM);
5980
5981         case KEY_getgrgid:
5982             UNI(OP_GGRGID);
5983
5984         case KEY_getlogin:
5985             FUN0(OP_GETLOGIN);
5986
5987         case KEY_given:
5988             yylval.ival = CopLINE(PL_curcop);
5989             OPERATOR(GIVEN);
5990
5991         case KEY_glob:
5992             set_csh();
5993             LOP(OP_GLOB,XTERM);
5994
5995         case KEY_hex:
5996             UNI(OP_HEX);
5997
5998         case KEY_if:
5999             yylval.ival = CopLINE(PL_curcop);
6000             OPERATOR(IF);
6001
6002         case KEY_index:
6003             LOP(OP_INDEX,XTERM);
6004
6005         case KEY_int:
6006             UNI(OP_INT);
6007
6008         case KEY_ioctl:
6009             LOP(OP_IOCTL,XTERM);
6010
6011         case KEY_join:
6012             LOP(OP_JOIN,XTERM);
6013
6014         case KEY_keys:
6015             UNI(OP_KEYS);
6016
6017         case KEY_kill:
6018             LOP(OP_KILL,XTERM);
6019
6020         case KEY_last:
6021             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6022             LOOPX(OP_LAST);
6023
6024         case KEY_lc:
6025             UNI(OP_LC);
6026
6027         case KEY_lcfirst:
6028             UNI(OP_LCFIRST);
6029
6030         case KEY_local:
6031             yylval.ival = 0;
6032             OPERATOR(LOCAL);
6033
6034         case KEY_length:
6035             UNI(OP_LENGTH);
6036
6037         case KEY_lt:
6038             Rop(OP_SLT);
6039
6040         case KEY_le:
6041             Rop(OP_SLE);
6042
6043         case KEY_localtime:
6044             UNI(OP_LOCALTIME);
6045
6046         case KEY_log:
6047             UNI(OP_LOG);
6048
6049         case KEY_link:
6050             LOP(OP_LINK,XTERM);
6051
6052         case KEY_listen:
6053             LOP(OP_LISTEN,XTERM);
6054
6055         case KEY_lock:
6056             UNI(OP_LOCK);
6057
6058         case KEY_lstat:
6059             UNI(OP_LSTAT);
6060
6061         case KEY_m:
6062             s = scan_pat(s,OP_MATCH);
6063             TERM(sublex_start());
6064
6065         case KEY_map:
6066             LOP(OP_MAPSTART, XREF);
6067
6068         case KEY_mkdir:
6069             LOP(OP_MKDIR,XTERM);
6070
6071         case KEY_msgctl:
6072             LOP(OP_MSGCTL,XTERM);
6073
6074         case KEY_msgget:
6075             LOP(OP_MSGGET,XTERM);
6076
6077         case KEY_msgrcv:
6078             LOP(OP_MSGRCV,XTERM);
6079
6080         case KEY_msgsnd:
6081             LOP(OP_MSGSND,XTERM);
6082
6083         case KEY_our:
6084         case KEY_my:
6085         case KEY_state:
6086             PL_in_my = tmp;
6087             s = SKIPSPACE1(s);
6088             if (isIDFIRST_lazy_if(s,UTF)) {
6089 #ifdef PERL_MAD
6090                 char* start = s;
6091 #endif
6092                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6093                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
6094                     goto really_sub;
6095                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6096                 if (!PL_in_my_stash) {
6097                     char tmpbuf[1024];
6098                     PL_bufptr = s;
6099                     my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6100                     yyerror(tmpbuf);
6101                 }
6102 #ifdef PERL_MAD
6103                 if (PL_madskills) {     /* just add type to declarator token */
6104                     sv_catsv(PL_thistoken, PL_nextwhite);
6105                     PL_nextwhite = 0;
6106                     sv_catpvn(PL_thistoken, start, s - start);
6107                 }
6108 #endif
6109             }
6110             yylval.ival = 1;
6111             OPERATOR(MY);
6112
6113         case KEY_next:
6114             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6115             LOOPX(OP_NEXT);
6116
6117         case KEY_ne:
6118             Eop(OP_SNE);
6119
6120         case KEY_no:
6121             s = tokenize_use(0, s);
6122             OPERATOR(USE);
6123
6124         case KEY_not:
6125             if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
6126                 FUN1(OP_NOT);
6127             else
6128                 OPERATOR(NOTOP);
6129
6130         case KEY_open:
6131             s = SKIPSPACE1(s);
6132             if (isIDFIRST_lazy_if(s,UTF)) {
6133                 const char *t;
6134                 for (d = s; isALNUM_lazy_if(d,UTF);)
6135                     d++;
6136                 for (t=d; isSPACE(*t);)
6137                     t++;
6138                 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
6139                     /* [perl #16184] */
6140                     && !(t[0] == '=' && t[1] == '>')
6141                 ) {
6142                     int parms_len = (int)(d-s);
6143                     Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6144                            "Precedence problem: open %.*s should be open(%.*s)",
6145                             parms_len, s, parms_len, s);
6146                 }
6147             }
6148             LOP(OP_OPEN,XTERM);
6149
6150         case KEY_or:
6151             yylval.ival = OP_OR;
6152             OPERATOR(OROP);
6153
6154         case KEY_ord:
6155             UNI(OP_ORD);
6156
6157         case KEY_oct:
6158             UNI(OP_OCT);
6159
6160         case KEY_opendir:
6161             LOP(OP_OPEN_DIR,XTERM);
6162
6163         case KEY_print:
6164             checkcomma(s,PL_tokenbuf,"filehandle");
6165             LOP(OP_PRINT,XREF);
6166
6167         case KEY_printf:
6168             checkcomma(s,PL_tokenbuf,"filehandle");
6169             LOP(OP_PRTF,XREF);
6170
6171         case KEY_prototype:
6172             UNI(OP_PROTOTYPE);
6173
6174         case KEY_push:
6175             LOP(OP_PUSH,XTERM);
6176
6177         case KEY_pop:
6178             UNIDOR(OP_POP);
6179
6180         case KEY_pos:
6181             UNIDOR(OP_POS);
6182
6183         case KEY_pack:
6184             LOP(OP_PACK,XTERM);
6185
6186         case KEY_package:
6187             s = force_word(s,WORD,FALSE,TRUE,FALSE);
6188             OPERATOR(PACKAGE);
6189
6190         case KEY_pipe:
6191             LOP(OP_PIPE_OP,XTERM);
6192
6193         case KEY_q:
6194             s = scan_str(s,!!PL_madskills,FALSE);
6195             if (!s)
6196                 missingterm(NULL);
6197             yylval.ival = OP_CONST;
6198             TERM(sublex_start());
6199
6200         case KEY_quotemeta:
6201             UNI(OP_QUOTEMETA);
6202
6203         case KEY_qw:
6204             s = scan_str(s,!!PL_madskills,FALSE);
6205             if (!s)
6206                 missingterm(NULL);
6207             PL_expect = XOPERATOR;
6208             force_next(')');
6209             if (SvCUR(PL_lex_stuff)) {
6210                 OP *words = NULL;
6211                 int warned = 0;
6212                 d = SvPV_force(PL_lex_stuff, len);
6213                 while (len) {
6214                     for (; isSPACE(*d) && len; --len, ++d)
6215                         /**/;
6216                     if (len) {
6217                         SV *sv;
6218                         const char *b = d;
6219                         if (!warned && ckWARN(WARN_QW)) {
6220                             for (; !isSPACE(*d) && len; --len, ++d) {
6221                                 if (*d == ',') {
6222                                     Perl_warner(aTHX_ packWARN(WARN_QW),
6223                                         "Possible attempt to separate words with commas");
6224                                     ++warned;
6225                                 }
6226                                 else if (*d == '#') {
6227                                     Perl_warner(aTHX_ packWARN(WARN_QW),
6228                                         "Possible attempt to put comments in qw() list");
6229                                     ++warned;
6230                                 }
6231                             }
6232                         }
6233                         else {
6234                             for (; !isSPACE(*d) && len; --len, ++d)
6235                                 /**/;
6236                         }
6237                         sv = newSVpvn(b, d-b);
6238                         if (DO_UTF8(PL_lex_stuff))
6239                             SvUTF8_on(sv);
6240                         words = append_elem(OP_LIST, words,
6241                                             newSVOP(OP_CONST, 0, tokeq(sv)));
6242                     }
6243                 }
6244                 if (words) {
6245                     start_force(PL_curforce);
6246                     NEXTVAL_NEXTTOKE.opval = words;
6247                     force_next(THING);
6248                 }
6249             }
6250             if (PL_lex_stuff) {
6251                 SvREFCNT_dec(PL_lex_stuff);
6252                 PL_lex_stuff = NULL;
6253             }
6254             PL_expect = XTERM;
6255             TOKEN('(');
6256
6257         case KEY_qq:
6258             s = scan_str(s,!!PL_madskills,FALSE);
6259             if (!s)
6260                 missingterm(NULL);
6261             yylval.ival = OP_STRINGIFY;
6262             if (SvIVX(PL_lex_stuff) == '\'')
6263                 SvIV_set(PL_lex_stuff, 0);      /* qq'$foo' should intepolate */
6264             TERM(sublex_start());
6265
6266         case KEY_qr:
6267             s = scan_pat(s,OP_QR);
6268             TERM(sublex_start());
6269
6270         case KEY_qx:
6271             s = scan_str(s,!!PL_madskills,FALSE);
6272             if (!s)
6273                 missingterm(NULL);
6274             yylval.ival = OP_BACKTICK;
6275             set_csh();
6276             TERM(sublex_start());
6277
6278         case KEY_return:
6279             OLDLOP(OP_RETURN);
6280
6281         case KEY_require:
6282             s = SKIPSPACE1(s);
6283             if (isDIGIT(*s)) {
6284                 s = force_version(s, FALSE);
6285             }
6286             else if (*s != 'v' || !isDIGIT(s[1])
6287                     || (s = force_version(s, TRUE), *s == 'v'))
6288             {
6289                 *PL_tokenbuf = '\0';
6290                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6291                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6292                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
6293                 else if (*s == '<')
6294                     yyerror("<> should be quotes");
6295             }
6296             if (orig_keyword == KEY_require) {
6297                 orig_keyword = 0;
6298                 yylval.ival = 1;
6299             }
6300             else
6301                 yylval.ival = 0;
6302             PL_expect = XTERM;
6303             PL_bufptr = s;
6304             PL_last_uni = PL_oldbufptr;
6305             PL_last_lop_op = OP_REQUIRE;
6306             s = skipspace(s);
6307             return REPORT( (int)REQUIRE );
6308
6309         case KEY_reset:
6310             UNI(OP_RESET);
6311
6312         case KEY_redo:
6313             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6314             LOOPX(OP_REDO);
6315
6316         case KEY_rename:
6317             LOP(OP_RENAME,XTERM);
6318
6319         case KEY_rand:
6320             UNI(OP_RAND);
6321
6322         case KEY_rmdir:
6323             UNI(OP_RMDIR);
6324
6325         case KEY_rindex:
6326             LOP(OP_RINDEX,XTERM);
6327
6328         case KEY_read:
6329             LOP(OP_READ,XTERM);
6330
6331         case KEY_readdir:
6332             UNI(OP_READDIR);
6333
6334         case KEY_readline:
6335             set_csh();
6336             UNIDOR(OP_READLINE);
6337
6338         case KEY_readpipe:
6339             set_csh();
6340             UNI(OP_BACKTICK);
6341
6342         case KEY_rewinddir:
6343             UNI(OP_REWINDDIR);
6344
6345         case KEY_recv:
6346             LOP(OP_RECV,XTERM);
6347
6348         case KEY_reverse:
6349             LOP(OP_REVERSE,XTERM);
6350
6351         case KEY_readlink:
6352             UNIDOR(OP_READLINK);
6353
6354         case KEY_ref:
6355             UNI(OP_REF);
6356
6357         case KEY_s:
6358             s = scan_subst(s);
6359             if (yylval.opval)
6360                 TERM(sublex_start());
6361             else
6362                 TOKEN(1);       /* force error */
6363
6364         case KEY_say:
6365             checkcomma(s,PL_tokenbuf,"filehandle");
6366             LOP(OP_SAY,XREF);
6367
6368         case KEY_chomp:
6369             UNI(OP_CHOMP);
6370
6371         case KEY_scalar:
6372             UNI(OP_SCALAR);
6373
6374         case KEY_select:
6375             LOP(OP_SELECT,XTERM);
6376
6377         case KEY_seek:
6378             LOP(OP_SEEK,XTERM);
6379
6380         case KEY_semctl:
6381             LOP(OP_SEMCTL,XTERM);
6382
6383         case KEY_semget:
6384             LOP(OP_SEMGET,XTERM);
6385
6386         case KEY_semop:
6387             LOP(OP_SEMOP,XTERM);
6388
6389         case KEY_send:
6390             LOP(OP_SEND,XTERM);
6391
6392         case KEY_setpgrp:
6393             LOP(OP_SETPGRP,XTERM);
6394
6395         case KEY_setpriority:
6396             LOP(OP_SETPRIORITY,XTERM);
6397
6398         case KEY_sethostent:
6399             UNI(OP_SHOSTENT);
6400
6401         case KEY_setnetent:
6402             UNI(OP_SNETENT);
6403
6404         case KEY_setservent:
6405             UNI(OP_SSERVENT);
6406
6407         case KEY_setprotoent:
6408             UNI(OP_SPROTOENT);
6409
6410         case KEY_setpwent:
6411             FUN0(OP_SPWENT);
6412
6413         case KEY_setgrent:
6414             FUN0(OP_SGRENT);
6415
6416         case KEY_seekdir:
6417             LOP(OP_SEEKDIR,XTERM);
6418
6419         case KEY_setsockopt:
6420             LOP(OP_SSOCKOPT,XTERM);
6421
6422         case KEY_shift:
6423             UNIDOR(OP_SHIFT);
6424
6425         case KEY_shmctl:
6426             LOP(OP_SHMCTL,XTERM);
6427
6428         case KEY_shmget:
6429             LOP(OP_SHMGET,XTERM);
6430
6431         case KEY_shmread:
6432             LOP(OP_SHMREAD,XTERM);
6433
6434         case KEY_shmwrite:
6435             LOP(OP_SHMWRITE,XTERM);
6436
6437         case KEY_shutdown:
6438             LOP(OP_SHUTDOWN,XTERM);
6439
6440         case KEY_sin:
6441             UNI(OP_SIN);
6442
6443         case KEY_sleep:
6444             UNI(OP_SLEEP);
6445
6446         case KEY_socket:
6447             LOP(OP_SOCKET,XTERM);
6448
6449         case KEY_socketpair:
6450             LOP(OP_SOCKPAIR,XTERM);
6451
6452         case KEY_sort:
6453             checkcomma(s,PL_tokenbuf,"subroutine name");
6454             s = SKIPSPACE1(s);
6455             if (*s == ';' || *s == ')')         /* probably a close */
6456                 Perl_croak(aTHX_ "sort is now a reserved word");
6457             PL_expect = XTERM;
6458             s = force_word(s,WORD,TRUE,TRUE,FALSE);
6459             LOP(OP_SORT,XREF);
6460
6461         case KEY_split:
6462             LOP(OP_SPLIT,XTERM);
6463
6464         case KEY_sprintf:
6465             LOP(OP_SPRINTF,XTERM);
6466
6467         case KEY_splice:
6468             LOP(OP_SPLICE,XTERM);
6469
6470         case KEY_sqrt:
6471             UNI(OP_SQRT);
6472
6473         case KEY_srand:
6474             UNI(OP_SRAND);
6475
6476         case KEY_stat:
6477             UNI(OP_STAT);
6478
6479         case KEY_study:
6480             UNI(OP_STUDY);
6481
6482         case KEY_substr:
6483             LOP(OP_SUBSTR,XTERM);
6484
6485         case KEY_format:
6486         case KEY_sub:
6487           really_sub:
6488             {
6489                 char tmpbuf[sizeof PL_tokenbuf];
6490                 SSize_t tboffset = 0;
6491                 expectation attrful;
6492                 bool have_name, have_proto, bad_proto;
6493                 const int key = tmp;
6494
6495 #ifdef PERL_MAD
6496                 SV *tmpwhite = 0;
6497
6498                 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6499                 SV *subtoken = newSVpvn(tstart, s - tstart);
6500                 PL_thistoken = 0;
6501
6502                 d = s;
6503                 s = SKIPSPACE2(s,tmpwhite);
6504 #else
6505                 s = skipspace(s);
6506 #endif
6507
6508                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6509                     (*s == ':' && s[1] == ':'))
6510                 {
6511 #ifdef PERL_MAD
6512                     SV *nametoke;
6513 #endif
6514
6515                     PL_expect = XBLOCK;
6516                     attrful = XATTRBLOCK;
6517                     /* remember buffer pos'n for later force_word */
6518                     tboffset = s - PL_oldbufptr;
6519                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6520 #ifdef PERL_MAD
6521                     if (PL_madskills)
6522                         nametoke = newSVpvn(s, d - s);
6523 #endif
6524                     if (strchr(tmpbuf, ':'))
6525                         sv_setpv(PL_subname, tmpbuf);
6526                     else {
6527                         sv_setsv(PL_subname,PL_curstname);
6528                         sv_catpvs(PL_subname,"::");
6529                         sv_catpvn(PL_subname,tmpbuf,len);
6530                     }
6531                     have_name = TRUE;
6532
6533 #ifdef PERL_MAD
6534
6535                     start_force(0);
6536                     CURMAD('X', nametoke);
6537                     CURMAD('_', tmpwhite);
6538                     (void) force_word(PL_oldbufptr + tboffset, WORD,
6539                                       FALSE, TRUE, TRUE);
6540
6541                     s = SKIPSPACE2(d,tmpwhite);
6542 #else
6543                     s = skipspace(d);
6544 #endif
6545                 }
6546                 else {
6547                     if (key == KEY_my)
6548                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
6549                     PL_expect = XTERMBLOCK;
6550                     attrful = XATTRTERM;
6551                     sv_setpvn(PL_subname,"?",1);
6552                     have_name = FALSE;
6553                 }
6554
6555                 if (key == KEY_format) {
6556                     if (*s == '=')
6557                         PL_lex_formbrack = PL_lex_brackets + 1;
6558 #ifdef PERL_MAD
6559                     PL_thistoken = subtoken;
6560                     s = d;
6561 #else
6562                     if (have_name)
6563                         (void) force_word(PL_oldbufptr + tboffset, WORD,
6564                                           FALSE, TRUE, TRUE);
6565 #endif
6566                     OPERATOR(FORMAT);
6567                 }
6568
6569                 /* Look for a prototype */
6570                 if (*s == '(') {
6571                     char *p;
6572
6573                     s = scan_str(s,!!PL_madskills,FALSE);
6574                     if (!s)
6575                         Perl_croak(aTHX_ "Prototype not terminated");
6576                     /* strip spaces and check for bad characters */
6577                     d = SvPVX(PL_lex_stuff);
6578                     tmp = 0;
6579                     bad_proto = FALSE;
6580                     for (p = d; *p; ++p) {
6581                         if (!isSPACE(*p)) {
6582                             d[tmp++] = *p;
6583                             if (!strchr("$@%*;[]&\\", *p))
6584                                 bad_proto = TRUE;
6585                         }
6586                     }
6587                     d[tmp] = '\0';
6588                     if (bad_proto && ckWARN(WARN_SYNTAX))
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('^', newSVpvn("",0));
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)
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 (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 (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 (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 (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 (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 (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 (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))
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)) {
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) || 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     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  */