toke.c

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