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