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