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