toke.c

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