toke.c

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