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