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