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 /* YYINITDEPTH -- initial size of the parser's stacks.  */
  29 #define YYINITDEPTH 200
  30
  31 static const char ident_too_long[] = "Identifier too long";
  32 static const char commaless_variable_list[] = "comma-less variable list";
  33
  34 static void restore_rsfp(pTHX_ void *f);
  35 #ifndef PERL_NO_UTF16_FILTER
  36 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
  37 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
  38 #endif
  39
  40 #ifdef PERL_MAD
  41 #  define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
  42 #  define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
  43 #else
  44 #  define CURMAD(slot,sv)
  45 #  define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
  46 #endif
  47
  48 #define XFAKEBRACK 128
  49 #define XENUMMASK 127
  50
  51 #ifdef USE_UTF8_SCRIPTS
  52 #   define UTF (!IN_BYTES)
  53 #else
  54 #   define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
  55 #endif
  56
  57 /* In variables named $^X, these are the legal values for X.
  58  * 1999-02-27 mjd-perl-patch@plover.com */
  59 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
  60
  61 /* On MacOS, respect nonbreaking spaces */
  62 #ifdef MACOS_TRADITIONAL
  63 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
  64 #else
  65 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
  66 #endif
  67
  68 /* LEX_* are values for PL_lex_state, the state of the lexer.
  69  * They are arranged oddly so that the guard on the switch statement
  70  * can get by with a single comparison (if the compiler is smart enough).
  71  */
  72
  73 /* #define LEX_NOTPARSING               11 is done in perl.h. */
  74
  75 #define LEX_NORMAL              10 /* normal code (ie not within "...")     */
  76 #define LEX_INTERPNORMAL         9 /* code within a string, eg "$foo[$x+1]" */
  77 #define LEX_INTERPCASEMOD        8 /* expecting a \U, \Q or \E etc          */
  78 #define LEX_INTERPPUSH           7 /* starting a new sublex parse level     */
  79 #define LEX_INTERPSTART          6 /* expecting the start of a $var         */
  80
  81                                    /* at end of code, eg "$x" followed by:  */
  82 #define LEX_INTERPEND            5 /* ... eg not one of [, { or ->          */
  83 #define LEX_INTERPENDMAYBE       4 /* ... eg one of [, { or ->              */
  84
  85 #define LEX_INTERPCONCAT         3 /* expecting anything, eg at start of
  86                                         string or after \E, $foo, etc       */
  87 #define LEX_INTERPCONST          2 /* NOT USED */
  88 #define LEX_FORMLINE             1 /* expecting a format line               */
  89 #define LEX_KNOWNEXT             0 /* next token known; just return it      */
  90
  91
  92 #ifdef DEBUGGING
  93 static const char* const lex_state_names[] = {
  94     "KNOWNEXT",
  95     "FORMLINE",
  96     "INTERPCONST",
  97     "INTERPCONCAT",
  98     "INTERPENDMAYBE",
  99     "INTERPEND",
 100     "INTERPSTART",
 101     "INTERPPUSH",
 102     "INTERPCASEMOD",
 103     "INTERPNORMAL",
 104     "NORMAL"
 105 };
 106 #endif
 107
 108 #ifdef ff_next
 109 #undef ff_next
 110 #endif
 111
 112 #include "keywords.h"
 113
 114 /* CLINE is a macro that ensures PL_copline has a sane value */
 115
 116 #ifdef CLINE
 117 #undef CLINE
 118 #endif
 119 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
 120
 121 #ifdef PERL_MAD
 122 #  define SKIPSPACE0(s) skipspace0(s)
 123 #  define SKIPSPACE1(s) skipspace1(s)
 124 #  define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
 125 #  define PEEKSPACE(s) skipspace2(s,0)
 126 #else
 127 #  define SKIPSPACE0(s) skipspace(s)
 128 #  define SKIPSPACE1(s) skipspace(s)
 129 #  define SKIPSPACE2(s,tsv) skipspace(s)
 130 #  define PEEKSPACE(s) skipspace(s)
 131 #endif
 132
 133 /*
 134  * Convenience functions to return different tokens and prime the
 135  * lexer for the next token.  They all take an argument.
 136  *
 137  * TOKEN        : generic token (used for '(', DOLSHARP, etc)
 138  * OPERATOR     : generic operator
 139  * AOPERATOR    : assignment operator
 140  * PREBLOCK     : beginning the block after an if, while, foreach, ...
 141  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
 142  * PREREF       : *EXPR where EXPR is not a simple identifier
 143  * TERM         : expression term
 144  * LOOPX        : loop exiting command (goto, last, dump, etc)
 145  * FTST         : file test operator
 146  * FUN0         : zero-argument function
 147  * FUN1         : not used, except for not, which isn't a UNIOP
 148  * BOop         : bitwise or or xor
 149  * BAop         : bitwise and
 150  * SHop         : shift operator
 151  * PWop         : power operator
 152  * PMop         : pattern-matching operator
 153  * Aop          : addition-level operator
 154  * Mop          : multiplication-level operator
 155  * Eop          : equality-testing operator
 156  * Rop          : relational operator <= != gt
 157  *
 158  * Also see LOP and lop() below.
 159  */
 160
 161 #ifdef DEBUGGING /* Serve -DT. */
 162 #   define REPORT(retval) tokereport((I32)retval)
 163 #else
 164 #   define REPORT(retval) (retval)
 165 #endif
 166
 167 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
 168 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
 169 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
 170 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
 171 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
 172 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
 173 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
 174 #define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
 175 #define FTST(f)  return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
 176 #define FUN0(f)  return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
 177 #define FUN1(f)  return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
 178 #define BOop(f)  return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
 179 #define BAop(f)  return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
 180 #define SHop(f)  return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
 181 #define PWop(f)  return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
 182 #define PMop(f)  return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
 183 #define Aop(f)   return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
 184 #define Mop(f)   return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
 185 #define Eop(f)   return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
 186 #define Rop(f)   return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
 187
 188 /* This bit of chicanery makes a unary function followed by
 189  * a parenthesis into a function with one argument, highest precedence.
 190  * The UNIDOR macro is for unary functions that can be followed by the //
 191  * operator (such as C<shift // 0>).
 192  */
 193 #define UNI2(f,x) { \
 194         yylval.ival = f; \
 195         PL_expect = x; \
 196         PL_bufptr = s; \
 197         PL_last_uni = PL_oldbufptr; \
 198         PL_last_lop_op = f; \
 199         if (*s == '(') \
 200             return REPORT( (int)FUNC1 ); \
 201         s = PEEKSPACE(s); \
 202         return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
 203         }
 204 #define UNI(f)    UNI2(f,XTERM)
 205 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
 206
 207 #define UNIBRACK(f) { \
 208         yylval.ival = f; \
 209         PL_bufptr = s; \
 210         PL_last_uni = PL_oldbufptr; \
 211         if (*s == '(') \
 212             return REPORT( (int)FUNC1 ); \
 213         s = PEEKSPACE(s); \
 214         return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
 215         }
 216
 217 /* grandfather return to old style */
 218 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
 219
 220 #ifdef DEBUGGING
 221
 222 /* how to interpret the yylval associated with the token */
 223 enum token_type {
 224     TOKENTYPE_NONE,
 225     TOKENTYPE_IVAL,
 226     TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */
 227     TOKENTYPE_PVAL,
 228     TOKENTYPE_OPVAL,
 229     TOKENTYPE_GVVAL
 230 };
 231
 232 static struct debug_tokens {
 233     const int token;
 234     enum token_type type;
 235     const char *name;
 236 } const debug_tokens[] =
 237 {
 238     { ADDOP,            TOKENTYPE_OPNUM,        "ADDOP" },
 239     { ANDAND,           TOKENTYPE_NONE,         "ANDAND" },
 240     { ANDOP,            TOKENTYPE_NONE,         "ANDOP" },
 241     { ANONSUB,          TOKENTYPE_IVAL,         "ANONSUB" },
 242     { ARROW,            TOKENTYPE_NONE,         "ARROW" },
 243     { ASSIGNOP,         TOKENTYPE_OPNUM,        "ASSIGNOP" },
 244     { BITANDOP,         TOKENTYPE_OPNUM,        "BITANDOP" },
 245     { BITOROP,          TOKENTYPE_OPNUM,        "BITOROP" },
 246     { COLONATTR,        TOKENTYPE_NONE,         "COLONATTR" },
 247     { CONTINUE,         TOKENTYPE_NONE,         "CONTINUE" },
 248     { DEFAULT,          TOKENTYPE_NONE,         "DEFAULT" },
 249     { DO,               TOKENTYPE_NONE,         "DO" },
 250     { DOLSHARP,         TOKENTYPE_NONE,         "DOLSHARP" },
 251     { DORDOR,           TOKENTYPE_NONE,         "DORDOR" },
 252     { DOROP,            TOKENTYPE_OPNUM,        "DOROP" },
 253     { DOTDOT,           TOKENTYPE_IVAL,         "DOTDOT" },
 254     { ELSE,             TOKENTYPE_NONE,         "ELSE" },
 255     { ELSIF,            TOKENTYPE_IVAL,         "ELSIF" },
 256     { EQOP,             TOKENTYPE_OPNUM,        "EQOP" },
 257     { FOR,              TOKENTYPE_IVAL,         "FOR" },
 258     { FORMAT,           TOKENTYPE_NONE,         "FORMAT" },
 259     { FUNC,             TOKENTYPE_OPNUM,        "FUNC" },
 260     { FUNC0,            TOKENTYPE_OPNUM,        "FUNC0" },
 261     { FUNC0SUB,         TOKENTYPE_OPVAL,        "FUNC0SUB" },
 262     { FUNC1,            TOKENTYPE_OPNUM,        "FUNC1" },
 263     { FUNCMETH,         TOKENTYPE_OPVAL,        "FUNCMETH" },
 264     { GIVEN,            TOKENTYPE_IVAL,         "GIVEN" },
 265     { HASHBRACK,        TOKENTYPE_NONE,         "HASHBRACK" },
 266     { IF,               TOKENTYPE_IVAL,         "IF" },
 267     { LABEL,            TOKENTYPE_PVAL,         "LABEL" },
 268     { LOCAL,            TOKENTYPE_IVAL,         "LOCAL" },
 269     { LOOPEX,           TOKENTYPE_OPNUM,        "LOOPEX" },
 270     { LSTOP,            TOKENTYPE_OPNUM,        "LSTOP" },
 271     { LSTOPSUB,         TOKENTYPE_OPVAL,        "LSTOPSUB" },
 272     { MATCHOP,          TOKENTYPE_OPNUM,        "MATCHOP" },
 273     { METHOD,           TOKENTYPE_OPVAL,        "METHOD" },
 274     { MULOP,            TOKENTYPE_OPNUM,        "MULOP" },
 275     { MY,               TOKENTYPE_IVAL,         "MY" },
 276     { MYSUB,            TOKENTYPE_NONE,         "MYSUB" },
 277     { NOAMP,            TOKENTYPE_NONE,         "NOAMP" },
 278     { NOTOP,            TOKENTYPE_NONE,         "NOTOP" },
 279     { OROP,             TOKENTYPE_IVAL,         "OROP" },
 280     { OROR,             TOKENTYPE_NONE,         "OROR" },
 281     { PACKAGE,          TOKENTYPE_NONE,         "PACKAGE" },
 282     { PMFUNC,           TOKENTYPE_OPVAL,        "PMFUNC" },
 283     { POSTDEC,          TOKENTYPE_NONE,         "POSTDEC" },
 284     { POSTINC,          TOKENTYPE_NONE,         "POSTINC" },
 285     { POWOP,            TOKENTYPE_OPNUM,        "POWOP" },
 286     { PREDEC,           TOKENTYPE_NONE,         "PREDEC" },
 287     { PREINC,           TOKENTYPE_NONE,         "PREINC" },
 288     { PRIVATEREF,       TOKENTYPE_OPVAL,        "PRIVATEREF" },
 289     { REFGEN,           TOKENTYPE_NONE,         "REFGEN" },
 290     { RELOP,            TOKENTYPE_OPNUM,        "RELOP" },
 291     { SHIFTOP,          TOKENTYPE_OPNUM,        "SHIFTOP" },
 292     { SUB,              TOKENTYPE_NONE,         "SUB" },
 293     { THING,            TOKENTYPE_OPVAL,        "THING" },
 294     { UMINUS,           TOKENTYPE_NONE,         "UMINUS" },
 295     { UNIOP,            TOKENTYPE_OPNUM,        "UNIOP" },
 296     { UNIOPSUB,         TOKENTYPE_OPVAL,        "UNIOPSUB" },
 297     { UNLESS,           TOKENTYPE_IVAL,         "UNLESS" },
 298     { UNTIL,            TOKENTYPE_IVAL,         "UNTIL" },
 299     { USE,              TOKENTYPE_IVAL,         "USE" },
 300     { WHEN,             TOKENTYPE_IVAL,         "WHEN" },
 301     { WHILE,            TOKENTYPE_IVAL,         "WHILE" },
 302     { WORD,             TOKENTYPE_OPVAL,        "WORD" },
 303     { 0,                TOKENTYPE_NONE,         NULL }
 304 };
 305
 306 /* dump the returned token in rv, plus any optional arg in yylval */
 307
 308 STATIC int
 309 S_tokereport(pTHX_ I32 rv)
 310 {
 311     dVAR;
 312     if (DEBUG_T_TEST) {
 313         const char *name = NULL;
 314         enum token_type type = TOKENTYPE_NONE;
 315         const struct debug_tokens *p;
 316         SV* const report = newSVpvs("<== ");
 317
 318         for (p = debug_tokens; p->token; p++) {
 319             if (p->token == (int)rv) {
 320                 name = p->name;
 321                 type = p->type;
 322                 break;
 323             }
 324         }
 325         if (name)
 326             Perl_sv_catpv(aTHX_ report, name);
 327         else if ((char)rv > ' ' && (char)rv < '~')
 328             Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
 329         else if (!rv)
 330             sv_catpvs(report, "EOF");
 331         else
 332             Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
 333         switch (type) {
 334         case TOKENTYPE_NONE:
 335         case TOKENTYPE_GVVAL: /* doesn't appear to be used */
 336             break;
 337         case TOKENTYPE_IVAL:
 338             Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival);
 339             break;
 340         case TOKENTYPE_OPNUM:
 341             Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
 342                                     PL_op_name[yylval.ival]);
 343             break;
 344         case TOKENTYPE_PVAL:
 345             Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
 346             break;
 347         case TOKENTYPE_OPVAL:
 348             if (yylval.opval) {
 349                 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
 350                                     PL_op_name[yylval.opval->op_type]);
 351                 if (yylval.opval->op_type == OP_CONST) {
 352                     Perl_sv_catpvf(aTHX_ report, " %s",
 353                         SvPEEK(cSVOPx_sv(yylval.opval)));
 354                 }
 355
 356             }
 357             else
 358                 sv_catpvs(report, "(opval=null)");
 359             break;
 360         }
 361         PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
 362     };
 363     return (int)rv;
 364 }
 365
 366
 367 /* print the buffer with suitable escapes */
 368
 369 STATIC void
 370 S_printbuf(pTHX_ const char* fmt, const char* s)
 371 {
 372     SV* const tmp = newSVpvs("");
 373     PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
 374     SvREFCNT_dec(tmp);
 375 }
 376
 377 #endif
 378
 379 /*
 380  * S_ao
 381  *
 382  * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
 383  * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
 384  */
 385
 386 STATIC int
 387 S_ao(pTHX_ int toketype)
 388 {
 389     dVAR;
 390     if (*PL_bufptr == '=') {
 391         PL_bufptr++;
 392         if (toketype == ANDAND)
 393             yylval.ival = OP_ANDASSIGN;
 394         else if (toketype == OROR)
 395             yylval.ival = OP_ORASSIGN;
 396         else if (toketype == DORDOR)
 397             yylval.ival = OP_DORASSIGN;
 398         toketype = ASSIGNOP;
 399     }
 400     return toketype;
 401 }
 402
 403 /*
 404  * S_no_op
 405  * When Perl expects an operator and finds something else, no_op
 406  * prints the warning.  It always prints "<something> found where
 407  * operator expected.  It prints "Missing semicolon on previous line?"
 408  * if the surprise occurs at the start of the line.  "do you need to
 409  * predeclare ..." is printed out for code like "sub bar; foo bar $x"
 410  * where the compiler doesn't know if foo is a method call or a function.
 411  * It prints "Missing operator before end of line" if there's nothing
 412  * after the missing operator, or "... before <...>" if there is something
 413  * after the missing operator.
 414  */
 415
 416 STATIC void
 417 S_no_op(pTHX_ const char *what, char *s)
 418 {
 419     dVAR;
 420     char * const oldbp = PL_bufptr;
 421     const bool is_first = (PL_oldbufptr == PL_linestart);
 422
 423     if (!s)
 424         s = oldbp;
 425     else
 426         PL_bufptr = s;
 427     yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
 428     if (ckWARN_d(WARN_SYNTAX)) {
 429         if (is_first)
 430             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 431                     "\t(Missing semicolon on previous line?)\n");
 432         else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
 433             const char *t;
 434             for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
 435                 NOOP;
 436             if (t < PL_bufptr && isSPACE(*t))
 437                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 438                         "\t(Do you need to predeclare %.*s?)\n",
 439                     (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
 440         }
 441         else {
 442             assert(s >= oldbp);
 443             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 444                     "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
 445         }
 446     }
 447     PL_bufptr = oldbp;
 448 }
 449
 450 /*
 451  * S_missingterm
 452  * Complain about missing quote/regexp/heredoc terminator.
 453  * If it's called with NULL then it cauterizes the line buffer.
 454  * If we're in a delimited string and the delimiter is a control
 455  * character, it's reformatted into a two-char sequence like ^C.
 456  * This is fatal.
 457  */
 458
 459 STATIC void
 460 S_missingterm(pTHX_ char *s)
 461 {
 462     dVAR;
 463     char tmpbuf[3];
 464     char q;
 465     if (s) {
 466         char * const nl = strrchr(s,'\n');
 467         if (nl)
 468             *nl = '\0';
 469     }
 470     else if (
 471 #ifdef EBCDIC
 472         iscntrl(PL_multi_close)
 473 #else
 474         PL_multi_close < 32 || PL_multi_close == 127
 475 #endif
 476         ) {
 477         *tmpbuf = '^';
 478         tmpbuf[1] = (char)toCTRL(PL_multi_close);
 479         tmpbuf[2] = '\0';
 480         s = tmpbuf;
 481     }
 482     else {
 483         *tmpbuf = (char)PL_multi_close;
 484         tmpbuf[1] = '\0';
 485         s = tmpbuf;
 486     }
 487     q = strchr(s,'"') ? '\'' : '"';
 488     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
 489 }
 490
 491 #define FEATURE_IS_ENABLED(name)                                        \
 492         ((0 != (PL_hints & HINT_LOCALIZE_HH))                           \
 493             && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
 494 /*
 495  * S_feature_is_enabled
 496  * Check whether the named feature is enabled.
 497  */
 498 STATIC bool
 499 S_feature_is_enabled(pTHX_ const char *name, STRLEN namelen)
 500 {
 501     dVAR;
 502     HV * const hinthv = GvHV(PL_hintgv);
 503     char he_name[32] = "feature_";
 504     (void) my_strlcpy(&he_name[8], name, 24);
 505
 506     return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
 507 }
 508
 509 /*
 510  * Perl_deprecate
 511  */
 512
 513 void
 514 Perl_deprecate(pTHX_ const char *s)
 515 {
 516     if (ckWARN(WARN_DEPRECATED))
 517         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
 518 }
 519
 520 void
 521 Perl_deprecate_old(pTHX_ const char *s)
 522 {
 523     /* This function should NOT be called for any new deprecated warnings */
 524     /* Use Perl_deprecate instead                                         */
 525     /*                                                                    */
 526     /* It is here to maintain backward compatibility with the pre-5.8     */
 527     /* warnings category hierarchy. The "deprecated" category used to     */
 528     /* live under the "syntax" category. It is now a top-level category   */
 529     /* in its own right.                                                  */
 530
 531     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
 532         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 533                         "Use of %s is deprecated", s);
 534 }
 535
 536 /*
 537  * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
 538  * utf16-to-utf8-reversed.
 539  */
 540
 541 #ifdef PERL_CR_FILTER
 542 static void
 543 strip_return(SV *sv)
 544 {
 545     register const char *s = SvPVX_const(sv);
 546     register const char * const e = s + SvCUR(sv);
 547     /* outer loop optimized to do nothing if there are no CR-LFs */
 548     while (s < e) {
 549         if (*s++ == '\r' && *s == '\n') {
 550             /* hit a CR-LF, need to copy the rest */
 551             register char *d = s - 1;
 552             *d++ = *s++;
 553             while (s < e) {
 554                 if (*s == '\r' && s[1] == '\n')
 555                     s++;
 556                 *d++ = *s++;
 557             }
 558             SvCUR(sv) -= s - d;
 559             return;
 560         }
 561     }
 562 }
 563
 564 STATIC I32
 565 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 566 {
 567     const I32 count = FILTER_READ(idx+1, sv, maxlen);
 568     if (count > 0 && !maxlen)
 569         strip_return(sv);
 570     return count;
 571 }
 572 #endif
 573
 574 /*
 575  * Perl_lex_start
 576  * Initialize variables.  Uses the Perl save_stack to save its state (for
 577  * recursive calls to the parser).
 578  */
 579
 580 void
 581 Perl_lex_start(pTHX_ SV *line)
 582 {
 583     dVAR;
 584     const char *s;
 585     STRLEN len;
 586     yy_parser *parser;
 587
 588     /* create and initialise a parser */
 589
 590     Newx(parser, 1, yy_parser);
 591     parser->old_parser = PL_parser;
 592     PL_parser = parser;
 593
 594     Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
 595     parser->ps = parser->stack;
 596     parser->stack_size = YYINITDEPTH;
 597
 598     parser->stack->state = 0;
 599     parser->yyerrstatus = 0;
 600     parser->yychar = YYEMPTY;           /* Cause a token to be read.  */
 601
 602     /* initialise lexer state */
 603
 604     SAVEI32(PL_lex_dojoin);
 605     SAVEI32(PL_lex_brackets);
 606     SAVEI32(PL_lex_casemods);
 607     SAVEI32(PL_lex_starts);
 608     SAVEI32(PL_lex_state);
 609     SAVEVPTR(PL_lex_inpat);
 610     SAVEI32(PL_lex_inwhat);
 611 #ifdef PERL_MAD
 612     if (PL_lex_state == LEX_KNOWNEXT) {
 613         I32 toke = PL_lasttoke;
 614         while (--toke >= 0) {
 615             SAVEI32(PL_nexttoke[toke].next_type);
 616             SAVEVPTR(PL_nexttoke[toke].next_val);
 617             if (PL_madskills)
 618                 SAVEVPTR(PL_nexttoke[toke].next_mad);
 619         }
 620         SAVEI32(PL_lasttoke);
 621     }
 622     SAVESPTR(PL_endwhite);
 623     SAVESPTR(PL_thistoken);
 624     SAVESPTR(PL_thiswhite);
 625     SAVESPTR(PL_nextwhite);
 626     SAVESPTR(PL_thisopen);
 627     SAVESPTR(PL_thisclose);
 628     SAVESPTR(PL_thisstuff);
 629     SAVEVPTR(PL_thismad);
 630     SAVEI32(PL_realtokenstart);
 631     SAVEI32(PL_faketokens);
 632     SAVESPTR(PL_skipwhite);
 633     SAVEI32(PL_curforce);
 634 #else
 635     if (PL_lex_state == LEX_KNOWNEXT) {
 636         I32 toke = PL_nexttoke;
 637         while (--toke >= 0) {
 638             SAVEI32(PL_nexttype[toke]);
 639             SAVEVPTR(PL_nextval[toke]);
 640         }
 641         SAVEI32(PL_nexttoke);
 642     }
 643 #endif
 644     SAVECOPLINE(PL_curcop);
 645     SAVEPPTR(PL_bufptr);
 646     SAVEPPTR(PL_bufend);
 647     SAVEPPTR(PL_oldbufptr);
 648     SAVEPPTR(PL_oldoldbufptr);
 649     SAVEPPTR(PL_last_lop);
 650     SAVEPPTR(PL_last_uni);
 651     SAVEPPTR(PL_linestart);
 652     SAVESPTR(PL_linestr);
 653     SAVEGENERICPV(PL_lex_brackstack);
 654     SAVEGENERICPV(PL_lex_casestack);
 655     SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
 656     SAVESPTR(PL_lex_stuff);
 657     SAVEI32(PL_lex_defer);
 658     SAVEI32(PL_sublex_info.sub_inwhat);
 659     SAVEI32(PL_sublex_info.super_state);
 660     SAVEVPTR(PL_sublex_info.sub_op);
 661     SAVEPPTR(PL_sublex_info.super_bufptr);
 662     SAVEPPTR(PL_sublex_info.super_bufend);
 663     SAVESPTR(PL_lex_repl);
 664     SAVEINT(PL_expect);
 665     SAVEINT(PL_lex_expect);
 666     SAVEI32(PL_lex_formbrack);
 667     SAVEVPTR(PL_lex_op);
 668     SAVEI32(PL_multi_close);
 669     SAVEI32(PL_multi_open);
 670     SAVEI32(PL_multi_start);
 671     SAVEI8(PL_pending_ident);
 672     SAVEBOOL(PL_preambled);
 673
 674     PL_lex_state = LEX_NORMAL;
 675     PL_lex_defer = 0;
 676     PL_expect = XSTATE;
 677     PL_lex_brackets = 0;
 678     Newx(PL_lex_brackstack, 120, char);
 679     Newx(PL_lex_casestack, 12, char);
 680     PL_lex_casemods = 0;
 681     *PL_lex_casestack = '\0';
 682     PL_lex_dojoin = 0;
 683     PL_lex_starts = 0;
 684     PL_lex_stuff = NULL;
 685     PL_lex_repl = NULL;
 686     PL_lex_inpat = 0;
 687 #ifdef PERL_MAD
 688     PL_lasttoke = 0;
 689     PL_endwhite = NULL;
 690     PL_faketokens = 0;
 691     PL_nextwhite = NULL;
 692     PL_realtokenstart = 0;
 693     PL_skipwhite = NULL;
 694     PL_thisclose = NULL;
 695     PL_thisopen = NULL;
 696     PL_thisstuff = NULL;
 697     PL_thistoken = NULL;
 698     PL_thiswhite = NULL;
 699     PL_thismad = NULL;
 700 #else
 701     PL_nexttoke = 0;
 702 #endif
 703     PL_lex_inwhat = 0;
 704     PL_sublex_info.sub_inwhat = 0;
 705     PL_sublex_info.super_state = 0;
 706     PL_sublex_info.sub_op = NULL;
 707     PL_sublex_info.super_bufptr = NULL;
 708     PL_sublex_info.super_bufend = NULL;
 709     PL_lex_expect = 0;
 710     PL_lex_formbrack = 0;
 711     PL_lex_op = NULL;
 712     PL_multi_close = 0;
 713     PL_multi_open = 0;
 714     PL_multi_start = 0;
 715     PL_pending_ident = '\0';
 716     PL_preambled = FALSE;
 717
 718     if (line) {
 719         s = SvPV_const(line, len);
 720     } else {
 721         len = 0;
 722     }
 723     if (!len) {
 724         PL_linestr = newSVpvs("\n;");
 725     } else if (SvREADONLY(line) || s[len-1] != ';') {
 726         PL_linestr = newSVsv(line);
 727         if (s[len-1] != ';')
 728             sv_catpvs(PL_linestr, "\n;");
 729     } else {
 730         SvTEMP_off(line);
 731         SvREFCNT_inc_simple_void_NN(line);
 732         PL_linestr = line;
 733     }
 734     /* PL_linestr needs to survive until end of scope, not just the next
 735        FREETMPS. See changes 17505 and 17546 which fixed the symptoms only.  */
 736     SAVEFREESV(PL_linestr);
 737     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
 738     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
 739     PL_last_lop = PL_last_uni = NULL;
 740     PL_rsfp = 0;
 741 }
 742
 743 /*
 744  * Perl_lex_end
 745  * Finalizer for lexing operations.  Must be called when the parser is
 746  * done with the lexer.
 747  */
 748
 749 void
 750 Perl_lex_end(pTHX)
 751 {
 752     dVAR;
 753     PL_doextract = FALSE;
 754 }
 755
 756 /*
 757  * S_incline
 758  * This subroutine has nothing to do with tilting, whether at windmills
 759  * or pinball tables.  Its name is short for "increment line".  It
 760  * increments the current line number in CopLINE(PL_curcop) and checks
 761  * to see whether the line starts with a comment of the form
 762  *    # line 500 "foo.pm"
 763  * If so, it sets the current line number and file to the values in the comment.
 764  */
 765
 766 STATIC void
 767 S_incline(pTHX_ char *s)
 768 {
 769     dVAR;
 770     char *t;
 771     char *n;
 772     char *e;
 773     char ch;
 774
 775     CopLINE_inc(PL_curcop);
 776     if (*s++ != '#')
 777         return;
 778     while (SPACE_OR_TAB(*s))
 779         s++;
 780     if (strnEQ(s, "line", 4))
 781         s += 4;
 782     else
 783         return;
 784     if (SPACE_OR_TAB(*s))
 785         s++;
 786     else
 787         return;
 788     while (SPACE_OR_TAB(*s))
 789         s++;
 790     if (!isDIGIT(*s))
 791         return;
 792
 793     n = s;
 794     while (isDIGIT(*s))
 795         s++;
 796     while (SPACE_OR_TAB(*s))
 797         s++;
 798     if (*s == '"' && (t = strchr(s+1, '"'))) {
 799         s++;
 800         e = t + 1;
 801     }
 802     else {
 803         t = s;
 804         while (!isSPACE(*t))
 805             t++;
 806         e = t;
 807     }
 808     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
 809         e++;
 810     if (*e != '\n' && *e != '\0')
 811         return;         /* false alarm */
 812
 813     ch = *t;
 814     *t = '\0';
 815     if (t - s > 0) {
 816 #ifndef USE_ITHREADS
 817         const char * const cf = CopFILE(PL_curcop);
 818         STRLEN tmplen = cf ? strlen(cf) : 0;
 819         if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
 820             /* must copy *{"::_<(eval N)[oldfilename:L]"}
 821              * to *{"::_<newfilename"} */
 822             char smallbuf[256], smallbuf2[256];
 823             char *tmpbuf, *tmpbuf2;
 824             GV **gvp, *gv2;
 825             STRLEN tmplen2 = strlen(s);
 826             if (tmplen + 3 < sizeof smallbuf)
 827                 tmpbuf = smallbuf;
 828             else
 829                 Newx(tmpbuf, tmplen + 3, char);
 830             if (tmplen2 + 3 < sizeof smallbuf2)
 831                 tmpbuf2 = smallbuf2;
 832             else
 833                 Newx(tmpbuf2, tmplen2 + 3, char);
 834             tmpbuf[0] = tmpbuf2[0] = '_';
 835             tmpbuf[1] = tmpbuf2[1] = '<';
 836             memcpy(tmpbuf + 2, cf, ++tmplen);
 837             memcpy(tmpbuf2 + 2, s, ++tmplen2);
 838             ++tmplen; ++tmplen2;
 839             gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
 840             if (gvp) {
 841                 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
 842                 if (!isGV(gv2)) {
 843                     gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
 844                     /* adjust ${"::_<newfilename"} to store the new file name */
 845                     GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
 846                     GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
 847                     GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
 848                 }
 849             }
 850             if (tmpbuf != smallbuf) Safefree(tmpbuf);
 851             if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
 852         }
 853 #endif
 854         CopFILE_free(PL_curcop);
 855         CopFILE_set(PL_curcop, s);
 856     }
 857     *t = ch;
 858     CopLINE_set(PL_curcop, atoi(n)-1);
 859 }
 860
 861 #ifdef PERL_MAD
 862 /* skip space before PL_thistoken */
 863
 864 STATIC char *
 865 S_skipspace0(pTHX_ register char *s)
 866 {
 867     s = skipspace(s);
 868     if (!PL_madskills)
 869         return s;
 870     if (PL_skipwhite) {
 871         if (!PL_thiswhite)
 872             PL_thiswhite = newSVpvs("");
 873         sv_catsv(PL_thiswhite, PL_skipwhite);
 874         sv_free(PL_skipwhite);
 875         PL_skipwhite = 0;
 876     }
 877     PL_realtokenstart = s - SvPVX(PL_linestr);
 878     return s;
 879 }
 880
 881 /* skip space after PL_thistoken */
 882
 883 STATIC char *
 884 S_skipspace1(pTHX_ register char *s)
 885 {
 886     const char *start = s;
 887     I32 startoff = start - SvPVX(PL_linestr);
 888
 889     s = skipspace(s);
 890     if (!PL_madskills)
 891         return s;
 892     start = SvPVX(PL_linestr) + startoff;
 893     if (!PL_thistoken && PL_realtokenstart >= 0) {
 894         const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
 895         PL_thistoken = newSVpvn(tstart, start - tstart);
 896     }
 897     PL_realtokenstart = -1;
 898     if (PL_skipwhite) {
 899         if (!PL_nextwhite)
 900             PL_nextwhite = newSVpvs("");
 901         sv_catsv(PL_nextwhite, PL_skipwhite);
 902         sv_free(PL_skipwhite);
 903         PL_skipwhite = 0;
 904     }
 905     return s;
 906 }
 907
 908 STATIC char *
 909 S_skipspace2(pTHX_ register char *s, SV **svp)
 910 {
 911     char *start;
 912     const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
 913     const I32 startoff = s - SvPVX(PL_linestr);
 914
 915     s = skipspace(s);
 916     PL_bufptr = SvPVX(PL_linestr) + bufptroff;
 917     if (!PL_madskills || !svp)
 918         return s;
 919     start = SvPVX(PL_linestr) + startoff;
 920     if (!PL_thistoken && PL_realtokenstart >= 0) {
 921         char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
 922         PL_thistoken = newSVpvn(tstart, start - tstart);
 923         PL_realtokenstart = -1;
 924     }
 925     if (PL_skipwhite) {
 926         if (!*svp)
 927             *svp = newSVpvs("");
 928         sv_setsv(*svp, PL_skipwhite);
 929         sv_free(PL_skipwhite);
 930         PL_skipwhite = 0;
 931     }
 932
 933     return s;
 934 }
 935 #endif
 936
 937 STATIC void
 938 S_update_debugger_info_pv(pTHX_ const char *buf, STRLEN len)
 939 {
 940     AV *av = CopFILEAVx(PL_curcop);
 941     if (av) {
 942         SV * const sv = newSV(0);
 943         sv_upgrade(sv, SVt_PVMG);
 944         sv_setpvn(sv, buf, len);
 945         (void)SvIOK_on(sv);
 946         SvIV_set(sv, 0);
 947         av_store(av, (I32)CopLINE(PL_curcop), sv);
 948     }
 949 }
 950
 951 STATIC void
 952 S_update_debugger_info_sv(pTHX_ SV *orig_sv)
 953 {
 954     AV *av = CopFILEAVx(PL_curcop);
 955     if (av) {
 956         SV * const sv = newSV(0);
 957         sv_upgrade(sv, SVt_PVMG);
 958         sv_setsv(sv, orig_sv);
 959         (void)SvIOK_on(sv);
 960         SvIV_set(sv, 0);
 961         av_store(av, (I32)CopLINE(PL_curcop), sv);
 962     }
 963 }
 964
 965 /*
 966  * S_skipspace
 967  * Called to gobble the appropriate amount and type of whitespace.
 968  * Skips comments as well.
 969  */
 970
 971 STATIC char *
 972 S_skipspace(pTHX_ register char *s)
 973 {
 974     dVAR;
 975 #ifdef PERL_MAD
 976     int curoff;
 977     int startoff = s - SvPVX(PL_linestr);
 978
 979     if (PL_skipwhite) {
 980         sv_free(PL_skipwhite);
 981         PL_skipwhite = 0;
 982     }
 983 #endif
 984
 985     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
 986         while (s < PL_bufend && SPACE_OR_TAB(*s))
 987             s++;
 988 #ifdef PERL_MAD
 989         goto done;
 990 #else
 991         return s;
 992 #endif
 993     }
 994     for (;;) {
 995         STRLEN prevlen;
 996         SSize_t oldprevlen, oldoldprevlen;
 997         SSize_t oldloplen = 0, oldunilen = 0;
 998         while (s < PL_bufend && isSPACE(*s)) {
 999             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
1000                 incline(s);
1001         }
1002
1003         /* comment */
1004         if (s < PL_bufend && *s == '#') {
1005             while (s < PL_bufend && *s != '\n')
1006                 s++;
1007             if (s < PL_bufend) {
1008                 s++;
1009                 if (PL_in_eval && !PL_rsfp) {
1010                     incline(s);
1011                     continue;
1012                 }
1013             }
1014         }
1015
1016         /* only continue to recharge the buffer if we're at the end
1017          * of the buffer, we're not reading from a source filter, and
1018          * we're in normal lexing mode
1019          */
1020         if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
1021                 PL_lex_state == LEX_FORMLINE)
1022 #ifdef PERL_MAD
1023             goto done;
1024 #else
1025             return s;
1026 #endif
1027
1028         /* try to recharge the buffer */
1029 #ifdef PERL_MAD
1030         curoff = s - SvPVX(PL_linestr);
1031 #endif
1032
1033         if ((s = filter_gets(PL_linestr, PL_rsfp,
1034                              (prevlen = SvCUR(PL_linestr)))) == NULL)
1035         {
1036 #ifdef PERL_MAD
1037             if (PL_madskills && curoff != startoff) {
1038                 if (!PL_skipwhite)
1039                     PL_skipwhite = newSVpvs("");
1040                 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1041                                         curoff - startoff);
1042             }
1043
1044             /* mustn't throw out old stuff yet if madpropping */
1045             SvCUR(PL_linestr) = curoff;
1046             s = SvPVX(PL_linestr) + curoff;
1047             *s = 0;
1048             if (curoff && s[-1] == '\n')
1049                 s[-1] = ' ';
1050 #endif
1051
1052             /* end of file.  Add on the -p or -n magic */
1053             /* XXX these shouldn't really be added here, can't set PL_faketokens */
1054             if (PL_minus_p) {
1055 #ifdef PERL_MAD
1056                 sv_catpv(PL_linestr,
1057                          ";}continue{print or die qq(-p destination: $!\\n);}");
1058 #else
1059                 sv_setpv(PL_linestr,
1060                          ";}continue{print or die qq(-p destination: $!\\n);}");
1061 #endif
1062                 PL_minus_n = PL_minus_p = 0;
1063             }
1064             else if (PL_minus_n) {
1065 #ifdef PERL_MAD
1066                 sv_catpvn(PL_linestr, ";}", 2);
1067 #else
1068                 sv_setpvn(PL_linestr, ";}", 2);
1069 #endif
1070                 PL_minus_n = 0;
1071             }
1072             else
1073 #ifdef PERL_MAD
1074                 sv_catpvn(PL_linestr,";", 1);
1075 #else
1076                 sv_setpvn(PL_linestr,";", 1);
1077 #endif
1078
1079             /* reset variables for next time we lex */
1080             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
1081                 = SvPVX(PL_linestr)
1082 #ifdef PERL_MAD
1083                 + curoff
1084 #endif
1085                 ;
1086             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1087             PL_last_lop = PL_last_uni = NULL;
1088
1089             /* Close the filehandle.  Could be from -P preprocessor,
1090              * STDIN, or a regular file.  If we were reading code from
1091              * STDIN (because the commandline held no -e or filename)
1092              * then we don't close it, we reset it so the code can
1093              * read from STDIN too.
1094              */
1095
1096             if (PL_preprocess && !PL_in_eval)
1097                 (void)PerlProc_pclose(PL_rsfp);
1098             else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1099                 PerlIO_clearerr(PL_rsfp);
1100             else
1101                 (void)PerlIO_close(PL_rsfp);
1102             PL_rsfp = NULL;
1103             return s;
1104         }
1105
1106         /* not at end of file, so we only read another line */
1107         /* make corresponding updates to old pointers, for yyerror() */
1108         oldprevlen = PL_oldbufptr - PL_bufend;
1109         oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1110         if (PL_last_uni)
1111             oldunilen = PL_last_uni - PL_bufend;
1112         if (PL_last_lop)
1113             oldloplen = PL_last_lop - PL_bufend;
1114         PL_linestart = PL_bufptr = s + prevlen;
1115         PL_bufend = s + SvCUR(PL_linestr);
1116         s = PL_bufptr;
1117         PL_oldbufptr = s + oldprevlen;
1118         PL_oldoldbufptr = s + oldoldprevlen;
1119         if (PL_last_uni)
1120             PL_last_uni = s + oldunilen;
1121         if (PL_last_lop)
1122             PL_last_lop = s + oldloplen;
1123         incline(s);
1124
1125         /* debugger active and we're not compiling the debugger code,
1126          * so store the line into the debugger's array of lines
1127          */
1128         if (PERLDB_LINE && PL_curstash != PL_debstash)
1129             update_debugger_info_pv(PL_bufptr, PL_bufend - PL_bufptr);
1130     }
1131
1132 #ifdef PERL_MAD
1133   done:
1134     if (PL_madskills) {
1135         if (!PL_skipwhite)
1136             PL_skipwhite = newSVpvs("");
1137         curoff = s - SvPVX(PL_linestr);
1138         if (curoff - startoff)
1139             sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1140                                 curoff - startoff);
1141     }
1142     return s;
1143 #endif
1144 }
1145
1146 /*
1147  * S_check_uni
1148  * Check the unary operators to ensure there's no ambiguity in how they're
1149  * used.  An ambiguous piece of code would be:
1150  *     rand + 5
1151  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
1152  * the +5 is its argument.
1153  */
1154
1155 STATIC void
1156 S_check_uni(pTHX)
1157 {
1158     dVAR;
1159     const char *s;
1160     const char *t;
1161
1162     if (PL_oldoldbufptr != PL_last_uni)
1163         return;
1164     while (isSPACE(*PL_last_uni))
1165         PL_last_uni++;
1166     s = PL_last_uni;
1167     while (isALNUM_lazy_if(s,UTF) || *s == '-')
1168         s++;
1169     if ((t = strchr(s, '(')) && t < PL_bufptr)
1170         return;
1171
1172     if (ckWARN_d(WARN_AMBIGUOUS)){
1173         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
1174                    "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1175                    (int)(s - PL_last_uni), PL_last_uni);
1176     }
1177 }
1178
1179 /*
1180  * LOP : macro to build a list operator.  Its behaviour has been replaced
1181  * with a subroutine, S_lop() for which LOP is just another name.
1182  */
1183
1184 #define LOP(f,x) return lop(f,x,s)
1185
1186 /*
1187  * S_lop
1188  * Build a list operator (or something that might be one).  The rules:
1189  *  - if we have a next token, then it's a list operator [why?]
1190  *  - if the next thing is an opening paren, then it's a function
1191  *  - else it's a list operator
1192  */
1193
1194 STATIC I32
1195 S_lop(pTHX_ I32 f, int x, char *s)
1196 {
1197     dVAR;
1198     yylval.ival = f;
1199     CLINE;
1200     PL_expect = x;
1201     PL_bufptr = s;
1202     PL_last_lop = PL_oldbufptr;
1203     PL_last_lop_op = (OPCODE)f;
1204 #ifdef PERL_MAD
1205     if (PL_lasttoke)
1206         return REPORT(LSTOP);
1207 #else
1208     if (PL_nexttoke)
1209         return REPORT(LSTOP);
1210 #endif
1211     if (*s == '(')
1212         return REPORT(FUNC);
1213     s = PEEKSPACE(s);
1214     if (*s == '(')
1215         return REPORT(FUNC);
1216     else
1217         return REPORT(LSTOP);
1218 }
1219
1220 #ifdef PERL_MAD
1221  /*
1222  * S_start_force
1223  * Sets up for an eventual force_next().  start_force(0) basically does
1224  * an unshift, while start_force(-1) does a push.  yylex removes items
1225  * on the "pop" end.
1226  */
1227
1228 STATIC void
1229 S_start_force(pTHX_ int where)
1230 {
1231     int i;
1232
1233     if (where < 0)      /* so people can duplicate start_force(PL_curforce) */
1234         where = PL_lasttoke;
1235     assert(PL_curforce < 0 || PL_curforce == where);
1236     if (PL_curforce != where) {
1237         for (i = PL_lasttoke; i > where; --i) {
1238             PL_nexttoke[i] = PL_nexttoke[i-1];
1239         }
1240         PL_lasttoke++;
1241     }
1242     if (PL_curforce < 0)        /* in case of duplicate start_force() */
1243         Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1244     PL_curforce = where;
1245     if (PL_nextwhite) {
1246         if (PL_madskills)
1247             curmad('^', newSVpvs(""));
1248         CURMAD('_', PL_nextwhite);
1249     }
1250 }
1251
1252 STATIC void
1253 S_curmad(pTHX_ char slot, SV *sv)
1254 {
1255     MADPROP **where;
1256
1257     if (!sv)
1258         return;
1259     if (PL_curforce < 0)
1260         where = &PL_thismad;
1261     else
1262         where = &PL_nexttoke[PL_curforce].next_mad;
1263
1264     if (PL_faketokens)
1265         sv_setpvn(sv, "", 0);
1266     else {
1267         if (!IN_BYTES) {
1268             if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1269                 SvUTF8_on(sv);
1270             else if (PL_encoding) {
1271                 sv_recode_to_utf8(sv, PL_encoding);
1272             }
1273         }
1274     }
1275
1276     /* keep a slot open for the head of the list? */
1277     if (slot != '_' && *where && (*where)->mad_key == '^') {
1278         (*where)->mad_key = slot;
1279         sv_free((*where)->mad_val);
1280         (*where)->mad_val = (void*)sv;
1281     }
1282     else
1283         addmad(newMADsv(slot, sv), where, 0);
1284 }
1285 #else
1286 #  define start_force(where)    NOOP
1287 #  define curmad(slot, sv)      NOOP
1288 #endif
1289
1290 /*
1291  * S_force_next
1292  * When the lexer realizes it knows the next token (for instance,
1293  * it is reordering tokens for the parser) then it can call S_force_next
1294  * to know what token to return the next time the lexer is called.  Caller
1295  * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1296  * and possibly PL_expect to ensure the lexer handles the token correctly.
1297  */
1298
1299 STATIC void
1300 S_force_next(pTHX_ I32 type)
1301 {
1302     dVAR;
1303 #ifdef PERL_MAD
1304     if (PL_curforce < 0)
1305         start_force(PL_lasttoke);
1306     PL_nexttoke[PL_curforce].next_type = type;
1307     if (PL_lex_state != LEX_KNOWNEXT)
1308         PL_lex_defer = PL_lex_state;
1309     PL_lex_state = LEX_KNOWNEXT;
1310     PL_lex_expect = PL_expect;
1311     PL_curforce = -1;
1312 #else
1313     PL_nexttype[PL_nexttoke] = type;
1314     PL_nexttoke++;
1315     if (PL_lex_state != LEX_KNOWNEXT) {
1316         PL_lex_defer = PL_lex_state;
1317         PL_lex_expect = PL_expect;
1318         PL_lex_state = LEX_KNOWNEXT;
1319     }
1320 #endif
1321 }
1322
1323 STATIC SV *
1324 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
1325 {
1326     dVAR;
1327     SV * const sv = newSVpvn(start,len);
1328     if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
1329         SvUTF8_on(sv);
1330     return sv;
1331 }
1332
1333 /*
1334  * S_force_word
1335  * When the lexer knows the next thing is a word (for instance, it has
1336  * just seen -> and it knows that the next char is a word char, then
1337  * it calls S_force_word to stick the next word into the PL_nexttoke/val
1338  * lookahead.
1339  *
1340  * Arguments:
1341  *   char *start : buffer position (must be within PL_linestr)
1342  *   int token   : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1343  *   int check_keyword : if true, Perl checks to make sure the word isn't
1344  *       a keyword (do this if the word is a label, e.g. goto FOO)
1345  *   int allow_pack : if true, : characters will also be allowed (require,
1346  *       use, etc. do this)
1347  *   int allow_initial_tick : used by the "sub" lexer only.
1348  */
1349
1350 STATIC char *
1351 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1352 {
1353     dVAR;
1354     register char *s;
1355     STRLEN len;
1356
1357     start = SKIPSPACE1(start);
1358     s = start;
1359     if (isIDFIRST_lazy_if(s,UTF) ||
1360         (allow_pack && *s == ':') ||
1361         (allow_initial_tick && *s == '\'') )
1362     {
1363         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1364         if (check_keyword && keyword(PL_tokenbuf, len, 0))
1365             return start;
1366         start_force(PL_curforce);
1367         if (PL_madskills)
1368             curmad('X', newSVpvn(start,s-start));
1369         if (token == METHOD) {
1370             s = SKIPSPACE1(s);
1371             if (*s == '(')
1372                 PL_expect = XTERM;
1373             else {
1374                 PL_expect = XOPERATOR;
1375             }
1376         }
1377         NEXTVAL_NEXTTOKE.opval
1378             = (OP*)newSVOP(OP_CONST,0,
1379                            S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1380         NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1381         force_next(token);
1382     }
1383     return s;
1384 }
1385
1386 /*
1387  * S_force_ident
1388  * Called when the lexer wants $foo *foo &foo etc, but the program
1389  * text only contains the "foo" portion.  The first argument is a pointer
1390  * to the "foo", and the second argument is the type symbol to prefix.
1391  * Forces the next token to be a "WORD".
1392  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1393  */
1394
1395 STATIC void
1396 S_force_ident(pTHX_ register const char *s, int kind)
1397 {
1398     dVAR;
1399     if (*s) {
1400         const STRLEN len = strlen(s);
1401         OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1402         start_force(PL_curforce);
1403         NEXTVAL_NEXTTOKE.opval = o;
1404         force_next(WORD);
1405         if (kind) {
1406             o->op_private = OPpCONST_ENTERED;
1407             /* XXX see note in pp_entereval() for why we forgo typo
1408                warnings if the symbol must be introduced in an eval.
1409                GSAR 96-10-12 */
1410             gv_fetchpvn_flags(s, len,
1411                               PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1412                               : GV_ADD,
1413                               kind == '$' ? SVt_PV :
1414                               kind == '@' ? SVt_PVAV :
1415                               kind == '%' ? SVt_PVHV :
1416                               SVt_PVGV
1417                               );
1418         }
1419     }
1420 }
1421
1422 NV
1423 Perl_str_to_version(pTHX_ SV *sv)
1424 {
1425     NV retval = 0.0;
1426     NV nshift = 1.0;
1427     STRLEN len;
1428     const char *start = SvPV_const(sv,len);
1429     const char * const end = start + len;
1430     const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1431     while (start < end) {
1432         STRLEN skip;
1433         UV n;
1434         if (utf)
1435             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1436         else {
1437             n = *(U8*)start;
1438             skip = 1;
1439         }
1440         retval += ((NV)n)/nshift;
1441         start += skip;
1442         nshift *= 1000;
1443     }
1444     return retval;
1445 }
1446
1447 /*
1448  * S_force_version
1449  * Forces the next token to be a version number.
1450  * If the next token appears to be an invalid version number, (e.g. "v2b"),
1451  * and if "guessing" is TRUE, then no new token is created (and the caller
1452  * must use an alternative parsing method).
1453  */
1454
1455 STATIC char *
1456 S_force_version(pTHX_ char *s, int guessing)
1457 {
1458     dVAR;
1459     OP *version = NULL;
1460     char *d;
1461 #ifdef PERL_MAD
1462     I32 startoff = s - SvPVX(PL_linestr);
1463 #endif
1464
1465     s = SKIPSPACE1(s);
1466
1467     d = s;
1468     if (*d == 'v')
1469         d++;
1470     if (isDIGIT(*d)) {
1471         while (isDIGIT(*d) || *d == '_' || *d == '.')
1472             d++;
1473 #ifdef PERL_MAD
1474         if (PL_madskills) {
1475             start_force(PL_curforce);
1476             curmad('X', newSVpvn(s,d-s));
1477         }
1478 #endif
1479         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1480             SV *ver;
1481             s = scan_num(s, &yylval);
1482             version = yylval.opval;
1483             ver = cSVOPx(version)->op_sv;
1484             if (SvPOK(ver) && !SvNIOK(ver)) {
1485                 SvUPGRADE(ver, SVt_PVNV);
1486                 SvNV_set(ver, str_to_version(ver));
1487                 SvNOK_on(ver);          /* hint that it is a version */
1488             }
1489         }
1490         else if (guessing) {
1491 #ifdef PERL_MAD
1492             if (PL_madskills) {
1493                 sv_free(PL_nextwhite);  /* let next token collect whitespace */
1494                 PL_nextwhite = 0;
1495                 s = SvPVX(PL_linestr) + startoff;
1496             }
1497 #endif
1498             return s;
1499         }
1500     }
1501
1502 #ifdef PERL_MAD
1503     if (PL_madskills && !version) {
1504         sv_free(PL_nextwhite);  /* let next token collect whitespace */
1505         PL_nextwhite = 0;
1506         s = SvPVX(PL_linestr) + startoff;
1507     }
1508 #endif
1509     /* NOTE: The parser sees the package name and the VERSION swapped */
1510     start_force(PL_curforce);
1511     NEXTVAL_NEXTTOKE.opval = version;
1512     force_next(WORD);
1513
1514     return s;
1515 }
1516
1517 /*
1518  * S_tokeq
1519  * Tokenize a quoted string passed in as an SV.  It finds the next
1520  * chunk, up to end of string or a backslash.  It may make a new
1521  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
1522  * turns \\ into \.
1523  */
1524
1525 STATIC SV *
1526 S_tokeq(pTHX_ SV *sv)
1527 {
1528     dVAR;
1529     register char *s;
1530     register char *send;
1531     register char *d;
1532     STRLEN len = 0;
1533     SV *pv = sv;
1534
1535     if (!SvLEN(sv))
1536         goto finish;
1537
1538     s = SvPV_force(sv, len);
1539     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1540         goto finish;
1541     send = s + len;
1542     while (s < send && *s != '\\')
1543         s++;
1544     if (s == send)
1545         goto finish;
1546     d = s;
1547     if ( PL_hints & HINT_NEW_STRING ) {
1548         pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
1549         if (SvUTF8(sv))
1550             SvUTF8_on(pv);
1551     }
1552     while (s < send) {
1553         if (*s == '\\') {
1554             if (s + 1 < send && (s[1] == '\\'))
1555                 s++;            /* all that, just for this */
1556         }
1557         *d++ = *s++;
1558     }
1559     *d = '\0';
1560     SvCUR_set(sv, d - SvPVX_const(sv));
1561   finish:
1562     if ( PL_hints & HINT_NEW_STRING )
1563        return new_constant(NULL, 0, "q", sv, pv, "q");
1564     return sv;
1565 }
1566
1567 /*
1568  * Now come three functions related to double-quote context,
1569  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
1570  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
1571  * interact with PL_lex_state, and create fake ( ... ) argument lists
1572  * to handle functions and concatenation.
1573  * They assume that whoever calls them will be setting up a fake
1574  * join call, because each subthing puts a ',' after it.  This lets
1575  *   "lower \luPpEr"
1576  * become
1577  *  join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1578  *
1579  * (I'm not sure whether the spurious commas at the end of lcfirst's
1580  * arguments and join's arguments are created or not).
1581  */
1582
1583 /*
1584  * S_sublex_start
1585  * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1586  *
1587  * Pattern matching will set PL_lex_op to the pattern-matching op to
1588  * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1589  *
1590  * OP_CONST and OP_READLINE are easy--just make the new op and return.
1591  *
1592  * Everything else becomes a FUNC.
1593  *
1594  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1595  * had an OP_CONST or OP_READLINE).  This just sets us up for a
1596  * call to S_sublex_push().
1597  */
1598
1599 STATIC I32
1600 S_sublex_start(pTHX)
1601 {
1602     dVAR;
1603     register const I32 op_type = yylval.ival;
1604
1605     if (op_type == OP_NULL) {
1606         yylval.opval = PL_lex_op;
1607         PL_lex_op = NULL;
1608         return THING;
1609     }
1610     if (op_type == OP_CONST || op_type == OP_READLINE) {
1611         SV *sv = tokeq(PL_lex_stuff);
1612
1613         if (SvTYPE(sv) == SVt_PVIV) {
1614             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1615             STRLEN len;
1616             const char * const p = SvPV_const(sv, len);
1617             SV * const nsv = newSVpvn(p, len);
1618             if (SvUTF8(sv))
1619                 SvUTF8_on(nsv);
1620             SvREFCNT_dec(sv);
1621             sv = nsv;
1622         }
1623         yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1624         PL_lex_stuff = NULL;
1625         /* Allow <FH> // "foo" */
1626         if (op_type == OP_READLINE)
1627             PL_expect = XTERMORDORDOR;
1628         return THING;
1629     }
1630     else if (op_type == OP_BACKTICK && PL_lex_op) {
1631         /* readpipe() vas overriden */
1632         cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
1633         yylval.opval = PL_lex_op;
1634         PL_lex_op = NULL;
1635         PL_lex_stuff = NULL;
1636         return THING;
1637     }
1638
1639     PL_sublex_info.super_state = PL_lex_state;
1640     PL_sublex_info.sub_inwhat = op_type;
1641     PL_sublex_info.sub_op = PL_lex_op;
1642     PL_lex_state = LEX_INTERPPUSH;
1643
1644     PL_expect = XTERM;
1645     if (PL_lex_op) {
1646         yylval.opval = PL_lex_op;
1647         PL_lex_op = NULL;
1648         return PMFUNC;
1649     }
1650     else
1651         return FUNC;
1652 }
1653
1654 /*
1655  * S_sublex_push
1656  * Create a new scope to save the lexing state.  The scope will be
1657  * ended in S_sublex_done.  Returns a '(', starting the function arguments
1658  * to the uc, lc, etc. found before.
1659  * Sets PL_lex_state to LEX_INTERPCONCAT.
1660  */
1661
1662 STATIC I32
1663 S_sublex_push(pTHX)
1664 {
1665     dVAR;
1666     ENTER;
1667
1668     PL_lex_state = PL_sublex_info.super_state;
1669     SAVEI32(PL_lex_dojoin);
1670     SAVEI32(PL_lex_brackets);
1671     SAVEI32(PL_lex_casemods);
1672     SAVEI32(PL_lex_starts);
1673     SAVEI32(PL_lex_state);
1674     SAVEVPTR(PL_lex_inpat);
1675     SAVEI32(PL_lex_inwhat);
1676     SAVECOPLINE(PL_curcop);
1677     SAVEPPTR(PL_bufptr);
1678     SAVEPPTR(PL_bufend);
1679     SAVEPPTR(PL_oldbufptr);
1680     SAVEPPTR(PL_oldoldbufptr);
1681     SAVEPPTR(PL_last_lop);
1682     SAVEPPTR(PL_last_uni);
1683     SAVEPPTR(PL_linestart);
1684     SAVESPTR(PL_linestr);
1685     SAVEGENERICPV(PL_lex_brackstack);
1686     SAVEGENERICPV(PL_lex_casestack);
1687
1688     PL_linestr = PL_lex_stuff;
1689     PL_lex_stuff = NULL;
1690
1691     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1692         = SvPVX(PL_linestr);
1693     PL_bufend += SvCUR(PL_linestr);
1694     PL_last_lop = PL_last_uni = NULL;
1695     SAVEFREESV(PL_linestr);
1696
1697     PL_lex_dojoin = FALSE;
1698     PL_lex_brackets = 0;
1699     Newx(PL_lex_brackstack, 120, char);
1700     Newx(PL_lex_casestack, 12, char);
1701     PL_lex_casemods = 0;
1702     *PL_lex_casestack = '\0';
1703     PL_lex_starts = 0;
1704     PL_lex_state = LEX_INTERPCONCAT;
1705     CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1706
1707     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1708     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1709         PL_lex_inpat = PL_sublex_info.sub_op;
1710     else
1711         PL_lex_inpat = NULL;
1712
1713     return '(';
1714 }
1715
1716 /*
1717  * S_sublex_done
1718  * Restores lexer state after a S_sublex_push.
1719  */
1720
1721 STATIC I32
1722 S_sublex_done(pTHX)
1723 {
1724     dVAR;
1725     if (!PL_lex_starts++) {
1726         SV * const sv = newSVpvs("");
1727         if (SvUTF8(PL_linestr))
1728             SvUTF8_on(sv);
1729         PL_expect = XOPERATOR;
1730         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1731         return THING;
1732     }
1733
1734     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
1735         PL_lex_state = LEX_INTERPCASEMOD;
1736         return yylex();
1737     }
1738
1739     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1740     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1741         PL_linestr = PL_lex_repl;
1742         PL_lex_inpat = 0;
1743         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1744         PL_bufend += SvCUR(PL_linestr);
1745         PL_last_lop = PL_last_uni = NULL;
1746         SAVEFREESV(PL_linestr);
1747         PL_lex_dojoin = FALSE;
1748         PL_lex_brackets = 0;
1749         PL_lex_casemods = 0;
1750         *PL_lex_casestack = '\0';
1751         PL_lex_starts = 0;
1752         if (SvEVALED(PL_lex_repl)) {
1753             PL_lex_state = LEX_INTERPNORMAL;
1754             PL_lex_starts++;
1755             /*  we don't clear PL_lex_repl here, so that we can check later
1756                 whether this is an evalled subst; that means we rely on the
1757                 logic to ensure sublex_done() is called again only via the
1758                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1759         }
1760         else {
1761             PL_lex_state = LEX_INTERPCONCAT;
1762             PL_lex_repl = NULL;
1763         }
1764         return ',';
1765     }
1766     else {
1767 #ifdef PERL_MAD
1768         if (PL_madskills) {
1769             if (PL_thiswhite) {
1770                 if (!PL_endwhite)
1771                     PL_endwhite = newSVpvs("");
1772                 sv_catsv(PL_endwhite, PL_thiswhite);
1773                 PL_thiswhite = 0;
1774             }
1775             if (PL_thistoken)
1776                 sv_setpvn(PL_thistoken,"",0);
1777             else
1778                 PL_realtokenstart = -1;
1779         }
1780 #endif
1781         LEAVE;
1782         PL_bufend = SvPVX(PL_linestr);
1783         PL_bufend += SvCUR(PL_linestr);
1784         PL_expect = XOPERATOR;
1785         PL_sublex_info.sub_inwhat = 0;
1786         return ')';
1787     }
1788 }
1789
1790 /*
1791   scan_const
1792
1793   Extracts a pattern, double-quoted string, or transliteration.  This
1794   is terrifying code.
1795
1796   It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1797   processing a pattern (PL_lex_inpat is true), a transliteration
1798   (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1799
1800   Returns a pointer to the character scanned up to. If this is
1801   advanced from the start pointer supplied (i.e. if anything was
1802   successfully parsed), will leave an OP for the substring scanned
1803   in yylval. Caller must intuit reason for not parsing further
1804   by looking at the next characters herself.
1805
1806   In patterns:
1807     backslashes:
1808       double-quoted style: \r and \n
1809       regexp special ones: \D \s
1810       constants: \x31
1811       backrefs: \1
1812       case and quoting: \U \Q \E
1813     stops on @ and $, but not for $ as tail anchor
1814
1815   In transliterations:
1816     characters are VERY literal, except for - not at the start or end
1817     of the string, which indicates a range. If the range is in bytes,
1818     scan_const expands the range to the full set of intermediate
1819     characters. If the range is in utf8, the hyphen is replaced with
1820     a certain range mark which will be handled by pmtrans() in op.c.
1821
1822   In double-quoted strings:
1823     backslashes:
1824       double-quoted style: \r and \n
1825       constants: \x31
1826       deprecated backrefs: \1 (in substitution replacements)
1827       case and quoting: \U \Q \E
1828     stops on @ and $
1829
1830   scan_const does *not* construct ops to handle interpolated strings.
1831   It stops processing as soon as it finds an embedded $ or @ variable
1832   and leaves it to the caller to work out what's going on.
1833
1834   embedded arrays (whether in pattern or not) could be:
1835       @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1836
1837   $ in double-quoted strings must be the symbol of an embedded scalar.
1838
1839   $ in pattern could be $foo or could be tail anchor.  Assumption:
1840   it's a tail anchor if $ is the last thing in the string, or if it's
1841   followed by one of "()| \r\n\t"
1842
1843   \1 (backreferences) are turned into $1
1844
1845   The structure of the code is
1846       while (there's a character to process) {
1847           handle transliteration ranges
1848           skip regexp comments /(?#comment)/ and codes /(?{code})/
1849           skip #-initiated comments in //x patterns
1850           check for embedded arrays
1851           check for embedded scalars
1852           if (backslash) {
1853               leave intact backslashes from leaveit (below)
1854               deprecate \1 in substitution replacements
1855               handle string-changing backslashes \l \U \Q \E, etc.
1856               switch (what was escaped) {
1857                   handle \- in a transliteration (becomes a literal -)
1858                   handle \132 (octal characters)
1859                   handle \x15 and \x{1234} (hex characters)
1860                   handle \N{name} (named characters)
1861                   handle \cV (control characters)
1862                   handle printf-style backslashes (\f, \r, \n, etc)
1863               } (end switch)
1864           } (end if backslash)
1865     } (end while character to read)
1866
1867 */
1868
1869 STATIC char *
1870 S_scan_const(pTHX_ char *start)
1871 {
1872     dVAR;
1873     register char *send = PL_bufend;            /* end of the constant */
1874     SV *sv = newSV(send - start);               /* sv for the constant */
1875     register char *s = start;                   /* start of the constant */
1876     register char *d = SvPVX(sv);               /* destination for copies */
1877     bool dorange = FALSE;                       /* are we in a translit range? */
1878     bool didrange = FALSE;                      /* did we just finish a range? */
1879     I32  has_utf8 = FALSE;                      /* Output constant is UTF8 */
1880     I32  this_utf8 = UTF;                       /* The source string is assumed to be UTF8 */
1881     UV uv;
1882 #ifdef EBCDIC
1883     UV literal_endpoint = 0;
1884     bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1885 #endif
1886
1887     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1888         /* If we are doing a trans and we know we want UTF8 set expectation */
1889         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1890         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1891     }
1892
1893
1894     while (s < send || dorange) {
1895         /* get transliterations out of the way (they're most literal) */
1896         if (PL_lex_inwhat == OP_TRANS) {
1897             /* expand a range A-Z to the full set of characters.  AIE! */
1898             if (dorange) {
1899                 I32 i;                          /* current expanded character */
1900                 I32 min;                        /* first character in range */
1901                 I32 max;                        /* last character in range */
1902
1903 #ifdef EBCDIC
1904                 UV uvmax = 0;
1905 #endif
1906
1907                 if (has_utf8
1908 #ifdef EBCDIC
1909                     && !native_range
1910 #endif
1911                     ) {
1912                     char * const c = (char*)utf8_hop((U8*)d, -1);
1913                     char *e = d++;
1914                     while (e-- > c)
1915                         *(e + 1) = *e;
1916                     *c = (char)UTF_TO_NATIVE(0xff);
1917                     /* mark the range as done, and continue */
1918                     dorange = FALSE;
1919                     didrange = TRUE;
1920                     continue;
1921                 }
1922
1923                 i = d - SvPVX_const(sv);                /* remember current offset */
1924 #ifdef EBCDIC
1925                 SvGROW(sv,
1926                        SvLEN(sv) + (has_utf8 ?
1927                                     (512 - UTF_CONTINUATION_MARK +
1928                                      UNISKIP(0x100))
1929                                     : 256));
1930                 /* How many two-byte within 0..255: 128 in UTF-8,
1931                  * 96 in UTF-8-mod. */
1932 #else
1933                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
1934 #endif
1935                 d = SvPVX(sv) + i;              /* refresh d after realloc */
1936 #ifdef EBCDIC
1937                 if (has_utf8) {
1938                     int j;
1939                     for (j = 0; j <= 1; j++) {
1940                         char * const c = (char*)utf8_hop((U8*)d, -1);
1941                         const UV uv    = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
1942                         if (j)
1943                             min = (U8)uv;
1944                         else if (uv < 256)
1945                             max = (U8)uv;
1946                         else {
1947                             max = (U8)0xff; /* only to \xff */
1948                             uvmax = uv; /* \x{100} to uvmax */
1949                         }
1950                         d = c; /* eat endpoint chars */
1951                      }
1952                 }
1953                else {
1954 #endif
1955                    d -= 2;              /* eat the first char and the - */
1956                    min = (U8)*d;        /* first char in range */
1957                    max = (U8)d[1];      /* last char in range  */
1958 #ifdef EBCDIC
1959                }
1960 #endif
1961
1962                 if (min > max) {
1963                     Perl_croak(aTHX_
1964                                "Invalid range \"%c-%c\" in transliteration operator",
1965                                (char)min, (char)max);
1966                 }
1967
1968 #ifdef EBCDIC
1969                 if (literal_endpoint == 2 &&
1970                     ((isLOWER(min) && isLOWER(max)) ||
1971                      (isUPPER(min) && isUPPER(max)))) {
1972                     if (isLOWER(min)) {
1973                         for (i = min; i <= max; i++)
1974                             if (isLOWER(i))
1975                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1976                     } else {
1977                         for (i = min; i <= max; i++)
1978                             if (isUPPER(i))
1979                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1980                     }
1981                 }
1982                 else
1983 #endif
1984                     for (i = min; i <= max; i++)
1985 #ifdef EBCDIC
1986                         if (has_utf8) {
1987                             const U8 ch = (U8)NATIVE_TO_UTF(i);
1988                             if (UNI_IS_INVARIANT(ch))
1989                                 *d++ = (U8)i;
1990                             else {
1991                                 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
1992                                 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
1993                             }
1994                         }
1995                         else
1996 #endif
1997                             *d++ = (char)i;
1998
1999 #ifdef EBCDIC
2000                 if (uvmax) {
2001                     d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2002                     if (uvmax > 0x101)
2003                         *d++ = (char)UTF_TO_NATIVE(0xff);
2004                     if (uvmax > 0x100)
2005                         d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2006                 }
2007 #endif
2008
2009                 /* mark the range as done, and continue */
2010                 dorange = FALSE;
2011                 didrange = TRUE;
2012 #ifdef EBCDIC
2013                 literal_endpoint = 0;
2014 #endif
2015                 continue;
2016             }
2017
2018             /* range begins (ignore - as first or last char) */
2019             else if (*s == '-' && s+1 < send  && s != start) {
2020                 if (didrange) {
2021                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2022                 }
2023                 if (has_utf8
2024 #ifdef EBCDIC
2025                     && !native_range
2026 #endif
2027                     ) {
2028                     *d++ = (char)UTF_TO_NATIVE(0xff);   /* use illegal utf8 byte--see pmtrans */
2029                     s++;
2030                     continue;
2031                 }
2032                 dorange = TRUE;
2033                 s++;
2034             }
2035             else {
2036                 didrange = FALSE;
2037 #ifdef EBCDIC
2038                 literal_endpoint = 0;
2039                 native_range = TRUE;
2040 #endif
2041             }
2042         }
2043
2044         /* if we get here, we're not doing a transliteration */
2045
2046         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2047            except for the last char, which will be done separately. */
2048         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2049             if (s[2] == '#') {
2050                 while (s+1 < send && *s != ')')
2051                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2052             }
2053             else if (s[2] == '{' /* This should match regcomp.c */
2054                      || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
2055             {
2056                 I32 count = 1;
2057                 char *regparse = s + (s[2] == '{' ? 3 : 4);
2058                 char c;
2059
2060                 while (count && (c = *regparse)) {
2061                     if (c == '\\' && regparse[1])
2062                         regparse++;
2063                     else if (c == '{')
2064                         count++;
2065                     else if (c == '}')
2066                         count--;
2067                     regparse++;
2068                 }
2069                 if (*regparse != ')')
2070                     regparse--;         /* Leave one char for continuation. */
2071                 while (s < regparse)
2072                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2073             }
2074         }
2075
2076         /* likewise skip #-initiated comments in //x patterns */
2077         else if (*s == '#' && PL_lex_inpat &&
2078           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
2079             while (s+1 < send && *s != '\n')
2080                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2081         }
2082
2083         /* check for embedded arrays
2084            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2085            */
2086         else if (*s == '@' && s[1]) {
2087             if (isALNUM_lazy_if(s+1,UTF))
2088                 break;
2089             if (strchr(":'{$", s[1]))
2090                 break;
2091             if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2092                 break; /* in regexp, neither @+ nor @- are interpolated */
2093         }
2094
2095         /* check for embedded scalars.  only stop if we're sure it's a
2096            variable.
2097         */
2098         else if (*s == '$') {
2099             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
2100                 break;
2101             if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
2102                 break;          /* in regexp, $ might be tail anchor */
2103         }
2104
2105         /* End of else if chain - OP_TRANS rejoin rest */
2106
2107         /* backslashes */
2108         if (*s == '\\' && s+1 < send) {
2109             s++;
2110
2111             /* deprecate \1 in strings and substitution replacements */
2112             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2113                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2114             {
2115                 if (ckWARN(WARN_SYNTAX))
2116                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2117                 *--s = '$';
2118                 break;
2119             }
2120
2121             /* string-change backslash escapes */
2122             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2123                 --s;
2124                 break;
2125             }
2126             /* skip any other backslash escapes in a pattern */
2127             else if (PL_lex_inpat) {
2128                 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2129                 goto default_action;
2130             }
2131
2132             /* if we get here, it's either a quoted -, or a digit */
2133             switch (*s) {
2134
2135             /* quoted - in transliterations */
2136             case '-':
2137                 if (PL_lex_inwhat == OP_TRANS) {
2138                     *d++ = *s++;
2139                     continue;
2140                 }
2141                 /* FALL THROUGH */
2142             default:
2143                 {
2144                     if ((isALPHA(*s) || isDIGIT(*s)) &&
2145                         ckWARN(WARN_MISC))
2146                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2147                                     "Unrecognized escape \\%c passed through",
2148                                     *s);
2149                     /* default action is to copy the quoted character */
2150                     goto default_action;
2151                 }
2152
2153             /* \132 indicates an octal constant */
2154             case '0': case '1': case '2': case '3':
2155             case '4': case '5': case '6': case '7':
2156                 {
2157                     I32 flags = 0;
2158                     STRLEN len = 3;
2159                     uv = grok_oct(s, &len, &flags, NULL);
2160                     s += len;
2161                 }
2162                 goto NUM_ESCAPE_INSERT;
2163
2164             /* \x24 indicates a hex constant */
2165             case 'x':
2166                 ++s;
2167                 if (*s == '{') {
2168                     char* const e = strchr(s, '}');
2169                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2170                       PERL_SCAN_DISALLOW_PREFIX;
2171                     STRLEN len;
2172
2173                     ++s;
2174                     if (!e) {
2175                         yyerror("Missing right brace on \\x{}");
2176                         continue;
2177                     }
2178                     len = e - s;
2179                     uv = grok_hex(s, &len, &flags, NULL);
2180                     s = e + 1;
2181                 }
2182                 else {
2183                     {
2184                         STRLEN len = 2;
2185                         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2186                         uv = grok_hex(s, &len, &flags, NULL);
2187                         s += len;
2188                     }
2189                 }
2190
2191               NUM_ESCAPE_INSERT:
2192                 /* Insert oct or hex escaped character.
2193                  * There will always enough room in sv since such
2194                  * escapes will be longer than any UTF-8 sequence
2195                  * they can end up as. */
2196
2197                 /* We need to map to chars to ASCII before doing the tests
2198                    to cover EBCDIC
2199                 */
2200                 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
2201                     if (!has_utf8 && uv > 255) {
2202                         /* Might need to recode whatever we have
2203                          * accumulated so far if it contains any
2204                          * hibit chars.
2205                          *
2206                          * (Can't we keep track of that and avoid
2207                          *  this rescan? --jhi)
2208                          */
2209                         int hicount = 0;
2210                         U8 *c;
2211                         for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
2212                             if (!NATIVE_IS_INVARIANT(*c)) {
2213                                 hicount++;
2214                             }
2215                         }
2216                         if (hicount) {
2217                             const STRLEN offset = d - SvPVX_const(sv);
2218                             U8 *src, *dst;
2219                             d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
2220                             src = (U8 *)d - 1;
2221                             dst = src+hicount;
2222                             d  += hicount;
2223                             while (src >= (const U8 *)SvPVX_const(sv)) {
2224                                 if (!NATIVE_IS_INVARIANT(*src)) {
2225                                     const U8 ch = NATIVE_TO_ASCII(*src);
2226                                     *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
2227                                     *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
2228                                 }
2229                                 else {
2230                                     *dst-- = *src;
2231                                 }
2232                                 src--;
2233                             }
2234                         }
2235                     }
2236
2237                     if (has_utf8 || uv > 255) {
2238                         d = (char*)uvchr_to_utf8((U8*)d, uv);
2239                         has_utf8 = TRUE;
2240                         if (PL_lex_inwhat == OP_TRANS &&
2241                             PL_sublex_info.sub_op) {
2242                             PL_sublex_info.sub_op->op_private |=
2243                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
2244                                              : OPpTRANS_TO_UTF);
2245                         }
2246 #ifdef EBCDIC
2247                         if (uv > 255 && !dorange)
2248                             native_range = FALSE;
2249 #endif
2250                     }
2251                     else {
2252                         *d++ = (char)uv;
2253                     }
2254                 }
2255                 else {
2256                     *d++ = (char) uv;
2257                 }
2258                 continue;
2259
2260             /* \N{LATIN SMALL LETTER A} is a named character */
2261             case 'N':
2262                 ++s;
2263                 if (*s == '{') {
2264                     char* e = strchr(s, '}');
2265                     SV *res;
2266                     STRLEN len;
2267                     const char *str;
2268                     SV *type;
2269
2270                     if (!e) {
2271                         yyerror("Missing right brace on \\N{}");
2272                         e = s - 1;
2273                         goto cont_scan;
2274                     }
2275                     if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2276                         /* \N{U+...} */
2277                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2278                           PERL_SCAN_DISALLOW_PREFIX;
2279                         s += 3;
2280                         len = e - s;
2281                         uv = grok_hex(s, &len, &flags, NULL);
2282                         if ( e > s && len != (STRLEN)(e - s) ) {
2283                             uv = 0xFFFD;
2284                         }
2285                         s = e + 1;
2286                         goto NUM_ESCAPE_INSERT;
2287                     }
2288                     res = newSVpvn(s + 1, e - s - 1);
2289                     type = newSVpvn(s - 2,e - s + 3);
2290                     res = new_constant( NULL, 0, "charnames",
2291                                         res, NULL, SvPVX(type) );
2292                     SvREFCNT_dec(type);
2293                     if (has_utf8)
2294                         sv_utf8_upgrade(res);
2295                     str = SvPV_const(res,len);
2296 #ifdef EBCDIC_NEVER_MIND
2297                     /* charnames uses pack U and that has been
2298                      * recently changed to do the below uni->native
2299                      * mapping, so this would be redundant (and wrong,
2300                      * the code point would be doubly converted).
2301                      * But leave this in just in case the pack U change
2302                      * gets revoked, but the semantics is still
2303                      * desireable for charnames. --jhi */
2304                     {
2305                          UV uv = utf8_to_uvchr((const U8*)str, 0);
2306
2307                          if (uv < 0x100) {
2308                               U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2309
2310                               d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2311                               sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2312                               str = SvPV_const(res, len);
2313                          }
2314                     }
2315 #endif
2316                     if (!has_utf8 && SvUTF8(res)) {
2317                         const char * const ostart = SvPVX_const(sv);
2318                         SvCUR_set(sv, d - ostart);
2319                         SvPOK_on(sv);
2320                         *d = '\0';
2321                         sv_utf8_upgrade(sv);
2322                         /* this just broke our allocation above... */
2323                         SvGROW(sv, (STRLEN)(send - start));
2324                         d = SvPVX(sv) + SvCUR(sv);
2325                         has_utf8 = TRUE;
2326                     }
2327                     if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2328                         const char * const odest = SvPVX_const(sv);
2329
2330                         SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
2331                         d = SvPVX(sv) + (d - odest);
2332                     }
2333 #ifdef EBCDIC
2334                     if (!dorange)
2335                         native_range = FALSE; /* \N{} is guessed to be Unicode */
2336 #endif
2337                     Copy(str, d, len, char);
2338                     d += len;
2339                     SvREFCNT_dec(res);
2340                   cont_scan:
2341                     s = e + 1;
2342                 }
2343                 else
2344                     yyerror("Missing braces on \\N{}");
2345                 continue;
2346
2347             /* \c is a control character */
2348             case 'c':
2349                 s++;
2350                 if (s < send) {
2351                     U8 c = *s++;
2352 #ifdef EBCDIC
2353                     if (isLOWER(c))
2354                         c = toUPPER(c);
2355 #endif
2356                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2357                 }
2358                 else {
2359                     yyerror("Missing control char name in \\c");
2360                 }
2361                 continue;
2362
2363             /* printf-style backslashes, formfeeds, newlines, etc */
2364             case 'b':
2365                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2366                 break;
2367             case 'n':
2368                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2369                 break;
2370             case 'r':
2371                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2372                 break;
2373             case 'f':
2374                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2375                 break;
2376             case 't':
2377                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2378                 break;
2379             case 'e':
2380                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2381                 break;
2382             case 'a':
2383                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2384                 break;
2385             } /* end switch */
2386
2387             s++;
2388             continue;
2389         } /* end if (backslash) */
2390 #ifdef EBCDIC
2391         else
2392             literal_endpoint++;
2393 #endif
2394
2395     default_action:
2396         /* If we started with encoded form, or already know we want it
2397            and then encode the next character */
2398         if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
2399             STRLEN len  = 1;
2400             const UV nextuv   = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2401             const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2402             s += len;
2403             if (need > len) {
2404                 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
2405                 const STRLEN off = d - SvPVX_const(sv);
2406                 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
2407             }
2408             d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2409             has_utf8 = TRUE;
2410 #ifdef EBCDIC
2411             if (uv > 255 && !dorange)
2412                 native_range = FALSE;
2413 #endif
2414         }
2415         else {
2416             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2417         }
2418     } /* while loop to process each character */
2419
2420     /* terminate the string and set up the sv */
2421     *d = '\0';
2422     SvCUR_set(sv, d - SvPVX_const(sv));
2423     if (SvCUR(sv) >= SvLEN(sv))
2424         Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2425
2426     SvPOK_on(sv);
2427     if (PL_encoding && !has_utf8) {
2428         sv_recode_to_utf8(sv, PL_encoding);
2429         if (SvUTF8(sv))
2430             has_utf8 = TRUE;
2431     }
2432     if (has_utf8) {
2433         SvUTF8_on(sv);
2434         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2435             PL_sublex_info.sub_op->op_private |=
2436                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2437         }
2438     }
2439
2440     /* shrink the sv if we allocated more than we used */
2441     if (SvCUR(sv) + 5 < SvLEN(sv)) {
2442         SvPV_shrink_to_cur(sv);
2443     }
2444
2445     /* return the substring (via yylval) only if we parsed anything */
2446     if (s > PL_bufptr) {
2447         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
2448             sv = new_constant(start, s - start,
2449                               (const char *)(PL_lex_inpat ? "qr" : "q"),
2450                               sv, NULL,
2451                               (const char *)
2452                               (( PL_lex_inwhat == OP_TRANS
2453                                  ? "tr"
2454                                  : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
2455                                      ? "s"
2456                                      : "qq"))));
2457         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2458     } else
2459         SvREFCNT_dec(sv);
2460     return s;
2461 }
2462
2463 /* S_intuit_more
2464  * Returns TRUE if there's more to the expression (e.g., a subscript),
2465  * FALSE otherwise.
2466  *
2467  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2468  *
2469  * ->[ and ->{ return TRUE
2470  * { and [ outside a pattern are always subscripts, so return TRUE
2471  * if we're outside a pattern and it's not { or [, then return FALSE
2472  * if we're in a pattern and the first char is a {
2473  *   {4,5} (any digits around the comma) returns FALSE
2474  * if we're in a pattern and the first char is a [
2475  *   [] returns FALSE
2476  *   [SOMETHING] has a funky algorithm to decide whether it's a
2477  *      character class or not.  It has to deal with things like
2478  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2479  * anything else returns TRUE
2480  */
2481
2482 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2483
2484 STATIC int
2485 S_intuit_more(pTHX_ register char *s)
2486 {
2487     dVAR;
2488     if (PL_lex_brackets)
2489         return TRUE;
2490     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2491         return TRUE;
2492     if (*s != '{' && *s != '[')
2493         return FALSE;
2494     if (!PL_lex_inpat)
2495         return TRUE;
2496
2497     /* In a pattern, so maybe we have {n,m}. */
2498     if (*s == '{') {
2499         s++;
2500         if (!isDIGIT(*s))
2501             return TRUE;
2502         while (isDIGIT(*s))
2503             s++;
2504         if (*s == ',')
2505             s++;
2506         while (isDIGIT(*s))
2507             s++;
2508         if (*s == '}')
2509             return FALSE;
2510         return TRUE;
2511
2512     }
2513
2514     /* On the other hand, maybe we have a character class */
2515
2516     s++;
2517     if (*s == ']' || *s == '^')
2518         return FALSE;
2519     else {
2520         /* this is terrifying, and it works */
2521         int weight = 2;         /* let's weigh the evidence */
2522         char seen[256];
2523         unsigned char un_char = 255, last_un_char;
2524         const char * const send = strchr(s,']');
2525         char tmpbuf[sizeof PL_tokenbuf * 4];
2526
2527         if (!send)              /* has to be an expression */
2528             return TRUE;
2529
2530         Zero(seen,256,char);
2531         if (*s == '$')
2532             weight -= 3;
2533         else if (isDIGIT(*s)) {
2534             if (s[1] != ']') {
2535                 if (isDIGIT(s[1]) && s[2] == ']')
2536                     weight -= 10;
2537             }
2538             else
2539                 weight -= 100;
2540         }
2541         for (; s < send; s++) {
2542             last_un_char = un_char;
2543             un_char = (unsigned char)*s;
2544             switch (*s) {
2545             case '@':
2546             case '&':
2547             case '$':
2548                 weight -= seen[un_char] * 10;
2549                 if (isALNUM_lazy_if(s+1,UTF)) {
2550                     int len;
2551                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2552                     len = (int)strlen(tmpbuf);
2553                     if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2554                         weight -= 100;
2555                     else
2556                         weight -= 10;
2557                 }
2558                 else if (*s == '$' && s[1] &&
2559                   strchr("[#!%*<>()-=",s[1])) {
2560                     if (/*{*/ strchr("])} =",s[2]))
2561                         weight -= 10;
2562                     else
2563                         weight -= 1;
2564                 }
2565                 break;
2566             case '\\':
2567                 un_char = 254;
2568                 if (s[1]) {
2569                     if (strchr("wds]",s[1]))
2570                         weight += 100;
2571                     else if (seen[(U8)'\''] || seen[(U8)'"'])
2572                         weight += 1;
2573                     else if (strchr("rnftbxcav",s[1]))
2574                         weight += 40;
2575                     else if (isDIGIT(s[1])) {
2576                         weight += 40;
2577                         while (s[1] && isDIGIT(s[1]))
2578                             s++;
2579                     }
2580                 }
2581                 else
2582                     weight += 100;
2583                 break;
2584             case '-':
2585                 if (s[1] == '\\')
2586                     weight += 50;
2587                 if (strchr("aA01! ",last_un_char))
2588                     weight += 30;
2589                 if (strchr("zZ79~",s[1]))
2590                     weight += 30;
2591                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2592                     weight -= 5;        /* cope with negative subscript */
2593                 break;
2594             default:
2595                 if (!isALNUM(last_un_char)
2596                     && !(last_un_char == '$' || last_un_char == '@'
2597                          || last_un_char == '&')
2598                     && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2599                     char *d = tmpbuf;
2600                     while (isALPHA(*s))
2601                         *d++ = *s++;
2602                     *d = '\0';
2603                     if (keyword(tmpbuf, d - tmpbuf, 0))
2604                         weight -= 150;
2605                 }
2606                 if (un_char == last_un_char + 1)
2607                     weight += 5;
2608                 weight -= seen[un_char];
2609                 break;
2610             }
2611             seen[un_char]++;
2612         }
2613         if (weight >= 0)        /* probably a character class */
2614             return FALSE;
2615     }
2616
2617     return TRUE;
2618 }
2619
2620 /*
2621  * S_intuit_method
2622  *
2623  * Does all the checking to disambiguate
2624  *   foo bar
2625  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
2626  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2627  *
2628  * First argument is the stuff after the first token, e.g. "bar".
2629  *
2630  * Not a method if bar is a filehandle.
2631  * Not a method if foo is a subroutine prototyped to take a filehandle.
2632  * Not a method if it's really "Foo $bar"
2633  * Method if it's "foo $bar"
2634  * Not a method if it's really "print foo $bar"
2635  * Method if it's really "foo package::" (interpreted as package->foo)
2636  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2637  * Not a method if bar is a filehandle or package, but is quoted with
2638  *   =>
2639  */
2640
2641 STATIC int
2642 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2643 {
2644     dVAR;
2645     char *s = start + (*start == '$');
2646     char tmpbuf[sizeof PL_tokenbuf];
2647     STRLEN len;
2648     GV* indirgv;
2649 #ifdef PERL_MAD
2650     int soff;
2651 #endif
2652
2653     if (gv) {
2654         if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2655             return 0;
2656         if (cv) {
2657             if (SvPOK(cv)) {
2658                 const char *proto = SvPVX_const(cv);
2659                 if (proto) {
2660                     if (*proto == ';')
2661                         proto++;
2662                     if (*proto == '*')
2663                         return 0;
2664                 }
2665             }
2666         } else
2667             gv = NULL;
2668     }
2669     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2670     /* start is the beginning of the possible filehandle/object,
2671      * and s is the end of it
2672      * tmpbuf is a copy of it
2673      */
2674
2675     if (*start == '$') {
2676         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2677             return 0;
2678 #ifdef PERL_MAD
2679         len = start - SvPVX(PL_linestr);
2680 #endif
2681         s = PEEKSPACE(s);
2682 #ifdef PERL_MAD
2683         start = SvPVX(PL_linestr) + len;
2684 #endif
2685         PL_bufptr = start;
2686         PL_expect = XREF;
2687         return *s == '(' ? FUNCMETH : METHOD;
2688     }
2689     if (!keyword(tmpbuf, len, 0)) {
2690         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2691             len -= 2;
2692             tmpbuf[len] = '\0';
2693 #ifdef PERL_MAD
2694             soff = s - SvPVX(PL_linestr);
2695 #endif
2696             goto bare_package;
2697         }
2698         indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2699         if (indirgv && GvCVu(indirgv))
2700             return 0;
2701         /* filehandle or package name makes it a method */
2702         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2703 #ifdef PERL_MAD
2704             soff = s - SvPVX(PL_linestr);
2705 #endif
2706             s = PEEKSPACE(s);
2707             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2708                 return 0;       /* no assumptions -- "=>" quotes bearword */
2709       bare_package:
2710             start_force(PL_curforce);
2711             NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2712                                                    newSVpvn(tmpbuf,len));
2713             NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2714             if (PL_madskills)
2715                 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2716             PL_expect = XTERM;
2717             force_next(WORD);
2718             PL_bufptr = s;
2719 #ifdef PERL_MAD
2720             PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2721 #endif
2722             return *s == '(' ? FUNCMETH : METHOD;
2723         }
2724     }
2725     return 0;
2726 }
2727
2728 /*
2729  * S_incl_perldb
2730  * Return a string of Perl code to load the debugger.  If PERL5DB
2731  * is set, it will return the contents of that, otherwise a
2732  * compile-time require of perl5db.pl.
2733  */
2734
2735 STATIC const char*
2736 S_incl_perldb(pTHX)
2737 {
2738     dVAR;
2739     if (PL_perldb) {
2740         const char * const pdb = PerlEnv_getenv("PERL5DB");
2741
2742         if (pdb)
2743             return pdb;
2744         SETERRNO(0,SS_NORMAL);
2745         return "BEGIN { require 'perl5db.pl' }";
2746     }
2747     return "";
2748 }
2749
2750
2751 /* Encoded script support. filter_add() effectively inserts a
2752  * 'pre-processing' function into the current source input stream.
2753  * Note that the filter function only applies to the current source file
2754  * (e.g., it will not affect files 'require'd or 'use'd by this one).
2755  *
2756  * The datasv parameter (which may be NULL) can be used to pass
2757  * private data to this instance of the filter. The filter function
2758  * can recover the SV using the FILTER_DATA macro and use it to
2759  * store private buffers and state information.
2760  *
2761  * The supplied datasv parameter is upgraded to a PVIO type
2762  * and the IoDIRP/IoANY field is used to store the function pointer,
2763  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2764  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2765  * private use must be set using malloc'd pointers.
2766  */
2767
2768 SV *
2769 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2770 {
2771     dVAR;
2772     if (!funcp)
2773         return NULL;
2774
2775     if (!PL_rsfp_filters)
2776         PL_rsfp_filters = newAV();
2777     if (!datasv)
2778         datasv = newSV(0);
2779     SvUPGRADE(datasv, SVt_PVIO);
2780     IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2781     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2782     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2783                           FPTR2DPTR(void *, IoANY(datasv)),
2784                           SvPV_nolen(datasv)));
2785     av_unshift(PL_rsfp_filters, 1);
2786     av_store(PL_rsfp_filters, 0, datasv) ;
2787     return(datasv);
2788 }
2789
2790
2791 /* Delete most recently added instance of this filter function. */
2792 void
2793 Perl_filter_del(pTHX_ filter_t funcp)
2794 {
2795     dVAR;
2796     SV *datasv;
2797
2798 #ifdef DEBUGGING
2799     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2800                           FPTR2DPTR(void*, funcp)));
2801 #endif
2802     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2803         return;
2804     /* if filter is on top of stack (usual case) just pop it off */
2805     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2806     if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2807         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2808         IoANY(datasv) = (void *)NULL;
2809         sv_free(av_pop(PL_rsfp_filters));
2810
2811         return;
2812     }
2813     /* we need to search for the correct entry and clear it     */
2814     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2815 }
2816
2817
2818 /* Invoke the idxth filter function for the current rsfp.        */
2819 /* maxlen 0 = read one text line */
2820 I32
2821 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2822 {
2823     dVAR;
2824     filter_t funcp;
2825     SV *datasv = NULL;
2826     /* This API is bad. It should have been using unsigned int for maxlen.
2827        Not sure if we want to change the API, but if not we should sanity
2828        check the value here.  */
2829     const unsigned int correct_length
2830         = maxlen < 0 ?
2831 #ifdef PERL_MICRO
2832         0x7FFFFFFF
2833 #else
2834         INT_MAX
2835 #endif
2836         : maxlen;
2837
2838     if (!PL_rsfp_filters)
2839         return -1;
2840     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
2841         /* Provide a default input filter to make life easy.    */
2842         /* Note that we append to the line. This is handy.      */
2843         DEBUG_P(PerlIO_printf(Perl_debug_log,
2844                               "filter_read %d: from rsfp\n", idx));
2845         if (correct_length) {
2846             /* Want a block */
2847             int len ;
2848             const int old_len = SvCUR(buf_sv);
2849
2850             /* ensure buf_sv is large enough */
2851             SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2852             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2853                                    correct_length)) <= 0) {
2854                 if (PerlIO_error(PL_rsfp))
2855                     return -1;          /* error */
2856                 else
2857                     return 0 ;          /* end of file */
2858             }
2859             SvCUR_set(buf_sv, old_len + len) ;
2860         } else {
2861             /* Want a line */
2862             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2863                 if (PerlIO_error(PL_rsfp))
2864                     return -1;          /* error */
2865                 else
2866                     return 0 ;          /* end of file */
2867             }
2868         }
2869         return SvCUR(buf_sv);
2870     }
2871     /* Skip this filter slot if filter has been deleted */
2872     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2873         DEBUG_P(PerlIO_printf(Perl_debug_log,
2874                               "filter_read %d: skipped (filter deleted)\n",
2875                               idx));
2876         return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2877     }
2878     /* Get function pointer hidden within datasv        */
2879     funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2880     DEBUG_P(PerlIO_printf(Perl_debug_log,
2881                           "filter_read %d: via function %p (%s)\n",
2882                           idx, (void*)datasv, SvPV_nolen_const(datasv)));
2883     /* Call function. The function is expected to       */
2884     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2885     /* Return: <0:error, =0:eof, >0:not eof             */
2886     return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2887 }
2888
2889 STATIC char *
2890 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2891 {
2892     dVAR;
2893 #ifdef PERL_CR_FILTER
2894     if (!PL_rsfp_filters) {
2895         filter_add(S_cr_textfilter,NULL);
2896     }
2897 #endif
2898     if (PL_rsfp_filters) {
2899         if (!append)
2900             SvCUR_set(sv, 0);   /* start with empty line        */
2901         if (FILTER_READ(0, sv, 0) > 0)
2902             return ( SvPVX(sv) ) ;
2903         else
2904             return NULL ;
2905     }
2906     else
2907         return (sv_gets(sv, fp, append));
2908 }
2909
2910 STATIC HV *
2911 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2912 {
2913     dVAR;
2914     GV *gv;
2915
2916     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2917         return PL_curstash;
2918
2919     if (len > 2 &&
2920         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2921         (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
2922     {
2923         return GvHV(gv);                        /* Foo:: */
2924     }
2925
2926     /* use constant CLASS => 'MyClass' */
2927     gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
2928     if (gv && GvCV(gv)) {
2929         SV * const sv = cv_const_sv(GvCV(gv));
2930         if (sv)
2931             pkgname = SvPV_nolen_const(sv);
2932     }
2933
2934     return gv_stashpv(pkgname, FALSE);
2935 }
2936
2937 /*
2938  * S_readpipe_override
2939  * Check whether readpipe() is overriden, and generates the appropriate
2940  * optree, provided sublex_start() is called afterwards.
2941  */
2942 STATIC void
2943 S_readpipe_override(pTHX)
2944 {
2945     GV **gvp;
2946     GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
2947     yylval.ival = OP_BACKTICK;
2948     if ((gv_readpipe
2949                 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
2950             ||
2951             ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
2952              && (gv_readpipe = *gvp) != (GV*)&PL_sv_undef
2953              && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
2954     {
2955         PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
2956             append_elem(OP_LIST,
2957                 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
2958                 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
2959     }
2960     else {
2961         set_csh();
2962     }
2963 }
2964
2965 #ifdef PERL_MAD
2966  /*
2967  * Perl_madlex
2968  * The intent of this yylex wrapper is to minimize the changes to the
2969  * tokener when we aren't interested in collecting madprops.  It remains
2970  * to be seen how successful this strategy will be...
2971  */
2972
2973 int
2974 Perl_madlex(pTHX)
2975 {
2976     int optype;
2977     char *s = PL_bufptr;
2978
2979     /* make sure PL_thiswhite is initialized */
2980     PL_thiswhite = 0;
2981     PL_thismad = 0;
2982
2983     /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
2984     if (PL_pending_ident)
2985         return S_pending_ident(aTHX);
2986
2987     /* previous token ate up our whitespace? */
2988     if (!PL_lasttoke && PL_nextwhite) {
2989         PL_thiswhite = PL_nextwhite;
2990         PL_nextwhite = 0;
2991     }
2992
2993     /* isolate the token, and figure out where it is without whitespace */
2994     PL_realtokenstart = -1;
2995     PL_thistoken = 0;
2996     optype = yylex();
2997     s = PL_bufptr;
2998     assert(PL_curforce < 0);
2999
3000     if (!PL_thismad || PL_thismad->mad_key == '^') {    /* not forced already? */
3001         if (!PL_thistoken) {
3002             if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
3003                 PL_thistoken = newSVpvs("");
3004             else {
3005                 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
3006                 PL_thistoken = newSVpvn(tstart, s - tstart);
3007             }
3008         }
3009         if (PL_thismad) /* install head */
3010             CURMAD('X', PL_thistoken);
3011     }
3012
3013     /* last whitespace of a sublex? */
3014     if (optype == ')' && PL_endwhite) {
3015         CURMAD('X', PL_endwhite);
3016     }
3017
3018     if (!PL_thismad) {
3019
3020         /* if no whitespace and we're at EOF, bail.  Otherwise fake EOF below. */
3021         if (!PL_thiswhite && !PL_endwhite && !optype) {
3022             sv_free(PL_thistoken);
3023             PL_thistoken = 0;
3024             return 0;
3025         }
3026
3027         /* put off final whitespace till peg */
3028         if (optype == ';' && !PL_rsfp) {
3029             PL_nextwhite = PL_thiswhite;
3030             PL_thiswhite = 0;
3031         }
3032         else if (PL_thisopen) {
3033             CURMAD('q', PL_thisopen);
3034             if (PL_thistoken)
3035                 sv_free(PL_thistoken);
3036             PL_thistoken = 0;
3037         }
3038         else {
3039             /* Store actual token text as madprop X */
3040             CURMAD('X', PL_thistoken);
3041         }
3042
3043         if (PL_thiswhite) {
3044             /* add preceding whitespace as madprop _ */
3045             CURMAD('_', PL_thiswhite);
3046         }
3047
3048         if (PL_thisstuff) {
3049             /* add quoted material as madprop = */
3050             CURMAD('=', PL_thisstuff);
3051         }
3052
3053         if (PL_thisclose) {
3054             /* add terminating quote as madprop Q */
3055             CURMAD('Q', PL_thisclose);
3056         }
3057     }
3058
3059     /* special processing based on optype */
3060
3061     switch (optype) {
3062
3063     /* opval doesn't need a TOKEN since it can already store mp */
3064     case WORD:
3065     case METHOD:
3066     case FUNCMETH:
3067     case THING:
3068     case PMFUNC:
3069     case PRIVATEREF:
3070     case FUNC0SUB:
3071     case UNIOPSUB:
3072     case LSTOPSUB:
3073         if (yylval.opval)
3074             append_madprops(PL_thismad, yylval.opval, 0);
3075         PL_thismad = 0;
3076         return optype;
3077
3078     /* fake EOF */
3079     case 0:
3080         optype = PEG;
3081         if (PL_endwhite) {
3082             addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
3083             PL_endwhite = 0;
3084         }
3085         break;
3086
3087     case ']':
3088     case '}':
3089         if (PL_faketokens)
3090             break;
3091         /* remember any fake bracket that lexer is about to discard */
3092         if (PL_lex_brackets == 1 &&
3093             ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
3094         {
3095             s = PL_bufptr;
3096             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3097                 s++;
3098             if (*s == '}') {
3099                 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
3100                 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3101                 PL_thiswhite = 0;
3102                 PL_bufptr = s - 1;
3103                 break;  /* don't bother looking for trailing comment */
3104             }
3105             else
3106                 s = PL_bufptr;
3107         }
3108         if (optype == ']')
3109             break;
3110         /* FALLTHROUGH */
3111
3112     /* attach a trailing comment to its statement instead of next token */
3113     case ';':
3114         if (PL_faketokens)
3115             break;
3116         if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
3117             s = PL_bufptr;
3118             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3119                 s++;
3120             if (*s == '\n' || *s == '#') {
3121                 while (s < PL_bufend && *s != '\n')
3122                     s++;
3123                 if (s < PL_bufend)
3124                     s++;
3125                 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3126                 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3127                 PL_thiswhite = 0;
3128                 PL_bufptr = s;
3129             }
3130         }
3131         break;
3132
3133     /* pval */
3134     case LABEL:
3135         break;
3136
3137     /* ival */
3138     default:
3139         break;
3140
3141     }
3142
3143     /* Create new token struct.  Note: opvals return early above. */
3144     yylval.tkval = newTOKEN(optype, yylval, PL_thismad);
3145     PL_thismad = 0;
3146     return optype;
3147 }
3148 #endif
3149
3150 STATIC char *
3151 S_tokenize_use(pTHX_ int is_use, char *s) {
3152     dVAR;
3153     if (PL_expect != XSTATE)
3154         yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3155                     is_use ? "use" : "no"));
3156     s = SKIPSPACE1(s);
3157     if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3158         s = force_version(s, TRUE);
3159         if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3160             start_force(PL_curforce);
3161             NEXTVAL_NEXTTOKE.opval = NULL;
3162             force_next(WORD);
3163         }
3164         else if (*s == 'v') {
3165             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3166             s = force_version(s, FALSE);
3167         }
3168     }
3169     else {
3170         s = force_word(s,WORD,FALSE,TRUE,FALSE);
3171         s = force_version(s, FALSE);
3172     }
3173     yylval.ival = is_use;
3174     return s;
3175 }
3176 #ifdef DEBUGGING
3177     static const char* const exp_name[] =
3178         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3179           "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3180         };
3181 #endif
3182
3183 /*
3184   yylex
3185
3186   Works out what to call the token just pulled out of the input
3187   stream.  The yacc parser takes care of taking the ops we return and
3188   stitching them into a tree.
3189
3190   Returns:
3191     PRIVATEREF
3192
3193   Structure:
3194       if read an identifier
3195           if we're in a my declaration
3196               croak if they tried to say my($foo::bar)
3197               build the ops for a my() declaration
3198           if it's an access to a my() variable
3199               are we in a sort block?
3200                   croak if my($a); $a <=> $b
3201               build ops for access to a my() variable
3202           if in a dq string, and they've said @foo and we can't find @foo
3203               croak
3204           build ops for a bareword
3205       if we already built the token before, use it.
3206 */
3207
3208
3209 #ifdef __SC__
3210 #pragma segment Perl_yylex
3211 #endif
3212 int
3213 Perl_yylex(pTHX)
3214 {
3215     dVAR;
3216     register char *s = PL_bufptr;
3217     register char *d;
3218     STRLEN len;
3219     bool bof = FALSE;
3220
3221     /* orig_keyword, gvp, and gv are initialized here because
3222      * jump to the label just_a_word_zero can bypass their
3223      * initialization later. */
3224     I32 orig_keyword = 0;
3225     GV *gv = NULL;
3226     GV **gvp = NULL;
3227
3228     DEBUG_T( {
3229         SV* tmp = newSVpvs("");
3230         PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3231             (IV)CopLINE(PL_curcop),
3232             lex_state_names[PL_lex_state],
3233             exp_name[PL_expect],
3234             pv_display(tmp, s, strlen(s), 0, 60));
3235         SvREFCNT_dec(tmp);
3236     } );
3237     /* check if there's an identifier for us to look at */
3238     if (PL_pending_ident)
3239         return REPORT(S_pending_ident(aTHX));
3240
3241     /* no identifier pending identification */
3242
3243     switch (PL_lex_state) {
3244 #ifdef COMMENTARY
3245     case LEX_NORMAL:            /* Some compilers will produce faster */
3246     case LEX_INTERPNORMAL:      /* code if we comment these out. */
3247         break;
3248 #endif
3249
3250     /* when we've already built the next token, just pull it out of the queue */
3251     case LEX_KNOWNEXT:
3252 #ifdef PERL_MAD
3253         PL_lasttoke--;
3254         yylval = PL_nexttoke[PL_lasttoke].next_val;
3255         if (PL_madskills) {
3256             PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3257             PL_nexttoke[PL_lasttoke].next_mad = 0;
3258             if (PL_thismad && PL_thismad->mad_key == '_') {
3259                 PL_thiswhite = (SV*)PL_thismad->mad_val;
3260                 PL_thismad->mad_val = 0;
3261                 mad_free(PL_thismad);
3262                 PL_thismad = 0;
3263             }
3264         }
3265         if (!PL_lasttoke) {
3266             PL_lex_state = PL_lex_defer;
3267             PL_expect = PL_lex_expect;
3268             PL_lex_defer = LEX_NORMAL;
3269             if (!PL_nexttoke[PL_lasttoke].next_type)
3270                 return yylex();
3271         }
3272 #else
3273         PL_nexttoke--;
3274         yylval = PL_nextval[PL_nexttoke];
3275         if (!PL_nexttoke) {
3276             PL_lex_state = PL_lex_defer;
3277             PL_expect = PL_lex_expect;
3278             PL_lex_defer = LEX_NORMAL;
3279         }
3280 #endif
3281 #ifdef PERL_MAD
3282         /* FIXME - can these be merged?  */
3283         return(PL_nexttoke[PL_lasttoke].next_type);
3284 #else
3285         return REPORT(PL_nexttype[PL_nexttoke]);
3286 #endif
3287
3288     /* interpolated case modifiers like \L \U, including \Q and \E.
3289        when we get here, PL_bufptr is at the \
3290     */
3291     case LEX_INTERPCASEMOD:
3292 #ifdef DEBUGGING
3293         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3294             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3295 #endif
3296         /* handle \E or end of string */
3297         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3298             /* if at a \E */
3299             if (PL_lex_casemods) {
3300                 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3301                 PL_lex_casestack[PL_lex_casemods] = '\0';
3302
3303                 if (PL_bufptr != PL_bufend
3304                     && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3305                     PL_bufptr += 2;
3306                     PL_lex_state = LEX_INTERPCONCAT;
3307 #ifdef PERL_MAD
3308                     if (PL_madskills)
3309                         PL_thistoken = newSVpvs("\\E");
3310 #endif
3311                 }
3312                 return REPORT(')');
3313             }
3314 #ifdef PERL_MAD
3315             while (PL_bufptr != PL_bufend &&
3316               PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3317                 if (!PL_thiswhite)
3318                     PL_thiswhite = newSVpvs("");
3319                 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3320                 PL_bufptr += 2;
3321             }
3322 #else
3323             if (PL_bufptr != PL_bufend)
3324                 PL_bufptr += 2;
3325 #endif
3326             PL_lex_state = LEX_INTERPCONCAT;
3327             return yylex();
3328         }
3329         else {
3330             DEBUG_T({ PerlIO_printf(Perl_debug_log,
3331               "### Saw case modifier\n"); });
3332             s = PL_bufptr + 1;
3333             if (s[1] == '\\' && s[2] == 'E') {
3334 #ifdef PERL_MAD
3335                 if (!PL_thiswhite)
3336                     PL_thiswhite = newSVpvs("");
3337                 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3338 #endif
3339                 PL_bufptr = s + 3;
3340                 PL_lex_state = LEX_INTERPCONCAT;
3341                 return yylex();
3342             }
3343             else {
3344                 I32 tmp;
3345                 if (!PL_madskills) /* when just compiling don't need correct */
3346                     if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3347                         tmp = *s, *s = s[2], s[2] = (char)tmp;  /* misordered... */
3348                 if ((*s == 'L' || *s == 'U') &&
3349                     (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3350                     PL_lex_casestack[--PL_lex_casemods] = '\0';
3351                     return REPORT(')');
3352                 }
3353                 if (PL_lex_casemods > 10)
3354                     Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3355                 PL_lex_casestack[PL_lex_casemods++] = *s;
3356                 PL_lex_casestack[PL_lex_casemods] = '\0';
3357                 PL_lex_state = LEX_INTERPCONCAT;
3358                 start_force(PL_curforce);
3359                 NEXTVAL_NEXTTOKE.ival = 0;
3360                 force_next('(');
3361                 start_force(PL_curforce);
3362                 if (*s == 'l')
3363                     NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3364                 else if (*s == 'u')
3365                     NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3366                 else if (*s == 'L')
3367                     NEXTVAL_NEXTTOKE.ival = OP_LC;
3368                 else if (*s == 'U')
3369                     NEXTVAL_NEXTTOKE.ival = OP_UC;
3370                 else if (*s == 'Q')
3371                     NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3372                 else
3373                     Perl_croak(aTHX_ "panic: yylex");
3374                 if (PL_madskills) {
3375                     SV* const tmpsv = newSVpvs("");
3376                     Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
3377                     curmad('_', tmpsv);
3378                 }
3379                 PL_bufptr = s + 1;
3380             }
3381             force_next(FUNC);
3382             if (PL_lex_starts) {
3383                 s = PL_bufptr;
3384                 PL_lex_starts = 0;
3385 #ifdef PERL_MAD
3386                 if (PL_madskills) {
3387                     if (PL_thistoken)
3388                         sv_free(PL_thistoken);
3389                     PL_thistoken = newSVpvs("");
3390                 }
3391 #endif
3392                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3393                 if (PL_lex_casemods == 1 && PL_lex_inpat)
3394                     OPERATOR(',');
3395                 else
3396                     Aop(OP_CONCAT);
3397             }
3398             else
3399                 return yylex();
3400         }
3401
3402     case LEX_INTERPPUSH:
3403         return REPORT(sublex_push());
3404
3405     case LEX_INTERPSTART:
3406         if (PL_bufptr == PL_bufend)
3407             return REPORT(sublex_done());
3408         DEBUG_T({ PerlIO_printf(Perl_debug_log,
3409               "### Interpolated variable\n"); });
3410         PL_expect = XTERM;
3411         PL_lex_dojoin = (*PL_bufptr == '@');
3412         PL_lex_state = LEX_INTERPNORMAL;
3413         if (PL_lex_dojoin) {
3414             start_force(PL_curforce);
3415             NEXTVAL_NEXTTOKE.ival = 0;
3416             force_next(',');
3417             start_force(PL_curforce);
3418             force_ident("\"", '$');
3419             start_force(PL_curforce);
3420             NEXTVAL_NEXTTOKE.ival = 0;
3421             force_next('$');
3422             start_force(PL_curforce);
3423             NEXTVAL_NEXTTOKE.ival = 0;
3424             force_next('(');
3425             start_force(PL_curforce);
3426             NEXTVAL_NEXTTOKE.ival = OP_JOIN;    /* emulate join($", ...) */
3427             force_next(FUNC);
3428         }
3429         if (PL_lex_starts++) {
3430             s = PL_bufptr;
3431 #ifdef PERL_MAD
3432             if (PL_madskills) {
3433                 if (PL_thistoken)
3434                     sv_free(PL_thistoken);
3435                 PL_thistoken = newSVpvs("");
3436             }
3437 #endif
3438             /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3439             if (!PL_lex_casemods && PL_lex_inpat)
3440                 OPERATOR(',');
3441             else
3442                 Aop(OP_CONCAT);
3443         }
3444         return yylex();
3445
3446     case LEX_INTERPENDMAYBE:
3447         if (intuit_more(PL_bufptr)) {
3448             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
3449             break;
3450         }
3451         /* FALL THROUGH */
3452
3453     case LEX_INTERPEND:
3454         if (PL_lex_dojoin) {
3455             PL_lex_dojoin = FALSE;
3456             PL_lex_state = LEX_INTERPCONCAT;
3457 #ifdef PERL_MAD
3458             if (PL_madskills) {
3459                 if (PL_thistoken)
3460                     sv_free(PL_thistoken);
3461                 PL_thistoken = newSVpvs("");
3462             }
3463 #endif
3464             return REPORT(')');
3465         }
3466         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3467             && SvEVALED(PL_lex_repl))
3468         {
3469             if (PL_bufptr != PL_bufend)
3470                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3471             PL_lex_repl = NULL;
3472         }
3473         /* FALLTHROUGH */
3474     case LEX_INTERPCONCAT:
3475 #ifdef DEBUGGING
3476         if (PL_lex_brackets)
3477             Perl_croak(aTHX_ "panic: INTERPCONCAT");
3478 #endif
3479         if (PL_bufptr == PL_bufend)
3480             return REPORT(sublex_done());
3481
3482         if (SvIVX(PL_linestr) == '\'') {
3483             SV *sv = newSVsv(PL_linestr);
3484             if (!PL_lex_inpat)
3485                 sv = tokeq(sv);
3486             else if ( PL_hints & HINT_NEW_RE )
3487                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
3488             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3489             s = PL_bufend;
3490         }
3491         else {
3492             s = scan_const(PL_bufptr);
3493             if (*s == '\\')
3494                 PL_lex_state = LEX_INTERPCASEMOD;
3495             else
3496                 PL_lex_state = LEX_INTERPSTART;
3497         }
3498
3499         if (s != PL_bufptr) {
3500             start_force(PL_curforce);
3501             if (PL_madskills) {
3502                 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3503             }
3504             NEXTVAL_NEXTTOKE = yylval;
3505             PL_expect = XTERM;
3506             force_next(THING);
3507             if (PL_lex_starts++) {
3508 #ifdef PERL_MAD
3509                 if (PL_madskills) {
3510                     if (PL_thistoken)
3511                         sv_free(PL_thistoken);
3512                     PL_thistoken = newSVpvs("");
3513                 }
3514 #endif
3515                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3516                 if (!PL_lex_casemods && PL_lex_inpat)
3517                     OPERATOR(',');
3518                 else
3519                     Aop(OP_CONCAT);
3520             }
3521             else {
3522                 PL_bufptr = s;
3523                 return yylex();
3524             }
3525         }
3526
3527         return yylex();
3528     case LEX_FORMLINE:
3529         PL_lex_state = LEX_NORMAL;
3530         s = scan_formline(PL_bufptr);
3531         if (!PL_lex_formbrack)
3532             goto rightbracket;
3533         OPERATOR(';');
3534     }
3535
3536     s = PL_bufptr;
3537     PL_oldoldbufptr = PL_oldbufptr;
3538     PL_oldbufptr = s;
3539
3540   retry:
3541 #ifdef PERL_MAD
3542     if (PL_thistoken) {
3543         sv_free(PL_thistoken);
3544         PL_thistoken = 0;
3545     }
3546     PL_realtokenstart = s - SvPVX(PL_linestr);  /* assume but undo on ws */
3547 #endif
3548     switch (*s) {
3549     default:
3550         if (isIDFIRST_lazy_if(s,UTF))
3551             goto keylookup;
3552         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
3553     case 4:
3554     case 26:
3555         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
3556     case 0:
3557 #ifdef PERL_MAD
3558         if (PL_madskills)
3559             PL_faketokens = 0;
3560 #endif
3561         if (!PL_rsfp) {
3562             PL_last_uni = 0;
3563             PL_last_lop = 0;
3564             if (PL_lex_brackets) {
3565                 yyerror((const char *)
3566                         (PL_lex_formbrack
3567                          ? "Format not terminated"
3568                          : "Missing right curly or square bracket"));
3569             }
3570             DEBUG_T( { PerlIO_printf(Perl_debug_log,
3571                         "### Tokener got EOF\n");
3572             } );
3573             TOKEN(0);
3574         }
3575         if (s++ < PL_bufend)
3576             goto retry;                 /* ignore stray nulls */
3577         PL_last_uni = 0;
3578         PL_last_lop = 0;
3579         if (!PL_in_eval && !PL_preambled) {
3580             PL_preambled = TRUE;
3581 #ifdef PERL_MAD
3582             if (PL_madskills)
3583                 PL_faketokens = 1;
3584 #endif
3585             sv_setpv(PL_linestr,incl_perldb());
3586             if (SvCUR(PL_linestr))
3587                 sv_catpvs(PL_linestr,";");
3588             if (PL_preambleav){
3589                 while(AvFILLp(PL_preambleav) >= 0) {
3590                     SV *tmpsv = av_shift(PL_preambleav);
3591                     sv_catsv(PL_linestr, tmpsv);
3592                     sv_catpvs(PL_linestr, ";");
3593                     sv_free(tmpsv);
3594                 }
3595                 sv_free((SV*)PL_preambleav);
3596                 PL_preambleav = NULL;
3597             }
3598             if (PL_minus_n || PL_minus_p) {
3599                 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3600                 if (PL_minus_l)
3601                     sv_catpvs(PL_linestr,"chomp;");
3602                 if (PL_minus_a) {
3603                     if (PL_minus_F) {
3604                         if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3605                              || *PL_splitstr == '"')
3606                               && strchr(PL_splitstr + 1, *PL_splitstr))
3607                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3608                         else {
3609                             /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3610                                bytes can be used as quoting characters.  :-) */
3611                             const char *splits = PL_splitstr;
3612                             sv_catpvs(PL_linestr, "our @F=split(q\0");
3613                             do {
3614                                 /* Need to \ \s  */
3615                                 if (*splits == '\\')
3616                                     sv_catpvn(PL_linestr, splits, 1);
3617                                 sv_catpvn(PL_linestr, splits, 1);
3618                             } while (*splits++);
3619                             /* This loop will embed the trailing NUL of
3620                                PL_linestr as the last thing it does before
3621                                terminating.  */
3622                             sv_catpvs(PL_linestr, ");");
3623                         }
3624                     }
3625                     else
3626                         sv_catpvs(PL_linestr,"our @F=split(' ');");
3627                 }
3628             }
3629             if (PL_minus_E)
3630                 sv_catpvs(PL_linestr,"use feature ':5.10';");
3631             sv_catpvs(PL_linestr, "\n");
3632             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3633             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3634             PL_last_lop = PL_last_uni = NULL;
3635             if (PERLDB_LINE && PL_curstash != PL_debstash)
3636                 update_debugger_info_sv(PL_linestr);
3637             goto retry;
3638         }
3639         do {
3640             bof = PL_rsfp ? TRUE : FALSE;
3641             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3642               fake_eof:
3643 #ifdef PERL_MAD
3644                 PL_realtokenstart = -1;
3645 #endif
3646                 if (PL_rsfp) {
3647                     if (PL_preprocess && !PL_in_eval)
3648                         (void)PerlProc_pclose(PL_rsfp);
3649                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3650                         PerlIO_clearerr(PL_rsfp);
3651                     else
3652                         (void)PerlIO_close(PL_rsfp);
3653                     PL_rsfp = NULL;
3654                     PL_doextract = FALSE;
3655                 }
3656                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3657 #ifdef PERL_MAD
3658                     if (PL_madskills)
3659                         PL_faketokens = 1;
3660 #endif
3661                     sv_setpv(PL_linestr,
3662                              (const char *)
3663                              (PL_minus_p
3664                               ? ";}continue{print;}" : ";}"));
3665                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3666                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3667                     PL_last_lop = PL_last_uni = NULL;
3668                     PL_minus_n = PL_minus_p = 0;
3669                     goto retry;
3670                 }
3671                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3672                 PL_last_lop = PL_last_uni = NULL;
3673                 sv_setpvn(PL_linestr,"",0);
3674                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
3675             }
3676             /* If it looks like the start of a BOM or raw UTF-16,
3677              * check if it in fact is. */
3678             else if (bof &&
3679                      (*s == 0 ||
3680                       *(U8*)s == 0xEF ||
3681                       *(U8*)s >= 0xFE ||
3682                       s[1] == 0)) {
3683 #ifdef PERLIO_IS_STDIO
3684 #  ifdef __GNU_LIBRARY__
3685 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3686 #      define FTELL_FOR_PIPE_IS_BROKEN
3687 #    endif
3688 #  else
3689 #    ifdef __GLIBC__
3690 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3691 #        define FTELL_FOR_PIPE_IS_BROKEN
3692 #      endif
3693 #    endif
3694 #  endif
3695 #endif
3696 #ifdef FTELL_FOR_PIPE_IS_BROKEN
3697                 /* This loses the possibility to detect the bof
3698                  * situation on perl -P when the libc5 is being used.
3699                  * Workaround?  Maybe attach some extra state to PL_rsfp?
3700                  */
3701                 if (!PL_preprocess)
3702                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
3703 #else
3704                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3705 #endif
3706                 if (bof) {
3707                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3708                     s = swallow_bom((U8*)s);
3709                 }
3710             }
3711             if (PL_doextract) {
3712                 /* Incest with pod. */
3713 #ifdef PERL_MAD
3714                 if (PL_madskills)
3715                     sv_catsv(PL_thiswhite, PL_linestr);
3716 #endif
3717                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
3718                     sv_setpvn(PL_linestr, "", 0);
3719                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3720                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3721                     PL_last_lop = PL_last_uni = NULL;
3722                     PL_doextract = FALSE;
3723                 }
3724             }
3725             incline(s);
3726         } while (PL_doextract);
3727         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3728         if (PERLDB_LINE && PL_curstash != PL_debstash)
3729             update_debugger_info_sv(PL_linestr);
3730         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3731         PL_last_lop = PL_last_uni = NULL;
3732         if (CopLINE(PL_curcop) == 1) {
3733             while (s < PL_bufend && isSPACE(*s))
3734                 s++;
3735             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3736                 s++;
3737 #ifdef PERL_MAD
3738             if (PL_madskills)
3739                 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3740 #endif
3741             d = NULL;
3742             if (!PL_in_eval) {
3743                 if (*s == '#' && *(s+1) == '!')
3744                     d = s + 2;
3745 #ifdef ALTERNATE_SHEBANG
3746                 else {
3747                     static char const as[] = ALTERNATE_SHEBANG;
3748                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3749                         d = s + (sizeof(as) - 1);
3750                 }
3751 #endif /* ALTERNATE_SHEBANG */
3752             }
3753             if (d) {
3754                 char *ipath;
3755                 char *ipathend;
3756
3757                 while (isSPACE(*d))
3758                     d++;
3759                 ipath = d;
3760                 while (*d && !isSPACE(*d))
3761                     d++;
3762                 ipathend = d;
3763
3764 #ifdef ARG_ZERO_IS_SCRIPT
3765                 if (ipathend > ipath) {
3766                     /*
3767                      * HP-UX (at least) sets argv[0] to the script name,
3768                      * which makes $^X incorrect.  And Digital UNIX and Linux,
3769                      * at least, set argv[0] to the basename of the Perl
3770                      * interpreter. So, having found "#!", we'll set it right.
3771                      */
3772                     SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3773                                                     SVt_PV)); /* $^X */
3774                     assert(SvPOK(x) || SvGMAGICAL(x));
3775                     if (sv_eq(x, CopFILESV(PL_curcop))) {
3776                         sv_setpvn(x, ipath, ipathend - ipath);
3777                         SvSETMAGIC(x);
3778                     }
3779                     else {
3780                         STRLEN blen;
3781                         STRLEN llen;
3782                         const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3783                         const char * const lstart = SvPV_const(x,llen);
3784                         if (llen < blen) {
3785                             bstart += blen - llen;
3786                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3787                                 sv_setpvn(x, ipath, ipathend - ipath);
3788                                 SvSETMAGIC(x);
3789                             }
3790                         }
3791                     }
3792                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
3793                 }
3794 #endif /* ARG_ZERO_IS_SCRIPT */
3795
3796                 /*
3797                  * Look for options.
3798                  */
3799                 d = instr(s,"perl -");
3800                 if (!d) {
3801                     d = instr(s,"perl");
3802 #if defined(DOSISH)
3803                     /* avoid getting into infinite loops when shebang
3804                      * line contains "Perl" rather than "perl" */
3805                     if (!d) {
3806                         for (d = ipathend-4; d >= ipath; --d) {
3807                             if ((*d == 'p' || *d == 'P')
3808                                 && !ibcmp(d, "perl", 4))
3809                             {
3810                                 break;
3811                             }
3812                         }
3813                         if (d < ipath)
3814                             d = NULL;
3815                     }
3816 #endif
3817                 }
3818 #ifdef ALTERNATE_SHEBANG
3819                 /*
3820                  * If the ALTERNATE_SHEBANG on this system starts with a
3821                  * character that can be part of a Perl expression, then if
3822                  * we see it but not "perl", we're probably looking at the
3823                  * start of Perl code, not a request to hand off to some
3824                  * other interpreter.  Similarly, if "perl" is there, but
3825                  * not in the first 'word' of the line, we assume the line
3826                  * contains the start of the Perl program.
3827                  */
3828                 if (d && *s != '#') {
3829                     const char *c = ipath;
3830                     while (*c && !strchr("; \t\r\n\f\v#", *c))
3831                         c++;
3832                     if (c < d)
3833                         d = NULL;       /* "perl" not in first word; ignore */
3834                     else
3835                         *s = '#';       /* Don't try to parse shebang line */
3836                 }
3837 #endif /* ALTERNATE_SHEBANG */
3838 #ifndef MACOS_TRADITIONAL
3839                 if (!d &&
3840                     *s == '#' &&
3841                     ipathend > ipath &&
3842                     !PL_minus_c &&
3843                     !instr(s,"indir") &&
3844                     instr(PL_origargv[0],"perl"))
3845                 {
3846                     dVAR;
3847                     char **newargv;
3848
3849                     *ipathend = '\0';
3850                     s = ipathend + 1;
3851                     while (s < PL_bufend && isSPACE(*s))
3852                         s++;
3853                     if (s < PL_bufend) {
3854                         Newxz(newargv,PL_origargc+3,char*);
3855                         newargv[1] = s;
3856                         while (s < PL_bufend && !isSPACE(*s))
3857                             s++;
3858                         *s = '\0';
3859                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3860                     }
3861                     else
3862                         newargv = PL_origargv;
3863                     newargv[0] = ipath;
3864                     PERL_FPU_PRE_EXEC
3865                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3866                     PERL_FPU_POST_EXEC
3867                     Perl_croak(aTHX_ "Can't exec %s", ipath);
3868                 }
3869 #endif
3870                 if (d) {
3871                     while (*d && !isSPACE(*d))
3872                         d++;
3873                     while (SPACE_OR_TAB(*d))
3874                         d++;
3875
3876                     if (*d++ == '-') {
3877                         const bool switches_done = PL_doswitches;
3878                         const U32 oldpdb = PL_perldb;
3879                         const bool oldn = PL_minus_n;
3880                         const bool oldp = PL_minus_p;
3881
3882                         do {
3883                             if (*d == 'M' || *d == 'm' || *d == 'C') {
3884                                 const char * const m = d;
3885                                 while (*d && !isSPACE(*d))
3886                                     d++;
3887                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3888                                       (int)(d - m), m);
3889                             }
3890                             d = moreswitches(d);
3891                         } while (d);
3892                         if (PL_doswitches && !switches_done) {
3893                             int argc = PL_origargc;
3894                             char **argv = PL_origargv;
3895                             do {
3896                                 argc--,argv++;
3897                             } while (argc && argv[0][0] == '-' && argv[0][1]);
3898                             init_argv_symbols(argc,argv);
3899                         }
3900                         if ((PERLDB_LINE && !oldpdb) ||
3901                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
3902                               /* if we have already added "LINE: while (<>) {",
3903                                  we must not do it again */
3904                         {
3905                             sv_setpvn(PL_linestr, "", 0);
3906                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3907                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3908                             PL_last_lop = PL_last_uni = NULL;
3909                             PL_preambled = FALSE;
3910                             if (PERLDB_LINE)
3911                                 (void)gv_fetchfile(PL_origfilename);
3912                             goto retry;
3913                         }
3914                     }
3915                 }
3916             }
3917         }
3918         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3919             PL_bufptr = s;
3920             PL_lex_state = LEX_FORMLINE;
3921             return yylex();
3922         }
3923         goto retry;
3924     case '\r':
3925 #ifdef PERL_STRICT_CR
3926         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3927         Perl_croak(aTHX_
3928       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3929 #endif
3930     case ' ': case '\t': case '\f': case 013:
3931 #ifdef MACOS_TRADITIONAL
3932     case '\312':
3933 #endif
3934 #ifdef PERL_MAD
3935         PL_realtokenstart = -1;
3936         s = SKIPSPACE0(s);
3937 #else
3938         s++;
3939 #endif
3940         goto retry;
3941     case '#':
3942     case '\n':
3943 #ifdef PERL_MAD
3944         PL_realtokenstart = -1;
3945         if (PL_madskills)
3946             PL_faketokens = 0;
3947 #endif
3948         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3949             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3950                 /* handle eval qq[#line 1 "foo"\n ...] */
3951                 CopLINE_dec(PL_curcop);
3952                 incline(s);
3953             }
3954             if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
3955                 s = SKIPSPACE0(s);
3956                 if (!PL_in_eval || PL_rsfp)
3957                     incline(s);
3958             }
3959             else {
3960                 d = s;
3961                 while (d < PL_bufend && *d != '\n')
3962                     d++;
3963                 if (d < PL_bufend)
3964                     d++;
3965                 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3966                   Perl_croak(aTHX_ "panic: input overflow");
3967 #ifdef PERL_MAD
3968                 if (PL_madskills)
3969                     PL_thiswhite = newSVpvn(s, d - s);
3970 #endif
3971                 s = d;
3972                 incline(s);
3973             }
3974             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3975                 PL_bufptr = s;
3976                 PL_lex_state = LEX_FORMLINE;
3977                 return yylex();
3978             }
3979         }
3980         else {
3981 #ifdef PERL_MAD
3982             if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
3983                 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
3984                     PL_faketokens = 0;
3985                     s = SKIPSPACE0(s);
3986                     TOKEN(PEG); /* make sure any #! line is accessible */
3987                 }
3988                 s = SKIPSPACE0(s);
3989             }
3990             else {
3991 /*              if (PL_madskills && PL_lex_formbrack) { */
3992                     d = s;
3993                     while (d < PL_bufend && *d != '\n')
3994                         d++;
3995                     if (d < PL_bufend)
3996                         d++;
3997                     else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3998                       Perl_croak(aTHX_ "panic: input overflow");
3999                     if (PL_madskills && CopLINE(PL_curcop) >= 1) {
4000                         if (!PL_thiswhite)
4001                             PL_thiswhite = newSVpvs("");
4002                         if (CopLINE(PL_curcop) == 1) {
4003                             sv_setpvn(PL_thiswhite, "", 0);
4004                             PL_faketokens = 0;
4005                         }
4006                         sv_catpvn(PL_thiswhite, s, d - s);
4007                     }
4008                     s = d;
4009 /*              }
4010                 *s = '\0';
4011                 PL_bufend = s; */
4012             }
4013 #else
4014             *s = '\0';
4015             PL_bufend = s;
4016 #endif
4017         }
4018         goto retry;
4019     case '-':
4020         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
4021             I32 ftst = 0;
4022             char tmp;
4023
4024             s++;
4025             PL_bufptr = s;
4026             tmp = *s++;
4027
4028             while (s < PL_bufend && SPACE_OR_TAB(*s))
4029                 s++;
4030
4031             if (strnEQ(s,"=>",2)) {
4032                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
4033                 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
4034                 OPERATOR('-');          /* unary minus */
4035             }
4036             PL_last_uni = PL_oldbufptr;
4037             switch (tmp) {
4038             case 'r': ftst = OP_FTEREAD;        break;
4039             case 'w': ftst = OP_FTEWRITE;       break;
4040             case 'x': ftst = OP_FTEEXEC;        break;
4041             case 'o': ftst = OP_FTEOWNED;       break;
4042             case 'R': ftst = OP_FTRREAD;        break;
4043             case 'W': ftst = OP_FTRWRITE;       break;
4044             case 'X': ftst = OP_FTREXEC;        break;
4045             case 'O': ftst = OP_FTROWNED;       break;
4046             case 'e': ftst = OP_FTIS;           break;
4047             case 'z': ftst = OP_FTZERO;         break;
4048             case 's': ftst = OP_FTSIZE;         break;
4049             case 'f': ftst = OP_FTFILE;         break;
4050             case 'd': ftst = OP_FTDIR;          break;
4051             case 'l': ftst = OP_FTLINK;         break;
4052             case 'p': ftst = OP_FTPIPE;         break;
4053             case 'S': ftst = OP_FTSOCK;         break;
4054             case 'u': ftst = OP_FTSUID;         break;
4055             case 'g': ftst = OP_FTSGID;         break;
4056             case 'k': ftst = OP_FTSVTX;         break;
4057             case 'b': ftst = OP_FTBLK;          break;
4058             case 'c': ftst = OP_FTCHR;          break;
4059             case 't': ftst = OP_FTTTY;          break;
4060             case 'T': ftst = OP_FTTEXT;         break;
4061             case 'B': ftst = OP_FTBINARY;       break;
4062             case 'M': case 'A': case 'C':
4063                 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
4064                 switch (tmp) {
4065                 case 'M': ftst = OP_FTMTIME;    break;
4066                 case 'A': ftst = OP_FTATIME;    break;
4067                 case 'C': ftst = OP_FTCTIME;    break;
4068                 default:                        break;
4069                 }
4070                 break;
4071             default:
4072                 break;
4073             }
4074             if (ftst) {
4075                 PL_last_lop_op = (OPCODE)ftst;
4076                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4077                         "### Saw file test %c\n", (int)tmp);
4078                 } );
4079                 FTST(ftst);
4080             }
4081             else {
4082                 /* Assume it was a minus followed by a one-letter named
4083                  * subroutine call (or a -bareword), then. */
4084                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4085                         "### '-%c' looked like a file test but was not\n",
4086                         (int) tmp);
4087                 } );
4088                 s = --PL_bufptr;
4089             }
4090         }
4091         {
4092             const char tmp = *s++;
4093             if (*s == tmp) {
4094                 s++;
4095                 if (PL_expect == XOPERATOR)
4096                     TERM(POSTDEC);
4097                 else
4098                     OPERATOR(PREDEC);
4099             }
4100             else if (*s == '>') {
4101                 s++;
4102                 s = SKIPSPACE1(s);
4103                 if (isIDFIRST_lazy_if(s,UTF)) {
4104                     s = force_word(s,METHOD,FALSE,TRUE,FALSE);
4105                     TOKEN(ARROW);
4106                 }
4107                 else if (*s == '$')
4108                     OPERATOR(ARROW);
4109                 else
4110                     TERM(ARROW);
4111             }
4112             if (PL_expect == XOPERATOR)
4113                 Aop(OP_SUBTRACT);
4114             else {
4115                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4116                     check_uni();
4117                 OPERATOR('-');          /* unary minus */
4118             }
4119         }
4120
4121     case '+':
4122         {
4123             const char tmp = *s++;
4124             if (*s == tmp) {
4125                 s++;
4126                 if (PL_expect == XOPERATOR)
4127                     TERM(POSTINC);
4128                 else
4129                     OPERATOR(PREINC);
4130             }
4131             if (PL_expect == XOPERATOR)
4132                 Aop(OP_ADD);
4133             else {
4134                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4135                     check_uni();
4136                 OPERATOR('+');
4137             }
4138         }
4139
4140     case '*':
4141         if (PL_expect != XOPERATOR) {
4142             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4143             PL_expect = XOPERATOR;
4144             force_ident(PL_tokenbuf, '*');
4145             if (!*PL_tokenbuf)
4146                 PREREF('*');
4147             TERM('*');
4148         }
4149         s++;
4150         if (*s == '*') {
4151             s++;
4152             PWop(OP_POW);
4153         }
4154         Mop(OP_MULTIPLY);
4155
4156     case '%':
4157         if (PL_expect == XOPERATOR) {
4158             ++s;
4159             Mop(OP_MODULO);
4160         }
4161         PL_tokenbuf[0] = '%';
4162         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
4163         if (!PL_tokenbuf[1]) {
4164             PREREF('%');
4165         }
4166         PL_pending_ident = '%';
4167         TERM('%');
4168
4169     case '^':
4170         s++;
4171         BOop(OP_BIT_XOR);
4172     case '[':
4173         PL_lex_brackets++;
4174         /* FALL THROUGH */
4175     case '~':
4176         if (s[1] == '~'
4177         && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)
4178         && FEATURE_IS_ENABLED("~~"))
4179         {
4180             s += 2;
4181             Eop(OP_SMARTMATCH);
4182         }
4183     case ',':
4184         {
4185             const char tmp = *s++;
4186             OPERATOR(tmp);
4187         }
4188     case ':':
4189         if (s[1] == ':') {
4190             len = 0;
4191             goto just_a_word_zero_gv;
4192         }
4193         s++;
4194         switch (PL_expect) {
4195             OP *attrs;
4196 #ifdef PERL_MAD
4197             I32 stuffstart;
4198 #endif
4199         case XOPERATOR:
4200             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4201                 break;
4202             PL_bufptr = s;      /* update in case we back off */
4203             goto grabattrs;
4204         case XATTRBLOCK:
4205             PL_expect = XBLOCK;
4206             goto grabattrs;
4207         case XATTRTERM:
4208             PL_expect = XTERMBLOCK;
4209          grabattrs:
4210 #ifdef PERL_MAD
4211             stuffstart = s - SvPVX(PL_linestr) - 1;
4212 #endif
4213             s = PEEKSPACE(s);
4214             attrs = NULL;
4215             while (isIDFIRST_lazy_if(s,UTF)) {
4216                 I32 tmp;
4217                 SV *sv;
4218                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4219                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4220                     if (tmp < 0) tmp = -tmp;
4221                     switch (tmp) {
4222                     case KEY_or:
4223                     case KEY_and:
4224                     case KEY_err:
4225                     case KEY_for:
4226                     case KEY_unless:
4227                     case KEY_if:
4228                     case KEY_while:
4229                     case KEY_until:
4230                         goto got_attrs;
4231                     default:
4232                         break;
4233                     }
4234                 }
4235                 sv = newSVpvn(s, len);
4236                 if (*d == '(') {
4237                     d = scan_str(d,TRUE,TRUE);
4238                     if (!d) {
4239                         /* MUST advance bufptr here to avoid bogus
4240                            "at end of line" context messages from yyerror().
4241                          */
4242                         PL_bufptr = s + len;
4243                         yyerror("Unterminated attribute parameter in attribute list");
4244                         if (attrs)
4245                             op_free(attrs);
4246                         sv_free(sv);
4247                         return REPORT(0);       /* EOF indicator */
4248                     }
4249                 }
4250                 if (PL_lex_stuff) {
4251                     sv_catsv(sv, PL_lex_stuff);
4252                     attrs = append_elem(OP_LIST, attrs,
4253                                         newSVOP(OP_CONST, 0, sv));
4254                     SvREFCNT_dec(PL_lex_stuff);
4255                     PL_lex_stuff = NULL;
4256                 }
4257                 else {
4258                     if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4259                         sv_free(sv);
4260                         if (PL_in_my == KEY_our) {
4261 #ifdef USE_ITHREADS
4262                             GvUNIQUE_on(cGVOPx_gv(yylval.opval));
4263 #else
4264                             /* skip to avoid loading attributes.pm */
4265 #endif
4266                             deprecate(":unique");
4267                         }
4268                         else
4269                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4270                     }
4271
4272                     /* NOTE: any CV attrs applied here need to be part of
4273                        the CVf_BUILTIN_ATTRS define in cv.h! */
4274                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4275                         sv_free(sv);
4276                         CvLVALUE_on(PL_compcv);
4277                     }
4278                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4279                         sv_free(sv);
4280                         CvLOCKED_on(PL_compcv);
4281                     }
4282                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4283                         sv_free(sv);
4284                         CvMETHOD_on(PL_compcv);
4285                     }
4286                     else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) {
4287                         sv_free(sv);
4288                         CvASSERTION_on(PL_compcv);
4289                     }
4290                     /* After we've set the flags, it could be argued that
4291                        we don't need to do the attributes.pm-based setting
4292                        process, and shouldn't bother appending recognized
4293                        flags.  To experiment with that, uncomment the
4294                        following "else".  (Note that's already been
4295                        uncommented.  That keeps the above-applied built-in
4296                        attributes from being intercepted (and possibly
4297                        rejected) by a package's attribute routines, but is
4298                        justified by the performance win for the common case
4299                        of applying only built-in attributes.) */
4300                     else
4301                         attrs = append_elem(OP_LIST, attrs,
4302                                             newSVOP(OP_CONST, 0,
4303                                                     sv));
4304                 }
4305                 s = PEEKSPACE(d);
4306                 if (*s == ':' && s[1] != ':')
4307                     s = PEEKSPACE(s+1);
4308                 else if (s == d)
4309                     break;      /* require real whitespace or :'s */
4310                 /* XXX losing whitespace on sequential attributes here */
4311             }
4312             {
4313                 const char tmp
4314                     = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4315                 if (*s != ';' && *s != '}' && *s != tmp
4316                     && (tmp != '=' || *s != ')')) {
4317                     const char q = ((*s == '\'') ? '"' : '\'');
4318                     /* If here for an expression, and parsed no attrs, back
4319                        off. */
4320                     if (tmp == '=' && !attrs) {
4321                         s = PL_bufptr;
4322                         break;
4323                     }
4324                     /* MUST advance bufptr here to avoid bogus "at end of line"
4325                        context messages from yyerror().
4326                     */
4327                     PL_bufptr = s;
4328                     yyerror( (const char *)
4329                              (*s
4330                               ? Perl_form(aTHX_ "Invalid separator character "
4331                                           "%c%c%c in attribute list", q, *s, q)
4332                               : "Unterminated attribute list" ) );
4333                     if (attrs)
4334                         op_free(attrs);
4335                     OPERATOR(':');
4336                 }
4337             }
4338         got_attrs:
4339             if (attrs) {
4340                 start_force(PL_curforce);
4341                 NEXTVAL_NEXTTOKE.opval = attrs;
4342                 CURMAD('_', PL_nextwhite);
4343                 force_next(THING);
4344             }
4345 #ifdef PERL_MAD
4346             if (PL_madskills) {
4347                 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4348                                      (s - SvPVX(PL_linestr)) - stuffstart);
4349             }
4350 #endif
4351             TOKEN(COLONATTR);
4352         }
4353         OPERATOR(':');
4354     case '(':
4355         s++;
4356         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4357             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
4358         else
4359             PL_expect = XTERM;
4360         s = SKIPSPACE1(s);
4361         TOKEN('(');
4362     case ';':
4363         CLINE;
4364         {
4365             const char tmp = *s++;
4366             OPERATOR(tmp);
4367         }
4368     case ')':
4369         {
4370             const char tmp = *s++;
4371             s = SKIPSPACE1(s);
4372             if (*s == '{')
4373                 PREBLOCK(tmp);
4374             TERM(tmp);
4375         }
4376     case ']':
4377         s++;
4378         if (PL_lex_brackets <= 0)
4379             yyerror("Unmatched right square bracket");
4380         else
4381             --PL_lex_brackets;
4382         if (PL_lex_state == LEX_INTERPNORMAL) {
4383             if (PL_lex_brackets == 0) {
4384                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
4385                     PL_lex_state = LEX_INTERPEND;
4386             }
4387         }
4388         TERM(']');
4389     case '{':
4390       leftbracket:
4391         s++;
4392         if (PL_lex_brackets > 100) {
4393             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4394         }
4395         switch (PL_expect) {
4396         case XTERM:
4397             if (PL_lex_formbrack) {
4398                 s--;
4399                 PRETERMBLOCK(DO);
4400             }
4401             if (PL_oldoldbufptr == PL_last_lop)
4402                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4403             else
4404                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4405             OPERATOR(HASHBRACK);
4406         case XOPERATOR:
4407             while (s < PL_bufend && SPACE_OR_TAB(*s))
4408                 s++;
4409             d = s;
4410             PL_tokenbuf[0] = '\0';
4411             if (d < PL_bufend && *d == '-') {
4412                 PL_tokenbuf[0] = '-';
4413                 d++;
4414                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4415                     d++;
4416             }
4417             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4418                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4419                               FALSE, &len);
4420                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4421                     d++;
4422                 if (*d == '}') {
4423                     const char minus = (PL_tokenbuf[0] == '-');
4424                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4425                     if (minus)
4426                         force_next('-');
4427                 }
4428             }
4429             /* FALL THROUGH */
4430         case XATTRBLOCK:
4431         case XBLOCK:
4432             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4433             PL_expect = XSTATE;
4434             break;
4435         case XATTRTERM:
4436         case XTERMBLOCK:
4437