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