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