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