toke.c

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