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