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