This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Eliminate xpad_cop_seq from _xnvu union
[perl5.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 /*
25 =head1 Lexer interface
26 This is the lower layer of the Perl parser, managing characters and tokens.
27
28 =for apidoc AmU|yy_parser *|PL_parser
29
30 Pointer to a structure encapsulating the state of the parsing operation
31 currently in progress.  The pointer can be locally changed to perform
32 a nested parse without interfering with the state of an outer parse.
33 Individual members of C<PL_parser> have their own documentation.
34
35 =cut
36 */
37
38 #include "EXTERN.h"
39 #define PERL_IN_TOKE_C
40 #include "perl.h"
41 #include "dquote_inline.h"
42
43 #define new_constant(a,b,c,d,e,f,g)     \
44         S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
45
46 #define pl_yylval       (PL_parser->yylval)
47
48 /* XXX temporary backwards compatibility */
49 #define PL_lex_brackets         (PL_parser->lex_brackets)
50 #define PL_lex_allbrackets      (PL_parser->lex_allbrackets)
51 #define PL_lex_fakeeof          (PL_parser->lex_fakeeof)
52 #define PL_lex_brackstack       (PL_parser->lex_brackstack)
53 #define PL_lex_casemods         (PL_parser->lex_casemods)
54 #define PL_lex_casestack        (PL_parser->lex_casestack)
55 #define PL_lex_dojoin           (PL_parser->lex_dojoin)
56 #define PL_lex_formbrack        (PL_parser->lex_formbrack)
57 #define PL_lex_inpat            (PL_parser->lex_inpat)
58 #define PL_lex_inwhat           (PL_parser->lex_inwhat)
59 #define PL_lex_op               (PL_parser->lex_op)
60 #define PL_lex_repl             (PL_parser->lex_repl)
61 #define PL_lex_starts           (PL_parser->lex_starts)
62 #define PL_lex_stuff            (PL_parser->lex_stuff)
63 #define PL_multi_start          (PL_parser->multi_start)
64 #define PL_multi_open           (PL_parser->multi_open)
65 #define PL_multi_close          (PL_parser->multi_close)
66 #define PL_preambled            (PL_parser->preambled)
67 #define PL_linestr              (PL_parser->linestr)
68 #define PL_expect               (PL_parser->expect)
69 #define PL_copline              (PL_parser->copline)
70 #define PL_bufptr               (PL_parser->bufptr)
71 #define PL_oldbufptr            (PL_parser->oldbufptr)
72 #define PL_oldoldbufptr         (PL_parser->oldoldbufptr)
73 #define PL_linestart            (PL_parser->linestart)
74 #define PL_bufend               (PL_parser->bufend)
75 #define PL_last_uni             (PL_parser->last_uni)
76 #define PL_last_lop             (PL_parser->last_lop)
77 #define PL_last_lop_op          (PL_parser->last_lop_op)
78 #define PL_lex_state            (PL_parser->lex_state)
79 #define PL_rsfp                 (PL_parser->rsfp)
80 #define PL_rsfp_filters         (PL_parser->rsfp_filters)
81 #define PL_in_my                (PL_parser->in_my)
82 #define PL_in_my_stash          (PL_parser->in_my_stash)
83 #define PL_tokenbuf             (PL_parser->tokenbuf)
84 #define PL_multi_end            (PL_parser->multi_end)
85 #define PL_error_count          (PL_parser->error_count)
86
87 #  define PL_nexttoke           (PL_parser->nexttoke)
88 #  define PL_nexttype           (PL_parser->nexttype)
89 #  define PL_nextval            (PL_parser->nextval)
90
91 static const char* const ident_too_long = "Identifier too long";
92
93 #  define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
94
95 #define XENUMMASK  0x3f
96 #define XFAKEEOF   0x40
97 #define XFAKEBRACK 0x80
98
99 #ifdef USE_UTF8_SCRIPTS
100 #   define UTF cBOOL(!IN_BYTES)
101 #else
102 #   define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
103 #endif
104
105 /* The maximum number of characters preceding the unrecognized one to display */
106 #define UNRECOGNIZED_PRECEDE_COUNT 10
107
108 /* In variables named $^X, these are the legal values for X.
109  * 1999-02-27 mjd-perl-patch@plover.com */
110 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
111
112 #define SPACE_OR_TAB(c) isBLANK_A(c)
113
114 #define HEXFP_PEEK(s)     \
115     (((s[0] == '.') && \
116       (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
117      isALPHA_FOLD_EQ(s[0], 'p'))
118
119 /* LEX_* are values for PL_lex_state, the state of the lexer.
120  * They are arranged oddly so that the guard on the switch statement
121  * can get by with a single comparison (if the compiler is smart enough).
122  *
123  * These values refer to the various states within a sublex parse,
124  * i.e. within a double quotish string
125  */
126
127 /* #define LEX_NOTPARSING               11 is done in perl.h. */
128
129 #define LEX_NORMAL              10 /* normal code (ie not within "...")     */
130 #define LEX_INTERPNORMAL         9 /* code within a string, eg "$foo[$x+1]" */
131 #define LEX_INTERPCASEMOD        8 /* expecting a \U, \Q or \E etc          */
132 #define LEX_INTERPPUSH           7 /* starting a new sublex parse level     */
133 #define LEX_INTERPSTART          6 /* expecting the start of a $var         */
134
135                                    /* at end of code, eg "$x" followed by:  */
136 #define LEX_INTERPEND            5 /* ... eg not one of [, { or ->          */
137 #define LEX_INTERPENDMAYBE       4 /* ... eg one of [, { or ->              */
138
139 #define LEX_INTERPCONCAT         3 /* expecting anything, eg at start of
140                                         string or after \E, $foo, etc       */
141 #define LEX_INTERPCONST          2 /* NOT USED */
142 #define LEX_FORMLINE             1 /* expecting a format line               */
143
144
145 #ifdef DEBUGGING
146 static const char* const lex_state_names[] = {
147     "KNOWNEXT",
148     "FORMLINE",
149     "INTERPCONST",
150     "INTERPCONCAT",
151     "INTERPENDMAYBE",
152     "INTERPEND",
153     "INTERPSTART",
154     "INTERPPUSH",
155     "INTERPCASEMOD",
156     "INTERPNORMAL",
157     "NORMAL"
158 };
159 #endif
160
161 #include "keywords.h"
162
163 /* CLINE is a macro that ensures PL_copline has a sane value */
164
165 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
166
167 /*
168  * Convenience functions to return different tokens and prime the
169  * lexer for the next token.  They all take an argument.
170  *
171  * TOKEN        : generic token (used for '(', DOLSHARP, etc)
172  * OPERATOR     : generic operator
173  * AOPERATOR    : assignment operator
174  * PREBLOCK     : beginning the block after an if, while, foreach, ...
175  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
176  * PREREF       : *EXPR where EXPR is not a simple identifier
177  * TERM         : expression term
178  * POSTDEREF    : postfix dereference (->$* ->@[...] etc.)
179  * LOOPX        : loop exiting command (goto, last, dump, etc)
180  * FTST         : file test operator
181  * FUN0         : zero-argument function
182  * FUN0OP       : zero-argument function, with its op created in this file
183  * FUN1         : not used, except for not, which isn't a UNIOP
184  * BOop         : bitwise or or xor
185  * BAop         : bitwise and
186  * BCop         : bitwise complement
187  * SHop         : shift operator
188  * PWop         : power operator
189  * PMop         : pattern-matching operator
190  * Aop          : addition-level operator
191  * AopNOASSIGN  : addition-level operator that is never part of .=
192  * Mop          : multiplication-level operator
193  * Eop          : equality-testing operator
194  * Rop          : relational operator <= != gt
195  *
196  * Also see LOP and lop() below.
197  */
198
199 #ifdef DEBUGGING /* Serve -DT. */
200 #   define REPORT(retval) tokereport((I32)retval, &pl_yylval)
201 #else
202 #   define REPORT(retval) (retval)
203 #endif
204
205 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
206 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
207 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, retval))
208 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
209 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
210 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
211 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
212 #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
213 #define LOOPX(f) return (PL_bufptr = force_word(s,BAREWORD,TRUE,FALSE), \
214                          pl_yylval.ival=f, \
215                          PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
216                          REPORT((int)LOOPEX))
217 #define FTST(f)  return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
218 #define FUN0(f)  return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
219 #define FUN0OP(f)  return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
220 #define FUN1(f)  return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
221 #define BOop(f)  return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
222 #define BAop(f)  return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
223 #define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \
224                        REPORT('~')
225 #define SHop(f)  return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
226 #define PWop(f)  return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP))
227 #define PMop(f)  return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
228 #define Aop(f)   return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
229 #define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
230 #define Mop(f)   return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
231 #define Eop(f)   return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
232 #define Rop(f)   return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
233
234 /* This bit of chicanery makes a unary function followed by
235  * a parenthesis into a function with one argument, highest precedence.
236  * The UNIDOR macro is for unary functions that can be followed by the //
237  * operator (such as C<shift // 0>).
238  */
239 #define UNI3(f,x,have_x) { \
240         pl_yylval.ival = f; \
241         if (have_x) PL_expect = x; \
242         PL_bufptr = s; \
243         PL_last_uni = PL_oldbufptr; \
244         PL_last_lop_op = (f) < 0 ? -(f) : (f); \
245         if (*s == '(') \
246             return REPORT( (int)FUNC1 ); \
247         s = skipspace(s); \
248         return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
249         }
250 #define UNI(f)    UNI3(f,XTERM,1)
251 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
252 #define UNIPROTO(f,optional) { \
253         if (optional) PL_last_uni = PL_oldbufptr; \
254         OPERATOR(f); \
255         }
256
257 #define UNIBRACK(f) UNI3(f,0,0)
258
259 /* grandfather return to old style */
260 #define OLDLOP(f) \
261         do { \
262             if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
263                 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
264             pl_yylval.ival = (f); \
265             PL_expect = XTERM; \
266             PL_bufptr = s; \
267             return (int)LSTOP; \
268         } while(0)
269
270 #define COPLINE_INC_WITH_HERELINES                  \
271     STMT_START {                                     \
272         CopLINE_inc(PL_curcop);                       \
273         if (PL_parser->herelines)                      \
274             CopLINE(PL_curcop) += PL_parser->herelines, \
275             PL_parser->herelines = 0;                    \
276     } STMT_END
277 /* Called after scan_str to update CopLINE(PL_curcop), but only when there
278  * is no sublex_push to follow. */
279 #define COPLINE_SET_FROM_MULTI_END            \
280     STMT_START {                               \
281         CopLINE_set(PL_curcop, PL_multi_end);   \
282         if (PL_multi_end != PL_multi_start)      \
283             PL_parser->herelines = 0;             \
284     } STMT_END
285
286
287 #ifdef DEBUGGING
288
289 /* how to interpret the pl_yylval associated with the token */
290 enum token_type {
291     TOKENTYPE_NONE,
292     TOKENTYPE_IVAL,
293     TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
294     TOKENTYPE_PVAL,
295     TOKENTYPE_OPVAL
296 };
297
298 static struct debug_tokens {
299     const int token;
300     enum token_type type;
301     const char *name;
302 } const debug_tokens[] =
303 {
304     { ADDOP,            TOKENTYPE_OPNUM,        "ADDOP" },
305     { ANDAND,           TOKENTYPE_NONE,         "ANDAND" },
306     { ANDOP,            TOKENTYPE_NONE,         "ANDOP" },
307     { ANONSUB,          TOKENTYPE_IVAL,         "ANONSUB" },
308     { ARROW,            TOKENTYPE_NONE,         "ARROW" },
309     { ASSIGNOP,         TOKENTYPE_OPNUM,        "ASSIGNOP" },
310     { BITANDOP,         TOKENTYPE_OPNUM,        "BITANDOP" },
311     { BITOROP,          TOKENTYPE_OPNUM,        "BITOROP" },
312     { COLONATTR,        TOKENTYPE_NONE,         "COLONATTR" },
313     { CONTINUE,         TOKENTYPE_NONE,         "CONTINUE" },
314     { DEFAULT,          TOKENTYPE_NONE,         "DEFAULT" },
315     { DO,               TOKENTYPE_NONE,         "DO" },
316     { DOLSHARP,         TOKENTYPE_NONE,         "DOLSHARP" },
317     { DORDOR,           TOKENTYPE_NONE,         "DORDOR" },
318     { DOROP,            TOKENTYPE_OPNUM,        "DOROP" },
319     { DOTDOT,           TOKENTYPE_IVAL,         "DOTDOT" },
320     { ELSE,             TOKENTYPE_NONE,         "ELSE" },
321     { ELSIF,            TOKENTYPE_IVAL,         "ELSIF" },
322     { EQOP,             TOKENTYPE_OPNUM,        "EQOP" },
323     { FOR,              TOKENTYPE_IVAL,         "FOR" },
324     { FORMAT,           TOKENTYPE_NONE,         "FORMAT" },
325     { FORMLBRACK,       TOKENTYPE_NONE,         "FORMLBRACK" },
326     { FORMRBRACK,       TOKENTYPE_NONE,         "FORMRBRACK" },
327     { FUNC,             TOKENTYPE_OPNUM,        "FUNC" },
328     { FUNC0,            TOKENTYPE_OPNUM,        "FUNC0" },
329     { FUNC0OP,          TOKENTYPE_OPVAL,        "FUNC0OP" },
330     { FUNC0SUB,         TOKENTYPE_OPVAL,        "FUNC0SUB" },
331     { FUNC1,            TOKENTYPE_OPNUM,        "FUNC1" },
332     { FUNCMETH,         TOKENTYPE_OPVAL,        "FUNCMETH" },
333     { GIVEN,            TOKENTYPE_IVAL,         "GIVEN" },
334     { HASHBRACK,        TOKENTYPE_NONE,         "HASHBRACK" },
335     { IF,               TOKENTYPE_IVAL,         "IF" },
336     { LABEL,            TOKENTYPE_PVAL,         "LABEL" },
337     { LOCAL,            TOKENTYPE_IVAL,         "LOCAL" },
338     { LOOPEX,           TOKENTYPE_OPNUM,        "LOOPEX" },
339     { LSTOP,            TOKENTYPE_OPNUM,        "LSTOP" },
340     { LSTOPSUB,         TOKENTYPE_OPVAL,        "LSTOPSUB" },
341     { MATCHOP,          TOKENTYPE_OPNUM,        "MATCHOP" },
342     { METHOD,           TOKENTYPE_OPVAL,        "METHOD" },
343     { MULOP,            TOKENTYPE_OPNUM,        "MULOP" },
344     { MY,               TOKENTYPE_IVAL,         "MY" },
345     { NOAMP,            TOKENTYPE_NONE,         "NOAMP" },
346     { NOTOP,            TOKENTYPE_NONE,         "NOTOP" },
347     { OROP,             TOKENTYPE_IVAL,         "OROP" },
348     { OROR,             TOKENTYPE_NONE,         "OROR" },
349     { PACKAGE,          TOKENTYPE_NONE,         "PACKAGE" },
350     { PLUGEXPR,         TOKENTYPE_OPVAL,        "PLUGEXPR" },
351     { PLUGSTMT,         TOKENTYPE_OPVAL,        "PLUGSTMT" },
352     { PMFUNC,           TOKENTYPE_OPVAL,        "PMFUNC" },
353     { POSTJOIN,         TOKENTYPE_NONE,         "POSTJOIN" },
354     { POSTDEC,          TOKENTYPE_NONE,         "POSTDEC" },
355     { POSTINC,          TOKENTYPE_NONE,         "POSTINC" },
356     { POWOP,            TOKENTYPE_OPNUM,        "POWOP" },
357     { PREDEC,           TOKENTYPE_NONE,         "PREDEC" },
358     { PREINC,           TOKENTYPE_NONE,         "PREINC" },
359     { PRIVATEREF,       TOKENTYPE_OPVAL,        "PRIVATEREF" },
360     { QWLIST,           TOKENTYPE_OPVAL,        "QWLIST" },
361     { REFGEN,           TOKENTYPE_NONE,         "REFGEN" },
362     { RELOP,            TOKENTYPE_OPNUM,        "RELOP" },
363     { REQUIRE,          TOKENTYPE_NONE,         "REQUIRE" },
364     { SHIFTOP,          TOKENTYPE_OPNUM,        "SHIFTOP" },
365     { SUB,              TOKENTYPE_NONE,         "SUB" },
366     { THING,            TOKENTYPE_OPVAL,        "THING" },
367     { UMINUS,           TOKENTYPE_NONE,         "UMINUS" },
368     { UNIOP,            TOKENTYPE_OPNUM,        "UNIOP" },
369     { UNIOPSUB,         TOKENTYPE_OPVAL,        "UNIOPSUB" },
370     { UNLESS,           TOKENTYPE_IVAL,         "UNLESS" },
371     { UNTIL,            TOKENTYPE_IVAL,         "UNTIL" },
372     { USE,              TOKENTYPE_IVAL,         "USE" },
373     { WHEN,             TOKENTYPE_IVAL,         "WHEN" },
374     { WHILE,            TOKENTYPE_IVAL,         "WHILE" },
375     { BAREWORD,         TOKENTYPE_OPVAL,        "BAREWORD" },
376     { YADAYADA,         TOKENTYPE_IVAL,         "YADAYADA" },
377     { 0,                TOKENTYPE_NONE,         NULL }
378 };
379
380 /* dump the returned token in rv, plus any optional arg in pl_yylval */
381
382 STATIC int
383 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
384 {
385     PERL_ARGS_ASSERT_TOKEREPORT;
386
387     if (DEBUG_T_TEST) {
388         const char *name = NULL;
389         enum token_type type = TOKENTYPE_NONE;
390         const struct debug_tokens *p;
391         SV* const report = newSVpvs("<== ");
392
393         for (p = debug_tokens; p->token; p++) {
394             if (p->token == (int)rv) {
395                 name = p->name;
396                 type = p->type;
397                 break;
398             }
399         }
400         if (name)
401             Perl_sv_catpv(aTHX_ report, name);
402         else if (isGRAPH(rv))
403         {
404             Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
405             if ((char)rv == 'p')
406                 sv_catpvs(report, " (pending identifier)");
407         }
408         else if (!rv)
409             sv_catpvs(report, "EOF");
410         else
411             Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
412         switch (type) {
413         case TOKENTYPE_NONE:
414             break;
415         case TOKENTYPE_IVAL:
416             Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
417             break;
418         case TOKENTYPE_OPNUM:
419             Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
420                                     PL_op_name[lvalp->ival]);
421             break;
422         case TOKENTYPE_PVAL:
423             Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
424             break;
425         case TOKENTYPE_OPVAL:
426             if (lvalp->opval) {
427                 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
428                                     PL_op_name[lvalp->opval->op_type]);
429                 if (lvalp->opval->op_type == OP_CONST) {
430                     Perl_sv_catpvf(aTHX_ report, " %s",
431                         SvPEEK(cSVOPx_sv(lvalp->opval)));
432                 }
433
434             }
435             else
436                 sv_catpvs(report, "(opval=null)");
437             break;
438         }
439         PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
440     };
441     return (int)rv;
442 }
443
444
445 /* print the buffer with suitable escapes */
446
447 STATIC void
448 S_printbuf(pTHX_ const char *const fmt, const char *const s)
449 {
450     SV* const tmp = newSVpvs("");
451
452     PERL_ARGS_ASSERT_PRINTBUF;
453
454     GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
455     PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
456     GCC_DIAG_RESTORE;
457     SvREFCNT_dec(tmp);
458 }
459
460 #endif
461
462 static int
463 S_deprecate_commaless_var_list(pTHX) {
464     PL_expect = XTERM;
465     deprecate("comma-less variable list");
466     return REPORT(','); /* grandfather non-comma-format format */
467 }
468
469 /*
470  * S_ao
471  *
472  * This subroutine looks for an '=' next to the operator that has just been
473  * parsed and turns it into an ASSIGNOP if it finds one.
474  */
475
476 STATIC int
477 S_ao(pTHX_ int toketype)
478 {
479     if (*PL_bufptr == '=') {
480         PL_bufptr++;
481         if (toketype == ANDAND)
482             pl_yylval.ival = OP_ANDASSIGN;
483         else if (toketype == OROR)
484             pl_yylval.ival = OP_ORASSIGN;
485         else if (toketype == DORDOR)
486             pl_yylval.ival = OP_DORASSIGN;
487         toketype = ASSIGNOP;
488     }
489     return REPORT(toketype);
490 }
491
492 /*
493  * S_no_op
494  * When Perl expects an operator and finds something else, no_op
495  * prints the warning.  It always prints "<something> found where
496  * operator expected.  It prints "Missing semicolon on previous line?"
497  * if the surprise occurs at the start of the line.  "do you need to
498  * predeclare ..." is printed out for code like "sub bar; foo bar $x"
499  * where the compiler doesn't know if foo is a method call or a function.
500  * It prints "Missing operator before end of line" if there's nothing
501  * after the missing operator, or "... before <...>" if there is something
502  * after the missing operator.
503  *
504  * PL_bufptr is expected to point to the start of the thing that was found,
505  * and s after the next token or partial token.
506  */
507
508 STATIC void
509 S_no_op(pTHX_ const char *const what, char *s)
510 {
511     char * const oldbp = PL_bufptr;
512     const bool is_first = (PL_oldbufptr == PL_linestart);
513
514     PERL_ARGS_ASSERT_NO_OP;
515
516     if (!s)
517         s = oldbp;
518     else
519         PL_bufptr = s;
520     yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
521     if (ckWARN_d(WARN_SYNTAX)) {
522         if (is_first)
523             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
524                     "\t(Missing semicolon on previous line?)\n");
525         else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
526             const char *t;
527             for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if(t,UTF) || *t == ':');
528                                                             t += UTF ? UTF8SKIP(t) : 1)
529                 NOOP;
530             if (t < PL_bufptr && isSPACE(*t))
531                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
532                         "\t(Do you need to predeclare %"UTF8f"?)\n",
533                       UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
534         }
535         else {
536             assert(s >= oldbp);
537             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
538                     "\t(Missing operator before %"UTF8f"?)\n",
539                      UTF8fARG(UTF, s - oldbp, oldbp));
540         }
541     }
542     PL_bufptr = oldbp;
543 }
544
545 /*
546  * S_missingterm
547  * Complain about missing quote/regexp/heredoc terminator.
548  * If it's called with NULL then it cauterizes the line buffer.
549  * If we're in a delimited string and the delimiter is a control
550  * character, it's reformatted into a two-char sequence like ^C.
551  * This is fatal.
552  */
553
554 STATIC void
555 S_missingterm(pTHX_ char *s)
556 {
557     char tmpbuf[UTF8_MAXBYTES + 1];
558     char q;
559     bool uni = FALSE;
560     SV *sv;
561     if (s) {
562         char * const nl = strrchr(s,'\n');
563         if (nl)
564             *nl = '\0';
565         uni = UTF;
566     }
567     else if (PL_multi_close < 32) {
568         *tmpbuf = '^';
569         tmpbuf[1] = (char)toCTRL(PL_multi_close);
570         tmpbuf[2] = '\0';
571         s = tmpbuf;
572     }
573     else {
574         if (LIKELY(PL_multi_close < 256)) {
575             *tmpbuf = (char)PL_multi_close;
576             tmpbuf[1] = '\0';
577         }
578         else {
579             uni = TRUE;
580             *uvchr_to_utf8((U8 *)tmpbuf, PL_multi_close) = 0;
581         }
582         s = tmpbuf;
583     }
584     q = strchr(s,'"') ? '\'' : '"';
585     sv = sv_2mortal(newSVpv(s,0));
586     if (uni)
587         SvUTF8_on(sv);
588     Perl_croak(aTHX_ "Can't find string terminator %c%"SVf
589                      "%c anywhere before EOF",q,SVfARG(sv),q);
590 }
591
592 #include "feature.h"
593
594 /*
595  * Check whether the named feature is enabled.
596  */
597 bool
598 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
599 {
600     char he_name[8 + MAX_FEATURE_LEN] = "feature_";
601
602     PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
603
604     assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
605
606     if (namelen > MAX_FEATURE_LEN)
607         return FALSE;
608     memcpy(&he_name[8], name, namelen);
609
610     return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
611                                      REFCOUNTED_HE_EXISTS));
612 }
613
614 /*
615  * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
616  * utf16-to-utf8-reversed.
617  */
618
619 #ifdef PERL_CR_FILTER
620 static void
621 strip_return(SV *sv)
622 {
623     const char *s = SvPVX_const(sv);
624     const char * const e = s + SvCUR(sv);
625
626     PERL_ARGS_ASSERT_STRIP_RETURN;
627
628     /* outer loop optimized to do nothing if there are no CR-LFs */
629     while (s < e) {
630         if (*s++ == '\r' && *s == '\n') {
631             /* hit a CR-LF, need to copy the rest */
632             char *d = s - 1;
633             *d++ = *s++;
634             while (s < e) {
635                 if (*s == '\r' && s[1] == '\n')
636                     s++;
637                 *d++ = *s++;
638             }
639             SvCUR(sv) -= s - d;
640             return;
641         }
642     }
643 }
644
645 STATIC I32
646 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
647 {
648     const I32 count = FILTER_READ(idx+1, sv, maxlen);
649     if (count > 0 && !maxlen)
650         strip_return(sv);
651     return count;
652 }
653 #endif
654
655 /*
656 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
657
658 Creates and initialises a new lexer/parser state object, supplying
659 a context in which to lex and parse from a new source of Perl code.
660 A pointer to the new state object is placed in L</PL_parser>.  An entry
661 is made on the save stack so that upon unwinding the new state object
662 will be destroyed and the former value of L</PL_parser> will be restored.
663 Nothing else need be done to clean up the parsing context.
664
665 The code to be parsed comes from C<line> and C<rsfp>.  C<line>, if
666 non-null, provides a string (in SV form) containing code to be parsed.
667 A copy of the string is made, so subsequent modification of C<line>
668 does not affect parsing.  C<rsfp>, if non-null, provides an input stream
669 from which code will be read to be parsed.  If both are non-null, the
670 code in C<line> comes first and must consist of complete lines of input,
671 and C<rsfp> supplies the remainder of the source.
672
673 The C<flags> parameter is reserved for future use.  Currently it is only
674 used by perl internally, so extensions should always pass zero.
675
676 =cut
677 */
678
679 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
680    can share filters with the current parser.
681    LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
682    caller, hence isn't owned by the parser, so shouldn't be closed on parser
683    destruction. This is used to handle the case of defaulting to reading the
684    script from the standard input because no filename was given on the command
685    line (without getting confused by situation where STDIN has been closed, so
686    the script handle is opened on fd 0)  */
687
688 void
689 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
690 {
691     const char *s = NULL;
692     yy_parser *parser, *oparser;
693     if (flags && flags & ~LEX_START_FLAGS)
694         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
695
696     /* create and initialise a parser */
697
698     Newxz(parser, 1, yy_parser);
699     parser->old_parser = oparser = PL_parser;
700     PL_parser = parser;
701
702     parser->stack = NULL;
703     parser->ps = NULL;
704     parser->stack_size = 0;
705
706     /* on scope exit, free this parser and restore any outer one */
707     SAVEPARSER(parser);
708     parser->saved_curcop = PL_curcop;
709
710     /* initialise lexer state */
711
712     parser->nexttoke = 0;
713     parser->error_count = oparser ? oparser->error_count : 0;
714     parser->copline = parser->preambling = NOLINE;
715     parser->lex_state = LEX_NORMAL;
716     parser->expect = XSTATE;
717     parser->rsfp = rsfp;
718     parser->rsfp_filters =
719       !(flags & LEX_START_SAME_FILTER) || !oparser
720         ? NULL
721         : MUTABLE_AV(SvREFCNT_inc(
722             oparser->rsfp_filters
723              ? oparser->rsfp_filters
724              : (oparser->rsfp_filters = newAV())
725           ));
726
727     Newx(parser->lex_brackstack, 120, char);
728     Newx(parser->lex_casestack, 12, char);
729     *parser->lex_casestack = '\0';
730     Newxz(parser->lex_shared, 1, LEXSHARED);
731
732     if (line) {
733         STRLEN len;
734         s = SvPV_const(line, len);
735         parser->linestr = flags & LEX_START_COPIED
736                             ? SvREFCNT_inc_simple_NN(line)
737                             : newSVpvn_flags(s, len, SvUTF8(line));
738         if (!rsfp)
739             sv_catpvs(parser->linestr, "\n;");
740     } else {
741         parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
742     }
743     parser->oldoldbufptr =
744         parser->oldbufptr =
745         parser->bufptr =
746         parser->linestart = SvPVX(parser->linestr);
747     parser->bufend = parser->bufptr + SvCUR(parser->linestr);
748     parser->last_lop = parser->last_uni = NULL;
749
750     STATIC_ASSERT_STMT(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
751                                                         |LEX_DONT_CLOSE_RSFP));
752     parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
753                                                         |LEX_DONT_CLOSE_RSFP));
754
755     parser->in_pod = parser->filtered = 0;
756 }
757
758
759 /* delete a parser object */
760
761 void
762 Perl_parser_free(pTHX_  const yy_parser *parser)
763 {
764     PERL_ARGS_ASSERT_PARSER_FREE;
765
766     PL_curcop = parser->saved_curcop;
767     SvREFCNT_dec(parser->linestr);
768
769     if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
770         PerlIO_clearerr(parser->rsfp);
771     else if (parser->rsfp && (!parser->old_parser
772           || (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
773         PerlIO_close(parser->rsfp);
774     SvREFCNT_dec(parser->rsfp_filters);
775     SvREFCNT_dec(parser->lex_stuff);
776     SvREFCNT_dec(parser->lex_sub_repl);
777
778     Safefree(parser->lex_brackstack);
779     Safefree(parser->lex_casestack);
780     Safefree(parser->lex_shared);
781     PL_parser = parser->old_parser;
782     Safefree(parser);
783 }
784
785 void
786 Perl_parser_free_nexttoke_ops(pTHX_  yy_parser *parser, OPSLAB *slab)
787 {
788     I32 nexttoke = parser->nexttoke;
789     PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
790     while (nexttoke--) {
791         if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
792          && parser->nextval[nexttoke].opval
793          && parser->nextval[nexttoke].opval->op_slabbed
794          && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
795             op_free(parser->nextval[nexttoke].opval);
796             parser->nextval[nexttoke].opval = NULL;
797         }
798     }
799 }
800
801
802 /*
803 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
804
805 Buffer scalar containing the chunk currently under consideration of the
806 text currently being lexed.  This is always a plain string scalar (for
807 which C<SvPOK> is true).  It is not intended to be used as a scalar by
808 normal scalar means; instead refer to the buffer directly by the pointer
809 variables described below.
810
811 The lexer maintains various C<char*> pointers to things in the
812 C<PL_parser-E<gt>linestr> buffer.  If C<PL_parser-E<gt>linestr> is ever
813 reallocated, all of these pointers must be updated.  Don't attempt to
814 do this manually, but rather use L</lex_grow_linestr> if you need to
815 reallocate the buffer.
816
817 The content of the text chunk in the buffer is commonly exactly one
818 complete line of input, up to and including a newline terminator,
819 but there are situations where it is otherwise.  The octets of the
820 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
821 The function L</lex_bufutf8> tells you which.  Do not use the C<SvUTF8>
822 flag on this scalar, which may disagree with it.
823
824 For direct examination of the buffer, the variable
825 L</PL_parser-E<gt>bufend> points to the end of the buffer.  The current
826 lexing position is pointed to by L</PL_parser-E<gt>bufptr>.  Direct use
827 of these pointers is usually preferable to examination of the scalar
828 through normal scalar means.
829
830 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
831
832 Direct pointer to the end of the chunk of text currently being lexed, the
833 end of the lexer buffer.  This is equal to C<SvPVX(PL_parser-E<gt>linestr)
834 + SvCUR(PL_parser-E<gt>linestr)>.  A C<NUL> character (zero octet) is
835 always located at the end of the buffer, and does not count as part of
836 the buffer's contents.
837
838 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
839
840 Points to the current position of lexing inside the lexer buffer.
841 Characters around this point may be freely examined, within
842 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
843 L</PL_parser-E<gt>bufend>.  The octets of the buffer may be intended to be
844 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
845
846 Lexing code (whether in the Perl core or not) moves this pointer past
847 the characters that it consumes.  It is also expected to perform some
848 bookkeeping whenever a newline character is consumed.  This movement
849 can be more conveniently performed by the function L</lex_read_to>,
850 which handles newlines appropriately.
851
852 Interpretation of the buffer's octets can be abstracted out by
853 using the slightly higher-level functions L</lex_peek_unichar> and
854 L</lex_read_unichar>.
855
856 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
857
858 Points to the start of the current line inside the lexer buffer.
859 This is useful for indicating at which column an error occurred, and
860 not much else.  This must be updated by any lexing code that consumes
861 a newline; the function L</lex_read_to> handles this detail.
862
863 =cut
864 */
865
866 /*
867 =for apidoc Amx|bool|lex_bufutf8
868
869 Indicates whether the octets in the lexer buffer
870 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
871 of Unicode characters.  If not, they should be interpreted as Latin-1
872 characters.  This is analogous to the C<SvUTF8> flag for scalars.
873
874 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
875 contains valid UTF-8.  Lexing code must be robust in the face of invalid
876 encoding.
877
878 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
879 is significant, but not the whole story regarding the input character
880 encoding.  Normally, when a file is being read, the scalar contains octets
881 and its C<SvUTF8> flag is off, but the octets should be interpreted as
882 UTF-8 if the C<use utf8> pragma is in effect.  During a string eval,
883 however, the scalar may have the C<SvUTF8> flag on, and in this case its
884 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
885 is in effect.  This logic may change in the future; use this function
886 instead of implementing the logic yourself.
887
888 =cut
889 */
890
891 bool
892 Perl_lex_bufutf8(pTHX)
893 {
894     return UTF;
895 }
896
897 /*
898 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
899
900 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
901 at least C<len> octets (including terminating C<NUL>).  Returns a
902 pointer to the reallocated buffer.  This is necessary before making
903 any direct modification of the buffer that would increase its length.
904 L</lex_stuff_pvn> provides a more convenient way to insert text into
905 the buffer.
906
907 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
908 this function updates all of the lexer's variables that point directly
909 into the buffer.
910
911 =cut
912 */
913
914 char *
915 Perl_lex_grow_linestr(pTHX_ STRLEN len)
916 {
917     SV *linestr;
918     char *buf;
919     STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
920     STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
921     linestr = PL_parser->linestr;
922     buf = SvPVX(linestr);
923     if (len <= SvLEN(linestr))
924         return buf;
925     bufend_pos = PL_parser->bufend - buf;
926     bufptr_pos = PL_parser->bufptr - buf;
927     oldbufptr_pos = PL_parser->oldbufptr - buf;
928     oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
929     linestart_pos = PL_parser->linestart - buf;
930     last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
931     last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
932     re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
933                             PL_parser->lex_shared->re_eval_start - buf : 0;
934
935     buf = sv_grow(linestr, len);
936
937     PL_parser->bufend = buf + bufend_pos;
938     PL_parser->bufptr = buf + bufptr_pos;
939     PL_parser->oldbufptr = buf + oldbufptr_pos;
940     PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
941     PL_parser->linestart = buf + linestart_pos;
942     if (PL_parser->last_uni)
943         PL_parser->last_uni = buf + last_uni_pos;
944     if (PL_parser->last_lop)
945         PL_parser->last_lop = buf + last_lop_pos;
946     if (PL_parser->lex_shared->re_eval_start)
947         PL_parser->lex_shared->re_eval_start  = buf + re_eval_start_pos;
948     return buf;
949 }
950
951 /*
952 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
953
954 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
955 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
956 reallocating the buffer if necessary.  This means that lexing code that
957 runs later will see the characters as if they had appeared in the input.
958 It is not recommended to do this as part of normal parsing, and most
959 uses of this facility run the risk of the inserted characters being
960 interpreted in an unintended manner.
961
962 The string to be inserted is represented by C<len> octets starting
963 at C<pv>.  These octets are interpreted as either UTF-8 or Latin-1,
964 according to whether the C<LEX_STUFF_UTF8> flag is set in C<flags>.
965 The characters are recoded for the lexer buffer, according to how the
966 buffer is currently being interpreted (L</lex_bufutf8>).  If a string
967 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
968 function is more convenient.
969
970 =cut
971 */
972
973 void
974 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
975 {
976     dVAR;
977     char *bufptr;
978     PERL_ARGS_ASSERT_LEX_STUFF_PVN;
979     if (flags & ~(LEX_STUFF_UTF8))
980         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
981     if (UTF) {
982         if (flags & LEX_STUFF_UTF8) {
983             goto plain_copy;
984         } else {
985             STRLEN highhalf = 0;    /* Count of variants */
986             const char *p, *e = pv+len;
987             for (p = pv; p != e; p++) {
988                 if (! UTF8_IS_INVARIANT(*p)) {
989                     highhalf++;
990                 }
991             }
992             if (!highhalf)
993                 goto plain_copy;
994             lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
995             bufptr = PL_parser->bufptr;
996             Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
997             SvCUR_set(PL_parser->linestr,
998                 SvCUR(PL_parser->linestr) + len+highhalf);
999             PL_parser->bufend += len+highhalf;
1000             for (p = pv; p != e; p++) {
1001                 U8 c = (U8)*p;
1002                 if (! UTF8_IS_INVARIANT(c)) {
1003                     *bufptr++ = UTF8_TWO_BYTE_HI(c);
1004                     *bufptr++ = UTF8_TWO_BYTE_LO(c);
1005                 } else {
1006                     *bufptr++ = (char)c;
1007                 }
1008             }
1009         }
1010     } else {
1011         if (flags & LEX_STUFF_UTF8) {
1012             STRLEN highhalf = 0;
1013             const char *p, *e = pv+len;
1014             for (p = pv; p != e; p++) {
1015                 U8 c = (U8)*p;
1016                 if (UTF8_IS_ABOVE_LATIN1(c)) {
1017                     Perl_croak(aTHX_ "Lexing code attempted to stuff "
1018                                 "non-Latin-1 character into Latin-1 input");
1019                 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1020                     p++;
1021                     highhalf++;
1022                 } else if (! UTF8_IS_INVARIANT(c)) {
1023                     /* malformed UTF-8 */
1024                     ENTER;
1025                     SAVESPTR(PL_warnhook);
1026                     PL_warnhook = PERL_WARNHOOK_FATAL;
1027                     utf8n_to_uvchr((U8*)p, e-p, NULL, 0);
1028                     LEAVE;
1029                 }
1030             }
1031             if (!highhalf)
1032                 goto plain_copy;
1033             lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1034             bufptr = PL_parser->bufptr;
1035             Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1036             SvCUR_set(PL_parser->linestr,
1037                 SvCUR(PL_parser->linestr) + len-highhalf);
1038             PL_parser->bufend += len-highhalf;
1039             p = pv;
1040             while (p < e) {
1041                 if (UTF8_IS_INVARIANT(*p)) {
1042                     *bufptr++ = *p;
1043                     p++;
1044                 }
1045                 else {
1046                     assert(p < e -1 );
1047                     *bufptr++ = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
1048                     p += 2;
1049                 }
1050             }
1051         } else {
1052           plain_copy:
1053             lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1054             bufptr = PL_parser->bufptr;
1055             Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1056             SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1057             PL_parser->bufend += len;
1058             Copy(pv, bufptr, len, char);
1059         }
1060     }
1061 }
1062
1063 /*
1064 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1065
1066 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1067 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1068 reallocating the buffer if necessary.  This means that lexing code that
1069 runs later will see the characters as if they had appeared in the input.
1070 It is not recommended to do this as part of normal parsing, and most
1071 uses of this facility run the risk of the inserted characters being
1072 interpreted in an unintended manner.
1073
1074 The string to be inserted is represented by octets starting at C<pv>
1075 and continuing to the first nul.  These octets are interpreted as either
1076 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1077 in C<flags>.  The characters are recoded for the lexer buffer, according
1078 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1079 If it is not convenient to nul-terminate a string to be inserted, the
1080 L</lex_stuff_pvn> function is more appropriate.
1081
1082 =cut
1083 */
1084
1085 void
1086 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1087 {
1088     PERL_ARGS_ASSERT_LEX_STUFF_PV;
1089     lex_stuff_pvn(pv, strlen(pv), flags);
1090 }
1091
1092 /*
1093 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1094
1095 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1096 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1097 reallocating the buffer if necessary.  This means that lexing code that
1098 runs later will see the characters as if they had appeared in the input.
1099 It is not recommended to do this as part of normal parsing, and most
1100 uses of this facility run the risk of the inserted characters being
1101 interpreted in an unintended manner.
1102
1103 The string to be inserted is the string value of C<sv>.  The characters
1104 are recoded for the lexer buffer, according to how the buffer is currently
1105 being interpreted (L</lex_bufutf8>).  If a string to be inserted is
1106 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1107 need to construct a scalar.
1108
1109 =cut
1110 */
1111
1112 void
1113 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1114 {
1115     char *pv;
1116     STRLEN len;
1117     PERL_ARGS_ASSERT_LEX_STUFF_SV;
1118     if (flags)
1119         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1120     pv = SvPV(sv, len);
1121     lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1122 }
1123
1124 /*
1125 =for apidoc Amx|void|lex_unstuff|char *ptr
1126
1127 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1128 C<ptr>.  Text following C<ptr> will be moved, and the buffer shortened.
1129 This hides the discarded text from any lexing code that runs later,
1130 as if the text had never appeared.
1131
1132 This is not the normal way to consume lexed text.  For that, use
1133 L</lex_read_to>.
1134
1135 =cut
1136 */
1137
1138 void
1139 Perl_lex_unstuff(pTHX_ char *ptr)
1140 {
1141     char *buf, *bufend;
1142     STRLEN unstuff_len;
1143     PERL_ARGS_ASSERT_LEX_UNSTUFF;
1144     buf = PL_parser->bufptr;
1145     if (ptr < buf)
1146         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1147     if (ptr == buf)
1148         return;
1149     bufend = PL_parser->bufend;
1150     if (ptr > bufend)
1151         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1152     unstuff_len = ptr - buf;
1153     Move(ptr, buf, bufend+1-ptr, char);
1154     SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1155     PL_parser->bufend = bufend - unstuff_len;
1156 }
1157
1158 /*
1159 =for apidoc Amx|void|lex_read_to|char *ptr
1160
1161 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1162 to C<ptr>.  This advances L</PL_parser-E<gt>bufptr> to match C<ptr>,
1163 performing the correct bookkeeping whenever a newline character is passed.
1164 This is the normal way to consume lexed text.
1165
1166 Interpretation of the buffer's octets can be abstracted out by
1167 using the slightly higher-level functions L</lex_peek_unichar> and
1168 L</lex_read_unichar>.
1169
1170 =cut
1171 */
1172
1173 void
1174 Perl_lex_read_to(pTHX_ char *ptr)
1175 {
1176     char *s;
1177     PERL_ARGS_ASSERT_LEX_READ_TO;
1178     s = PL_parser->bufptr;
1179     if (ptr < s || ptr > PL_parser->bufend)
1180         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1181     for (; s != ptr; s++)
1182         if (*s == '\n') {
1183             COPLINE_INC_WITH_HERELINES;
1184             PL_parser->linestart = s+1;
1185         }
1186     PL_parser->bufptr = ptr;
1187 }
1188
1189 /*
1190 =for apidoc Amx|void|lex_discard_to|char *ptr
1191
1192 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1193 up to C<ptr>.  The remaining content of the buffer will be moved, and
1194 all pointers into the buffer updated appropriately.  C<ptr> must not
1195 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1196 it is not permitted to discard text that has yet to be lexed.
1197
1198 Normally it is not necessarily to do this directly, because it suffices to
1199 use the implicit discarding behaviour of L</lex_next_chunk> and things
1200 based on it.  However, if a token stretches across multiple lines,
1201 and the lexing code has kept multiple lines of text in the buffer for
1202 that purpose, then after completion of the token it would be wise to
1203 explicitly discard the now-unneeded earlier lines, to avoid future
1204 multi-line tokens growing the buffer without bound.
1205
1206 =cut
1207 */
1208
1209 void
1210 Perl_lex_discard_to(pTHX_ char *ptr)
1211 {
1212     char *buf;
1213     STRLEN discard_len;
1214     PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1215     buf = SvPVX(PL_parser->linestr);
1216     if (ptr < buf)
1217         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1218     if (ptr == buf)
1219         return;
1220     if (ptr > PL_parser->bufptr)
1221         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1222     discard_len = ptr - buf;
1223     if (PL_parser->oldbufptr < ptr)
1224         PL_parser->oldbufptr = ptr;
1225     if (PL_parser->oldoldbufptr < ptr)
1226         PL_parser->oldoldbufptr = ptr;
1227     if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1228         PL_parser->last_uni = NULL;
1229     if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1230         PL_parser->last_lop = NULL;
1231     Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1232     SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1233     PL_parser->bufend -= discard_len;
1234     PL_parser->bufptr -= discard_len;
1235     PL_parser->oldbufptr -= discard_len;
1236     PL_parser->oldoldbufptr -= discard_len;
1237     if (PL_parser->last_uni)
1238         PL_parser->last_uni -= discard_len;
1239     if (PL_parser->last_lop)
1240         PL_parser->last_lop -= discard_len;
1241 }
1242
1243 /*
1244 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1245
1246 Reads in the next chunk of text to be lexed, appending it to
1247 L</PL_parser-E<gt>linestr>.  This should be called when lexing code has
1248 looked to the end of the current chunk and wants to know more.  It is
1249 usual, but not necessary, for lexing to have consumed the entirety of
1250 the current chunk at this time.
1251
1252 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1253 chunk (i.e., the current chunk has been entirely consumed), normally the
1254 current chunk will be discarded at the same time that the new chunk is
1255 read in.  If C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, the current chunk
1256 will not be discarded.  If the current chunk has not been entirely
1257 consumed, then it will not be discarded regardless of the flag.
1258
1259 Returns true if some new text was added to the buffer, or false if the
1260 buffer has reached the end of the input text.
1261
1262 =cut
1263 */
1264
1265 #define LEX_FAKE_EOF 0x80000000
1266 #define LEX_NO_TERM  0x40000000 /* here-doc */
1267
1268 bool
1269 Perl_lex_next_chunk(pTHX_ U32 flags)
1270 {
1271     SV *linestr;
1272     char *buf;
1273     STRLEN old_bufend_pos, new_bufend_pos;
1274     STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1275     STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1276     bool got_some_for_debugger = 0;
1277     bool got_some;
1278     if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1279         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1280     if (!(flags & LEX_NO_TERM) && PL_lex_inwhat)
1281         return FALSE;
1282     linestr = PL_parser->linestr;
1283     buf = SvPVX(linestr);
1284     if (!(flags & LEX_KEEP_PREVIOUS)
1285           && PL_parser->bufptr == PL_parser->bufend)
1286     {
1287         old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1288         linestart_pos = 0;
1289         if (PL_parser->last_uni != PL_parser->bufend)
1290             PL_parser->last_uni = NULL;
1291         if (PL_parser->last_lop != PL_parser->bufend)
1292             PL_parser->last_lop = NULL;
1293         last_uni_pos = last_lop_pos = 0;
1294         *buf = 0;
1295         SvCUR(linestr) = 0;
1296     } else {
1297         old_bufend_pos = PL_parser->bufend - buf;
1298         bufptr_pos = PL_parser->bufptr - buf;
1299         oldbufptr_pos = PL_parser->oldbufptr - buf;
1300         oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1301         linestart_pos = PL_parser->linestart - buf;
1302         last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1303         last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1304     }
1305     if (flags & LEX_FAKE_EOF) {
1306         goto eof;
1307     } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1308         got_some = 0;
1309     } else if (filter_gets(linestr, old_bufend_pos)) {
1310         got_some = 1;
1311         got_some_for_debugger = 1;
1312     } else if (flags & LEX_NO_TERM) {
1313         got_some = 0;
1314     } else {
1315         if (!SvPOK(linestr))   /* can get undefined by filter_gets */
1316             sv_setpvs(linestr, "");
1317         eof:
1318         /* End of real input.  Close filehandle (unless it was STDIN),
1319          * then add implicit termination.
1320          */
1321         if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1322             PerlIO_clearerr(PL_parser->rsfp);
1323         else if (PL_parser->rsfp)
1324             (void)PerlIO_close(PL_parser->rsfp);
1325         PL_parser->rsfp = NULL;
1326         PL_parser->in_pod = PL_parser->filtered = 0;
1327         if (!PL_in_eval && PL_minus_p) {
1328             sv_catpvs(linestr,
1329                 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1330             PL_minus_n = PL_minus_p = 0;
1331         } else if (!PL_in_eval && PL_minus_n) {
1332             sv_catpvs(linestr, /*{*/";}");
1333             PL_minus_n = 0;
1334         } else
1335             sv_catpvs(linestr, ";");
1336         got_some = 1;
1337     }
1338     buf = SvPVX(linestr);
1339     new_bufend_pos = SvCUR(linestr);
1340     PL_parser->bufend = buf + new_bufend_pos;
1341     PL_parser->bufptr = buf + bufptr_pos;
1342     PL_parser->oldbufptr = buf + oldbufptr_pos;
1343     PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1344     PL_parser->linestart = buf + linestart_pos;
1345     if (PL_parser->last_uni)
1346         PL_parser->last_uni = buf + last_uni_pos;
1347     if (PL_parser->last_lop)
1348         PL_parser->last_lop = buf + last_lop_pos;
1349     if (PL_parser->preambling != NOLINE) {
1350         CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1351         PL_parser->preambling = NOLINE;
1352     }
1353     if (   got_some_for_debugger
1354         && PERLDB_LINE_OR_SAVESRC
1355         && PL_curstash != PL_debstash)
1356     {
1357         /* debugger active and we're not compiling the debugger code,
1358          * so store the line into the debugger's array of lines
1359          */
1360         update_debugger_info(NULL, buf+old_bufend_pos,
1361             new_bufend_pos-old_bufend_pos);
1362     }
1363     return got_some;
1364 }
1365
1366 /*
1367 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1368
1369 Looks ahead one (Unicode) character in the text currently being lexed.
1370 Returns the codepoint (unsigned integer value) of the next character,
1371 or -1 if lexing has reached the end of the input text.  To consume the
1372 peeked character, use L</lex_read_unichar>.
1373
1374 If the next character is in (or extends into) the next chunk of input
1375 text, the next chunk will be read in.  Normally the current chunk will be
1376 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1377 bit set, then the current chunk will not be discarded.
1378
1379 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1380 is encountered, an exception is generated.
1381
1382 =cut
1383 */
1384
1385 I32
1386 Perl_lex_peek_unichar(pTHX_ U32 flags)
1387 {
1388     dVAR;
1389     char *s, *bufend;
1390     if (flags & ~(LEX_KEEP_PREVIOUS))
1391         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1392     s = PL_parser->bufptr;
1393     bufend = PL_parser->bufend;
1394     if (UTF) {
1395         U8 head;
1396         I32 unichar;
1397         STRLEN len, retlen;
1398         if (s == bufend) {
1399             if (!lex_next_chunk(flags))
1400                 return -1;
1401             s = PL_parser->bufptr;
1402             bufend = PL_parser->bufend;
1403         }
1404         head = (U8)*s;
1405         if (UTF8_IS_INVARIANT(head))
1406             return head;
1407         if (UTF8_IS_START(head)) {
1408             len = UTF8SKIP(&head);
1409             while ((STRLEN)(bufend-s) < len) {
1410                 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1411                     break;
1412                 s = PL_parser->bufptr;
1413                 bufend = PL_parser->bufend;
1414             }
1415         }
1416         unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1417         if (retlen == (STRLEN)-1) {
1418             /* malformed UTF-8 */
1419             ENTER;
1420             SAVESPTR(PL_warnhook);
1421             PL_warnhook = PERL_WARNHOOK_FATAL;
1422             utf8n_to_uvchr((U8*)s, bufend-s, NULL, 0);
1423             LEAVE;
1424         }
1425         return unichar;
1426     } else {
1427         if (s == bufend) {
1428             if (!lex_next_chunk(flags))
1429                 return -1;
1430             s = PL_parser->bufptr;
1431         }
1432         return (U8)*s;
1433     }
1434 }
1435
1436 /*
1437 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1438
1439 Reads the next (Unicode) character in the text currently being lexed.
1440 Returns the codepoint (unsigned integer value) of the character read,
1441 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1442 if lexing has reached the end of the input text.  To non-destructively
1443 examine the next character, use L</lex_peek_unichar> instead.
1444
1445 If the next character is in (or extends into) the next chunk of input
1446 text, the next chunk will be read in.  Normally the current chunk will be
1447 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1448 bit set, then the current chunk will not be discarded.
1449
1450 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1451 is encountered, an exception is generated.
1452
1453 =cut
1454 */
1455
1456 I32
1457 Perl_lex_read_unichar(pTHX_ U32 flags)
1458 {
1459     I32 c;
1460     if (flags & ~(LEX_KEEP_PREVIOUS))
1461         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1462     c = lex_peek_unichar(flags);
1463     if (c != -1) {
1464         if (c == '\n')
1465             COPLINE_INC_WITH_HERELINES;
1466         if (UTF)
1467             PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1468         else
1469             ++(PL_parser->bufptr);
1470     }
1471     return c;
1472 }
1473
1474 /*
1475 =for apidoc Amx|void|lex_read_space|U32 flags
1476
1477 Reads optional spaces, in Perl style, in the text currently being
1478 lexed.  The spaces may include ordinary whitespace characters and
1479 Perl-style comments.  C<#line> directives are processed if encountered.
1480 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1481 at a non-space character (or the end of the input text).
1482
1483 If spaces extend into the next chunk of input text, the next chunk will
1484 be read in.  Normally the current chunk will be discarded at the same
1485 time, but if C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, then the current
1486 chunk will not be discarded.
1487
1488 =cut
1489 */
1490
1491 #define LEX_NO_INCLINE    0x40000000
1492 #define LEX_NO_NEXT_CHUNK 0x80000000
1493
1494 void
1495 Perl_lex_read_space(pTHX_ U32 flags)
1496 {
1497     char *s, *bufend;
1498     const bool can_incline = !(flags & LEX_NO_INCLINE);
1499     bool need_incline = 0;
1500     if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1501         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1502     s = PL_parser->bufptr;
1503     bufend = PL_parser->bufend;
1504     while (1) {
1505         char c = *s;
1506         if (c == '#') {
1507             do {
1508                 c = *++s;
1509             } while (!(c == '\n' || (c == 0 && s == bufend)));
1510         } else if (c == '\n') {
1511             s++;
1512             if (can_incline) {
1513                 PL_parser->linestart = s;
1514                 if (s == bufend)
1515                     need_incline = 1;
1516                 else
1517                     incline(s);
1518             }
1519         } else if (isSPACE(c)) {
1520             s++;
1521         } else if (c == 0 && s == bufend) {
1522             bool got_more;
1523             line_t l;
1524             if (flags & LEX_NO_NEXT_CHUNK)
1525                 break;
1526             PL_parser->bufptr = s;
1527             l = CopLINE(PL_curcop);
1528             CopLINE(PL_curcop) += PL_parser->herelines + 1;
1529             got_more = lex_next_chunk(flags);
1530             CopLINE_set(PL_curcop, l);
1531             s = PL_parser->bufptr;
1532             bufend = PL_parser->bufend;
1533             if (!got_more)
1534                 break;
1535             if (can_incline && need_incline && PL_parser->rsfp) {
1536                 incline(s);
1537                 need_incline = 0;
1538             }
1539         } else if (!c) {
1540             s++;
1541         } else {
1542             break;
1543         }
1544     }
1545     PL_parser->bufptr = s;
1546 }
1547
1548 /*
1549
1550 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1551
1552 This function performs syntax checking on a prototype, C<proto>.
1553 If C<warn> is true, any illegal characters or mismatched brackets
1554 will trigger illegalproto warnings, declaring that they were
1555 detected in the prototype for C<name>.
1556
1557 The return value is C<true> if this is a valid prototype, and
1558 C<false> if it is not, regardless of whether C<warn> was C<true> or
1559 C<false>.
1560
1561 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1562
1563 =cut
1564
1565  */
1566
1567 bool
1568 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1569 {
1570     STRLEN len, origlen;
1571     char *p = proto ? SvPV(proto, len) : NULL;
1572     bool bad_proto = FALSE;
1573     bool in_brackets = FALSE;
1574     bool after_slash = FALSE;
1575     char greedy_proto = ' ';
1576     bool proto_after_greedy_proto = FALSE;
1577     bool must_be_last = FALSE;
1578     bool underscore = FALSE;
1579     bool bad_proto_after_underscore = FALSE;
1580
1581     PERL_ARGS_ASSERT_VALIDATE_PROTO;
1582
1583     if (!proto)
1584         return TRUE;
1585
1586     origlen = len;
1587     for (; len--; p++) {
1588         if (!isSPACE(*p)) {
1589             if (must_be_last)
1590                 proto_after_greedy_proto = TRUE;
1591             if (underscore) {
1592                 if (!strchr(";@%", *p))
1593                     bad_proto_after_underscore = TRUE;
1594                 underscore = FALSE;
1595             }
1596             if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1597                 bad_proto = TRUE;
1598             }
1599             else {
1600                 if (*p == '[')
1601                     in_brackets = TRUE;
1602                 else if (*p == ']')
1603                     in_brackets = FALSE;
1604                 else if ((*p == '@' || *p == '%')
1605                          && !after_slash
1606                          && !in_brackets )
1607                 {
1608                     must_be_last = TRUE;
1609                     greedy_proto = *p;
1610                 }
1611                 else if (*p == '_')
1612                     underscore = TRUE;
1613             }
1614             if (*p == '\\')
1615                 after_slash = TRUE;
1616             else
1617                 after_slash = FALSE;
1618         }
1619     }
1620
1621     if (warn) {
1622         SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1623         p -= origlen;
1624         p = SvUTF8(proto)
1625             ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1626                              origlen, UNI_DISPLAY_ISPRINT)
1627             : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1628
1629         if (proto_after_greedy_proto)
1630             Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1631                         "Prototype after '%c' for %"SVf" : %s",
1632                         greedy_proto, SVfARG(name), p);
1633         if (in_brackets)
1634             Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1635                         "Missing ']' in prototype for %"SVf" : %s",
1636                         SVfARG(name), p);
1637         if (bad_proto)
1638             Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1639                         "Illegal character in prototype for %"SVf" : %s",
1640                         SVfARG(name), p);
1641         if (bad_proto_after_underscore)
1642             Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1643                         "Illegal character after '_' in prototype for %"SVf" : %s",
1644                         SVfARG(name), p);
1645     }
1646
1647     return (! (proto_after_greedy_proto || bad_proto) );
1648 }
1649
1650 /*
1651  * S_incline
1652  * This subroutine has nothing to do with tilting, whether at windmills
1653  * or pinball tables.  Its name is short for "increment line".  It
1654  * increments the current line number in CopLINE(PL_curcop) and checks
1655  * to see whether the line starts with a comment of the form
1656  *    # line 500 "foo.pm"
1657  * If so, it sets the current line number and file to the values in the comment.
1658  */
1659
1660 STATIC void
1661 S_incline(pTHX_ const char *s)
1662 {
1663     const char *t;
1664     const char *n;
1665     const char *e;
1666     line_t line_num;
1667     UV uv;
1668
1669     PERL_ARGS_ASSERT_INCLINE;
1670
1671     COPLINE_INC_WITH_HERELINES;
1672     if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1673      && s+1 == PL_bufend && *s == ';') {
1674         /* fake newline in string eval */
1675         CopLINE_dec(PL_curcop);
1676         return;
1677     }
1678     if (*s++ != '#')
1679         return;
1680     while (SPACE_OR_TAB(*s))
1681         s++;
1682     if (strnEQ(s, "line", 4))
1683         s += 4;
1684     else
1685         return;
1686     if (SPACE_OR_TAB(*s))
1687         s++;
1688     else
1689         return;
1690     while (SPACE_OR_TAB(*s))
1691         s++;
1692     if (!isDIGIT(*s))
1693         return;
1694
1695     n = s;
1696     while (isDIGIT(*s))
1697         s++;
1698     if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1699         return;
1700     while (SPACE_OR_TAB(*s))
1701         s++;
1702     if (*s == '"' && (t = strchr(s+1, '"'))) {
1703         s++;
1704         e = t + 1;
1705     }
1706     else {
1707         t = s;
1708         while (*t && !isSPACE(*t))
1709             t++;
1710         e = t;
1711     }
1712     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1713         e++;
1714     if (*e != '\n' && *e != '\0')
1715         return;         /* false alarm */
1716
1717     if (!grok_atoUV(n, &uv, &e))
1718         return;
1719     line_num = ((line_t)uv) - 1;
1720
1721     if (t - s > 0) {
1722         const STRLEN len = t - s;
1723
1724         if (!PL_rsfp && !PL_parser->filtered) {
1725             /* must copy *{"::_<(eval N)[oldfilename:L]"}
1726              * to *{"::_<newfilename"} */
1727             /* However, the long form of evals is only turned on by the
1728                debugger - usually they're "(eval %lu)" */
1729             GV * const cfgv = CopFILEGV(PL_curcop);
1730             if (cfgv) {
1731                 char smallbuf[128];
1732                 STRLEN tmplen2 = len;
1733                 char *tmpbuf2;
1734                 GV *gv2;
1735
1736                 if (tmplen2 + 2 <= sizeof smallbuf)
1737                     tmpbuf2 = smallbuf;
1738                 else
1739                     Newx(tmpbuf2, tmplen2 + 2, char);
1740
1741                 tmpbuf2[0] = '_';
1742                 tmpbuf2[1] = '<';
1743
1744                 memcpy(tmpbuf2 + 2, s, tmplen2);
1745                 tmplen2 += 2;
1746
1747                 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1748                 if (!isGV(gv2)) {
1749                     gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1750                     /* adjust ${"::_<newfilename"} to store the new file name */
1751                     GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1752                     /* The line number may differ. If that is the case,
1753                        alias the saved lines that are in the array.
1754                        Otherwise alias the whole array. */
1755                     if (CopLINE(PL_curcop) == line_num) {
1756                         GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1757                         GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1758                     }
1759                     else if (GvAV(cfgv)) {
1760                         AV * const av = GvAV(cfgv);
1761                         const I32 start = CopLINE(PL_curcop)+1;
1762                         I32 items = AvFILLp(av) - start;
1763                         if (items > 0) {
1764                             AV * const av2 = GvAVn(gv2);
1765                             SV **svp = AvARRAY(av) + start;
1766                             I32 l = (I32)line_num+1;
1767                             while (items--)
1768                                 av_store(av2, l++, SvREFCNT_inc(*svp++));
1769                         }
1770                     }
1771                 }
1772
1773                 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1774             }
1775         }
1776         CopFILE_free(PL_curcop);
1777         CopFILE_setn(PL_curcop, s, len);
1778     }
1779     CopLINE_set(PL_curcop, line_num);
1780 }
1781
1782 STATIC void
1783 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1784 {
1785     AV *av = CopFILEAVx(PL_curcop);
1786     if (av) {
1787         SV * sv;
1788         if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1789         else {
1790             sv = *av_fetch(av, 0, 1);
1791             SvUPGRADE(sv, SVt_PVMG);
1792         }
1793         if (!SvPOK(sv)) sv_setpvs(sv,"");
1794         if (orig_sv)
1795             sv_catsv(sv, orig_sv);
1796         else
1797             sv_catpvn(sv, buf, len);
1798         if (!SvIOK(sv)) {
1799             (void)SvIOK_on(sv);
1800             SvIV_set(sv, 0);
1801         }
1802         if (PL_parser->preambling == NOLINE)
1803             av_store(av, CopLINE(PL_curcop), sv);
1804     }
1805 }
1806
1807 /*
1808  * skipspace
1809  * Called to gobble the appropriate amount and type of whitespace.
1810  * Skips comments as well.
1811  * Returns the next character after the whitespace that is skipped.
1812  *
1813  * peekspace
1814  * Same thing, but look ahead without incrementing line numbers or
1815  * adjusting PL_linestart.
1816  */
1817
1818 #define skipspace(s) skipspace_flags(s, 0)
1819 #define peekspace(s) skipspace_flags(s, LEX_NO_INCLINE)
1820
1821 STATIC char *
1822 S_skipspace_flags(pTHX_ char *s, U32 flags)
1823 {
1824     PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1825     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1826         while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s))
1827             s++;
1828     } else {
1829         STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1830         PL_bufptr = s;
1831         lex_read_space(flags | LEX_KEEP_PREVIOUS |
1832                 (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ?
1833                     LEX_NO_NEXT_CHUNK : 0));
1834         s = PL_bufptr;
1835         PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1836         if (PL_linestart > PL_bufptr)
1837             PL_bufptr = PL_linestart;
1838         return s;
1839     }
1840     return s;
1841 }
1842
1843 /*
1844  * S_check_uni
1845  * Check the unary operators to ensure there's no ambiguity in how they're
1846  * used.  An ambiguous piece of code would be:
1847  *     rand + 5
1848  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
1849  * the +5 is its argument.
1850  */
1851
1852 STATIC void
1853 S_check_uni(pTHX)
1854 {
1855     const char *s;
1856     const char *t;
1857
1858     if (PL_oldoldbufptr != PL_last_uni)
1859         return;
1860     while (isSPACE(*PL_last_uni))
1861         PL_last_uni++;
1862     s = PL_last_uni;
1863     while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1864         s += UTF ? UTF8SKIP(s) : 1;
1865     if ((t = strchr(s, '(')) && t < PL_bufptr)
1866         return;
1867
1868     Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1869                      "Warning: Use of \"%"UTF8f"\" without parentheses is ambiguous",
1870                      UTF8fARG(UTF, (int)(s - PL_last_uni), PL_last_uni));
1871 }
1872
1873 /*
1874  * LOP : macro to build a list operator.  Its behaviour has been replaced
1875  * with a subroutine, S_lop() for which LOP is just another name.
1876  */
1877
1878 #define LOP(f,x) return lop(f,x,s)
1879
1880 /*
1881  * S_lop
1882  * Build a list operator (or something that might be one).  The rules:
1883  *  - if we have a next token, then it's a list operator (no parens) for
1884  *    which the next token has already been parsed; e.g.,
1885  *       sort foo @args
1886  *       sort foo (@args)
1887  *  - if the next thing is an opening paren, then it's a function
1888  *  - else it's a list operator
1889  */
1890
1891 STATIC I32
1892 S_lop(pTHX_ I32 f, int x, char *s)
1893 {
1894     PERL_ARGS_ASSERT_LOP;
1895
1896     pl_yylval.ival = f;
1897     CLINE;
1898     PL_bufptr = s;
1899     PL_last_lop = PL_oldbufptr;
1900     PL_last_lop_op = (OPCODE)f;
1901     if (PL_nexttoke)
1902         goto lstop;
1903     PL_expect = x;
1904     if (*s == '(')
1905         return REPORT(FUNC);
1906     s = skipspace(s);
1907     if (*s == '(')
1908         return REPORT(FUNC);
1909     else {
1910         lstop:
1911         if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1912             PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1913         return REPORT(LSTOP);
1914     }
1915 }
1916
1917 /*
1918  * S_force_next
1919  * When the lexer realizes it knows the next token (for instance,
1920  * it is reordering tokens for the parser) then it can call S_force_next
1921  * to know what token to return the next time the lexer is called.  Caller
1922  * will need to set PL_nextval[] and possibly PL_expect to ensure
1923  * the lexer handles the token correctly.
1924  */
1925
1926 STATIC void
1927 S_force_next(pTHX_ I32 type)
1928 {
1929 #ifdef DEBUGGING
1930     if (DEBUG_T_TEST) {
1931         PerlIO_printf(Perl_debug_log, "### forced token:\n");
1932         tokereport(type, &NEXTVAL_NEXTTOKE);
1933     }
1934 #endif
1935     assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype));
1936     PL_nexttype[PL_nexttoke] = type;
1937     PL_nexttoke++;
1938 }
1939
1940 /*
1941  * S_postderef
1942  *
1943  * This subroutine handles postfix deref syntax after the arrow has already
1944  * been emitted.  @* $* etc. are emitted as two separate token right here.
1945  * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
1946  * only the first, leaving yylex to find the next.
1947  */
1948
1949 static int
1950 S_postderef(pTHX_ int const funny, char const next)
1951 {
1952     assert(funny == DOLSHARP || strchr("$@%&*", funny));
1953     if (next == '*') {
1954         PL_expect = XOPERATOR;
1955         if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
1956             assert('@' == funny || '$' == funny || DOLSHARP == funny);
1957             PL_lex_state = LEX_INTERPEND;
1958             if ('@' == funny)
1959                 force_next(POSTJOIN);
1960         }
1961         force_next(next);
1962         PL_bufptr+=2;
1963     }
1964     else {
1965         if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
1966          && !PL_lex_brackets)
1967             PL_lex_dojoin = 2;
1968         PL_expect = XOPERATOR;
1969         PL_bufptr++;
1970     }
1971     return funny;
1972 }
1973
1974 void
1975 Perl_yyunlex(pTHX)
1976 {
1977     int yyc = PL_parser->yychar;
1978     if (yyc != YYEMPTY) {
1979         if (yyc) {
1980             NEXTVAL_NEXTTOKE = PL_parser->yylval;
1981             if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
1982                 PL_lex_allbrackets--;
1983                 PL_lex_brackets--;
1984                 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
1985             } else if (yyc == '('/*)*/) {
1986                 PL_lex_allbrackets--;
1987                 yyc |= (2<<24);
1988             }
1989             force_next(yyc);
1990         }
1991         PL_parser->yychar = YYEMPTY;
1992     }
1993 }
1994
1995 STATIC SV *
1996 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1997 {
1998     SV * const sv = newSVpvn_utf8(start, len,
1999                           !IN_BYTES
2000                           && UTF
2001                           && !is_utf8_invariant_string((const U8*)start, len)
2002                           && is_utf8_string((const U8*)start, len));
2003     return sv;
2004 }
2005
2006 /*
2007  * S_force_word
2008  * When the lexer knows the next thing is a word (for instance, it has
2009  * just seen -> and it knows that the next char is a word char, then
2010  * it calls S_force_word to stick the next word into the PL_nexttoke/val
2011  * lookahead.
2012  *
2013  * Arguments:
2014  *   char *start : buffer position (must be within PL_linestr)
2015  *   int token   : PL_next* will be this type of bare word
2016  *                 (e.g., METHOD,BAREWORD)
2017  *   int check_keyword : if true, Perl checks to make sure the word isn't
2018  *       a keyword (do this if the word is a label, e.g. goto FOO)
2019  *   int allow_pack : if true, : characters will also be allowed (require,
2020  *       use, etc. do this)
2021  */
2022
2023 STATIC char *
2024 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2025 {
2026     char *s;
2027     STRLEN len;
2028
2029     PERL_ARGS_ASSERT_FORCE_WORD;
2030
2031     start = skipspace(start);
2032     s = start;
2033     if (isIDFIRST_lazy_if(s,UTF)
2034         || (allow_pack && *s == ':' && s[1] == ':') )
2035     {
2036         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2037         if (check_keyword) {
2038           char *s2 = PL_tokenbuf;
2039           STRLEN len2 = len;
2040           if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2041             s2 += 6, len2 -= 6;
2042           if (keyword(s2, len2, 0))
2043             return start;
2044         }
2045         if (token == METHOD) {
2046             s = skipspace(s);
2047             if (*s == '(')
2048                 PL_expect = XTERM;
2049             else {
2050                 PL_expect = XOPERATOR;
2051             }
2052         }
2053         NEXTVAL_NEXTTOKE.opval
2054             = (OP*)newSVOP(OP_CONST,0,
2055                            S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2056         NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2057         force_next(token);
2058     }
2059     return s;
2060 }
2061
2062 /*
2063  * S_force_ident
2064  * Called when the lexer wants $foo *foo &foo etc, but the program
2065  * text only contains the "foo" portion.  The first argument is a pointer
2066  * to the "foo", and the second argument is the type symbol to prefix.
2067  * Forces the next token to be a "BAREWORD".
2068  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2069  */
2070
2071 STATIC void
2072 S_force_ident(pTHX_ const char *s, int kind)
2073 {
2074     PERL_ARGS_ASSERT_FORCE_IDENT;
2075
2076     if (s[0]) {
2077         const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2078         OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2079                                                                 UTF ? SVf_UTF8 : 0));
2080         NEXTVAL_NEXTTOKE.opval = o;
2081         force_next(BAREWORD);
2082         if (kind) {
2083             o->op_private = OPpCONST_ENTERED;
2084             /* XXX see note in pp_entereval() for why we forgo typo
2085                warnings if the symbol must be introduced in an eval.
2086                GSAR 96-10-12 */
2087             gv_fetchpvn_flags(s, len,
2088                               (PL_in_eval ? GV_ADDMULTI
2089                               : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2090                               kind == '$' ? SVt_PV :
2091                               kind == '@' ? SVt_PVAV :
2092                               kind == '%' ? SVt_PVHV :
2093                               SVt_PVGV
2094                               );
2095         }
2096     }
2097 }
2098
2099 static void
2100 S_force_ident_maybe_lex(pTHX_ char pit)
2101 {
2102     NEXTVAL_NEXTTOKE.ival = pit;
2103     force_next('p');
2104 }
2105
2106 NV
2107 Perl_str_to_version(pTHX_ SV *sv)
2108 {
2109     NV retval = 0.0;
2110     NV nshift = 1.0;
2111     STRLEN len;
2112     const char *start = SvPV_const(sv,len);
2113     const char * const end = start + len;
2114     const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2115
2116     PERL_ARGS_ASSERT_STR_TO_VERSION;
2117
2118     while (start < end) {
2119         STRLEN skip;
2120         UV n;
2121         if (utf)
2122             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2123         else {
2124             n = *(U8*)start;
2125             skip = 1;
2126         }
2127         retval += ((NV)n)/nshift;
2128         start += skip;
2129         nshift *= 1000;
2130     }
2131     return retval;
2132 }
2133
2134 /*
2135  * S_force_version
2136  * Forces the next token to be a version number.
2137  * If the next token appears to be an invalid version number, (e.g. "v2b"),
2138  * and if "guessing" is TRUE, then no new token is created (and the caller
2139  * must use an alternative parsing method).
2140  */
2141
2142 STATIC char *
2143 S_force_version(pTHX_ char *s, int guessing)
2144 {
2145     OP *version = NULL;
2146     char *d;
2147
2148     PERL_ARGS_ASSERT_FORCE_VERSION;
2149
2150     s = skipspace(s);
2151
2152     d = s;
2153     if (*d == 'v')
2154         d++;
2155     if (isDIGIT(*d)) {
2156         while (isDIGIT(*d) || *d == '_' || *d == '.')
2157             d++;
2158         if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2159             SV *ver;
2160             s = scan_num(s, &pl_yylval);
2161             version = pl_yylval.opval;
2162             ver = cSVOPx(version)->op_sv;
2163             if (SvPOK(ver) && !SvNIOK(ver)) {
2164                 SvUPGRADE(ver, SVt_PVNV);
2165                 SvNV_set(ver, str_to_version(ver));
2166                 SvNOK_on(ver);          /* hint that it is a version */
2167             }
2168         }
2169         else if (guessing) {
2170             return s;
2171         }
2172     }
2173
2174     /* NOTE: The parser sees the package name and the VERSION swapped */
2175     NEXTVAL_NEXTTOKE.opval = version;
2176     force_next(BAREWORD);
2177
2178     return s;
2179 }
2180
2181 /*
2182  * S_force_strict_version
2183  * Forces the next token to be a version number using strict syntax rules.
2184  */
2185
2186 STATIC char *
2187 S_force_strict_version(pTHX_ char *s)
2188 {
2189     OP *version = NULL;
2190     const char *errstr = NULL;
2191
2192     PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2193
2194     while (isSPACE(*s)) /* leading whitespace */
2195         s++;
2196
2197     if (is_STRICT_VERSION(s,&errstr)) {
2198         SV *ver = newSV(0);
2199         s = (char *)scan_version(s, ver, 0);
2200         version = newSVOP(OP_CONST, 0, ver);
2201     }
2202     else if ((*s != ';' && *s != '{' && *s != '}' )
2203              && (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2204     {
2205         PL_bufptr = s;
2206         if (errstr)
2207             yyerror(errstr); /* version required */
2208         return s;
2209     }
2210
2211     /* NOTE: The parser sees the package name and the VERSION swapped */
2212     NEXTVAL_NEXTTOKE.opval = version;
2213     force_next(BAREWORD);
2214
2215     return s;
2216 }
2217
2218 /*
2219  * S_tokeq
2220  * Tokenize a quoted string passed in as an SV.  It finds the next
2221  * chunk, up to end of string or a backslash.  It may make a new
2222  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
2223  * turns \\ into \.
2224  */
2225
2226 STATIC SV *
2227 S_tokeq(pTHX_ SV *sv)
2228 {
2229     char *s;
2230     char *send;
2231     char *d;
2232     SV *pv = sv;
2233
2234     PERL_ARGS_ASSERT_TOKEQ;
2235
2236     assert (SvPOK(sv));
2237     assert (SvLEN(sv));
2238     assert (!SvIsCOW(sv));
2239     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2240         goto finish;
2241     s = SvPVX(sv);
2242     send = SvEND(sv);
2243     /* This is relying on the SV being "well formed" with a trailing '\0'  */
2244     while (s < send && !(*s == '\\' && s[1] == '\\'))
2245         s++;
2246     if (s == send)
2247         goto finish;
2248     d = s;
2249     if ( PL_hints & HINT_NEW_STRING ) {
2250         pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2251                             SVs_TEMP | SvUTF8(sv));
2252     }
2253     while (s < send) {
2254         if (*s == '\\') {
2255             if (s + 1 < send && (s[1] == '\\'))
2256                 s++;            /* all that, just for this */
2257         }
2258         *d++ = *s++;
2259     }
2260     *d = '\0';
2261     SvCUR_set(sv, d - SvPVX_const(sv));
2262   finish:
2263     if ( PL_hints & HINT_NEW_STRING )
2264        return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2265     return sv;
2266 }
2267
2268 /*
2269  * Now come three functions related to double-quote context,
2270  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
2271  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
2272  * interact with PL_lex_state, and create fake ( ... ) argument lists
2273  * to handle functions and concatenation.
2274  * For example,
2275  *   "foo\lbar"
2276  * is tokenised as
2277  *    stringify ( const[foo] concat lcfirst ( const[bar] ) )
2278  */
2279
2280 /*
2281  * S_sublex_start
2282  * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2283  *
2284  * Pattern matching will set PL_lex_op to the pattern-matching op to
2285  * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2286  *
2287  * OP_CONST and OP_READLINE are easy--just make the new op and return.
2288  *
2289  * Everything else becomes a FUNC.
2290  *
2291  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2292  * had an OP_CONST or OP_READLINE).  This just sets us up for a
2293  * call to S_sublex_push().
2294  */
2295
2296 STATIC I32
2297 S_sublex_start(pTHX)
2298 {
2299     const I32 op_type = pl_yylval.ival;
2300
2301     if (op_type == OP_NULL) {
2302         pl_yylval.opval = PL_lex_op;
2303         PL_lex_op = NULL;
2304         return THING;
2305     }
2306     if (op_type == OP_CONST) {
2307         SV *sv = PL_lex_stuff;
2308         PL_lex_stuff = NULL;
2309         sv = tokeq(sv);
2310
2311         if (SvTYPE(sv) == SVt_PVIV) {
2312             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2313             STRLEN len;
2314             const char * const p = SvPV_const(sv, len);
2315             SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2316             SvREFCNT_dec(sv);
2317             sv = nsv;
2318         }
2319         pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2320         return THING;
2321     }
2322
2323     PL_parser->lex_super_state = PL_lex_state;
2324     PL_parser->lex_sub_inwhat = (U16)op_type;
2325     PL_parser->lex_sub_op = PL_lex_op;
2326     PL_lex_state = LEX_INTERPPUSH;
2327
2328     PL_expect = XTERM;
2329     if (PL_lex_op) {
2330         pl_yylval.opval = PL_lex_op;
2331         PL_lex_op = NULL;
2332         return PMFUNC;
2333     }
2334     else
2335         return FUNC;
2336 }
2337
2338 /*
2339  * S_sublex_push
2340  * Create a new scope to save the lexing state.  The scope will be
2341  * ended in S_sublex_done.  Returns a '(', starting the function arguments
2342  * to the uc, lc, etc. found before.
2343  * Sets PL_lex_state to LEX_INTERPCONCAT.
2344  */
2345
2346 STATIC I32
2347 S_sublex_push(pTHX)
2348 {
2349     LEXSHARED *shared;
2350     const bool is_heredoc = PL_multi_close == '<';
2351     ENTER;
2352
2353     PL_lex_state = PL_parser->lex_super_state;
2354     SAVEI8(PL_lex_dojoin);
2355     SAVEI32(PL_lex_brackets);
2356     SAVEI32(PL_lex_allbrackets);
2357     SAVEI32(PL_lex_formbrack);
2358     SAVEI8(PL_lex_fakeeof);
2359     SAVEI32(PL_lex_casemods);
2360     SAVEI32(PL_lex_starts);
2361     SAVEI8(PL_lex_state);
2362     SAVESPTR(PL_lex_repl);
2363     SAVEVPTR(PL_lex_inpat);
2364     SAVEI16(PL_lex_inwhat);
2365     if (is_heredoc)
2366     {
2367         SAVECOPLINE(PL_curcop);
2368         SAVEI32(PL_multi_end);
2369         SAVEI32(PL_parser->herelines);
2370         PL_parser->herelines = 0;
2371     }
2372     SAVEIV(PL_multi_close);
2373     SAVEPPTR(PL_bufptr);
2374     SAVEPPTR(PL_bufend);
2375     SAVEPPTR(PL_oldbufptr);
2376     SAVEPPTR(PL_oldoldbufptr);
2377     SAVEPPTR(PL_last_lop);
2378     SAVEPPTR(PL_last_uni);
2379     SAVEPPTR(PL_linestart);
2380     SAVESPTR(PL_linestr);
2381     SAVEGENERICPV(PL_lex_brackstack);
2382     SAVEGENERICPV(PL_lex_casestack);
2383     SAVEGENERICPV(PL_parser->lex_shared);
2384     SAVEBOOL(PL_parser->lex_re_reparsing);
2385     SAVEI32(PL_copline);
2386
2387     /* The here-doc parser needs to be able to peek into outer lexing
2388        scopes to find the body of the here-doc.  So we put PL_linestr and
2389        PL_bufptr into lex_shared, to ‘share’ those values.
2390      */
2391     PL_parser->lex_shared->ls_linestr = PL_linestr;
2392     PL_parser->lex_shared->ls_bufptr  = PL_bufptr;
2393
2394     PL_linestr = PL_lex_stuff;
2395     PL_lex_repl = PL_parser->lex_sub_repl;
2396     PL_lex_stuff = NULL;
2397     PL_parser->lex_sub_repl = NULL;
2398
2399     /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2400        set for an inner quote-like operator and then an error causes scope-
2401        popping.  We must not have a PL_lex_stuff value left dangling, as
2402        that breaks assumptions elsewhere.  See bug #123617.  */
2403     SAVEGENERICSV(PL_lex_stuff);
2404     SAVEGENERICSV(PL_parser->lex_sub_repl);
2405
2406     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2407         = SvPVX(PL_linestr);
2408     PL_bufend += SvCUR(PL_linestr);
2409     PL_last_lop = PL_last_uni = NULL;
2410     SAVEFREESV(PL_linestr);
2411     if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2412
2413     PL_lex_dojoin = FALSE;
2414     PL_lex_brackets = PL_lex_formbrack = 0;
2415     PL_lex_allbrackets = 0;
2416     PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2417     Newx(PL_lex_brackstack, 120, char);
2418     Newx(PL_lex_casestack, 12, char);
2419     PL_lex_casemods = 0;
2420     *PL_lex_casestack = '\0';
2421     PL_lex_starts = 0;
2422     PL_lex_state = LEX_INTERPCONCAT;
2423     if (is_heredoc)
2424         CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2425     PL_copline = NOLINE;
2426     
2427     Newxz(shared, 1, LEXSHARED);
2428     shared->ls_prev = PL_parser->lex_shared;
2429     PL_parser->lex_shared = shared;
2430
2431     PL_lex_inwhat = PL_parser->lex_sub_inwhat;
2432     if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2433     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2434         PL_lex_inpat = PL_parser->lex_sub_op;
2435     else
2436         PL_lex_inpat = NULL;
2437
2438     PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2439     PL_in_eval &= ~EVAL_RE_REPARSING;
2440
2441     return '(';
2442 }
2443
2444 /*
2445  * S_sublex_done
2446  * Restores lexer state after a S_sublex_push.
2447  */
2448
2449 STATIC I32
2450 S_sublex_done(pTHX)
2451 {
2452     if (!PL_lex_starts++) {
2453         SV * const sv = newSVpvs("");
2454         if (SvUTF8(PL_linestr))
2455             SvUTF8_on(sv);
2456         PL_expect = XOPERATOR;
2457         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2458         return THING;
2459     }
2460
2461     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
2462         PL_lex_state = LEX_INTERPCASEMOD;
2463         return yylex();
2464     }
2465
2466     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2467     assert(PL_lex_inwhat != OP_TRANSR);
2468     if (PL_lex_repl) {
2469         assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2470         PL_linestr = PL_lex_repl;
2471         PL_lex_inpat = 0;
2472         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2473         PL_bufend += SvCUR(PL_linestr);
2474         PL_last_lop = PL_last_uni = NULL;
2475         PL_lex_dojoin = FALSE;
2476         PL_lex_brackets = 0;
2477         PL_lex_allbrackets = 0;
2478         PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2479         PL_lex_casemods = 0;
2480         *PL_lex_casestack = '\0';
2481         PL_lex_starts = 0;
2482         if (SvEVALED(PL_lex_repl)) {
2483             PL_lex_state = LEX_INTERPNORMAL;
2484             PL_lex_starts++;
2485             /*  we don't clear PL_lex_repl here, so that we can check later
2486                 whether this is an evalled subst; that means we rely on the
2487                 logic to ensure sublex_done() is called again only via the
2488                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2489         }
2490         else {
2491             PL_lex_state = LEX_INTERPCONCAT;
2492             PL_lex_repl = NULL;
2493         }
2494         if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2495             CopLINE(PL_curcop) +=
2496                 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xnv_lines
2497                  + PL_parser->herelines;
2498             PL_parser->herelines = 0;
2499         }
2500         return '/';
2501     }
2502     else {
2503         const line_t l = CopLINE(PL_curcop);
2504         LEAVE;
2505         if (PL_multi_close == '<')
2506             PL_parser->herelines += l - PL_multi_end;
2507         PL_bufend = SvPVX(PL_linestr);
2508         PL_bufend += SvCUR(PL_linestr);
2509         PL_expect = XOPERATOR;
2510         return ')';
2511     }
2512 }
2513
2514 PERL_STATIC_INLINE SV*
2515 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2516 {
2517     /* <s> points to first character of interior of \N{}, <e> to one beyond the
2518      * interior, hence to the "}".  Finds what the name resolves to, returning
2519      * an SV* containing it; NULL if no valid one found */
2520
2521     SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2522
2523     HV * table;
2524     SV **cvp;
2525     SV *cv;
2526     SV *rv;
2527     HV *stash;
2528     const U8* first_bad_char_loc;
2529     const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2530
2531     PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2532
2533     if (!SvCUR(res)) {
2534         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
2535                        "Unknown charname '' is deprecated");
2536         return res;
2537     }
2538
2539     if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2540                                      e - backslash_ptr,
2541                                      &first_bad_char_loc))
2542     {
2543         /* If warnings are on, this will print a more detailed analysis of what
2544          * is wrong than the error message below */
2545         utf8n_to_uvchr(first_bad_char_loc,
2546                        e - ((char *) first_bad_char_loc),
2547                        NULL, 0);
2548
2549         /* We deliberately don't try to print the malformed character, which
2550          * might not print very well; it also may be just the first of many
2551          * malformations, so don't print what comes after it */
2552         yyerror_pv(Perl_form(aTHX_
2553             "Malformed UTF-8 character immediately after '%.*s'",
2554             (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr),
2555                    SVf_UTF8);
2556         return NULL;
2557     }
2558
2559     res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2560                         /* include the <}> */
2561                         e - backslash_ptr + 1);
2562     if (! SvPOK(res)) {
2563         SvREFCNT_dec_NN(res);
2564         return NULL;
2565     }
2566
2567     /* See if the charnames handler is the Perl core's, and if so, we can skip
2568      * the validation needed for a user-supplied one, as Perl's does its own
2569      * validation. */
2570     table = GvHV(PL_hintgv);             /* ^H */
2571     cvp = hv_fetchs(table, "charnames", FALSE);
2572     if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2573         SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2574     {
2575         const char * const name = HvNAME(stash);
2576         if (HvNAMELEN(stash) == sizeof("_charnames")-1
2577          && strEQ(name, "_charnames")) {
2578            return res;
2579        }
2580     }
2581
2582     /* Here, it isn't Perl's charname handler.  We can't rely on a
2583      * user-supplied handler to validate the input name.  For non-ut8 input,
2584      * look to see that the first character is legal.  Then loop through the
2585      * rest checking that each is a continuation */
2586
2587     /* This code makes the reasonable assumption that the only Latin1-range
2588      * characters that begin a character name alias are alphabetic, otherwise
2589      * would have to create a isCHARNAME_BEGIN macro */
2590
2591     if (! UTF) {
2592         if (! isALPHAU(*s)) {
2593             goto bad_charname;
2594         }
2595         s++;
2596         while (s < e) {
2597             if (! isCHARNAME_CONT(*s)) {
2598                 goto bad_charname;
2599             }
2600             if (*s == ' ' && *(s-1) == ' ') {
2601                 goto multi_spaces;
2602             }
2603             s++;
2604         }
2605     }
2606     else {
2607         /* Similarly for utf8.  For invariants can check directly; for other
2608          * Latin1, can calculate their code point and check; otherwise  use a
2609          * swash */
2610         if (UTF8_IS_INVARIANT(*s)) {
2611             if (! isALPHAU(*s)) {
2612                 goto bad_charname;
2613             }
2614             s++;
2615         } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2616             if (! isALPHAU(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1)))) {
2617                 goto bad_charname;
2618             }
2619             s += 2;
2620         }
2621         else {
2622             if (! PL_utf8_charname_begin) {
2623                 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2624                 PL_utf8_charname_begin = _core_swash_init("utf8",
2625                                                         "_Perl_Charname_Begin",
2626                                                         &PL_sv_undef,
2627                                                         1, 0, NULL, &flags);
2628             }
2629             if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2630                 goto bad_charname;
2631             }
2632             s += UTF8SKIP(s);
2633         }
2634
2635         while (s < e) {
2636             if (UTF8_IS_INVARIANT(*s)) {
2637                 if (! isCHARNAME_CONT(*s)) {
2638                     goto bad_charname;
2639                 }
2640                 if (*s == ' ' && *(s-1) == ' ') {
2641                     goto multi_spaces;
2642                 }
2643                 s++;
2644             }
2645             else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2646                 if (! isCHARNAME_CONT(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1))))
2647                 {
2648                     goto bad_charname;
2649                 }
2650                 s += 2;
2651             }
2652             else {
2653                 if (! PL_utf8_charname_continue) {
2654                     U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2655                     PL_utf8_charname_continue = _core_swash_init("utf8",
2656                                                 "_Perl_Charname_Continue",
2657                                                 &PL_sv_undef,
2658                                                 1, 0, NULL, &flags);
2659                 }
2660                 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2661                     goto bad_charname;
2662                 }
2663                 s += UTF8SKIP(s);
2664             }
2665         }
2666     }
2667     if (*(s-1) == ' ') {
2668         yyerror_pv(
2669             Perl_form(aTHX_
2670             "charnames alias definitions may not contain trailing "
2671             "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2672             (int)(s - backslash_ptr + 1), backslash_ptr,
2673             (int)(e - s + 1), s + 1
2674             ),
2675         UTF ? SVf_UTF8 : 0);
2676         return NULL;
2677     }
2678
2679     if (SvUTF8(res)) { /* Don't accept malformed input */
2680         const U8* first_bad_char_loc;
2681         STRLEN len;
2682         const char* const str = SvPV_const(res, len);
2683         if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2684             /* If warnings are on, this will print a more detailed analysis of
2685              * what is wrong than the error message below */
2686             utf8n_to_uvchr(first_bad_char_loc,
2687                            (char *) first_bad_char_loc - str,
2688                            NULL, 0);
2689
2690             /* We deliberately don't try to print the malformed character,
2691              * which might not print very well; it also may be just the first
2692              * of many malformations, so don't print what comes after it */
2693             yyerror_pv(
2694               Perl_form(aTHX_
2695                 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2696                  (int) (e - backslash_ptr + 1), backslash_ptr,
2697                  (int) ((char *) first_bad_char_loc - str), str
2698               ),
2699               SVf_UTF8);
2700             return NULL;
2701         }
2702     }
2703
2704     return res;
2705
2706   bad_charname: {
2707
2708         /* The final %.*s makes sure that should the trailing NUL be missing
2709          * that this print won't run off the end of the string */
2710         yyerror_pv(
2711           Perl_form(aTHX_
2712             "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2713             (int)(s - backslash_ptr + 1), backslash_ptr,
2714             (int)(e - s + 1), s + 1
2715           ),
2716           UTF ? SVf_UTF8 : 0);
2717         return NULL;
2718     }
2719
2720   multi_spaces:
2721         yyerror_pv(
2722           Perl_form(aTHX_
2723             "charnames alias definitions may not contain a sequence of "
2724             "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2725             (int)(s - backslash_ptr + 1), backslash_ptr,
2726             (int)(e - s + 1), s + 1
2727           ),
2728           UTF ? SVf_UTF8 : 0);
2729         return NULL;
2730 }
2731
2732 /*
2733   scan_const
2734
2735   Extracts the next constant part of a pattern, double-quoted string,
2736   or transliteration.  This is terrifying code.
2737
2738   For example, in parsing the double-quoted string "ab\x63$d", it would
2739   stop at the '$' and return an OP_CONST containing 'abc'.
2740
2741   It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2742   processing a pattern (PL_lex_inpat is true), a transliteration
2743   (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2744
2745   Returns a pointer to the character scanned up to. If this is
2746   advanced from the start pointer supplied (i.e. if anything was
2747   successfully parsed), will leave an OP_CONST for the substring scanned
2748   in pl_yylval. Caller must intuit reason for not parsing further
2749   by looking at the next characters herself.
2750
2751   In patterns:
2752     expand:
2753       \N{FOO}  => \N{U+hex_for_character_FOO}
2754       (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2755
2756     pass through:
2757         all other \-char, including \N and \N{ apart from \N{ABC}
2758
2759     stops on:
2760         @ and $ where it appears to be a var, but not for $ as tail anchor
2761         \l \L \u \U \Q \E
2762         (?{  or  (??{
2763
2764   In transliterations:
2765     characters are VERY literal, except for - not at the start or end
2766     of the string, which indicates a range. If the range is in bytes,
2767     scan_const expands the range to the full set of intermediate
2768     characters. If the range is in utf8, the hyphen is replaced with
2769     a certain range mark which will be handled by pmtrans() in op.c.
2770
2771   In double-quoted strings:
2772     backslashes:
2773       double-quoted style: \r and \n
2774       constants: \x31, etc.
2775       deprecated backrefs: \1 (in substitution replacements)
2776       case and quoting: \U \Q \E
2777     stops on @ and $
2778
2779   scan_const does *not* construct ops to handle interpolated strings.
2780   It stops processing as soon as it finds an embedded $ or @ variable
2781   and leaves it to the caller to work out what's going on.
2782
2783   embedded arrays (whether in pattern or not) could be:
2784       @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2785
2786   $ in double-quoted strings must be the symbol of an embedded scalar.
2787
2788   $ in pattern could be $foo or could be tail anchor.  Assumption:
2789   it's a tail anchor if $ is the last thing in the string, or if it's
2790   followed by one of "()| \r\n\t"
2791
2792   \1 (backreferences) are turned into $1 in substitutions
2793
2794   The structure of the code is
2795       while (there's a character to process) {
2796           handle transliteration ranges
2797           skip regexp comments /(?#comment)/ and codes /(?{code})/
2798           skip #-initiated comments in //x patterns
2799           check for embedded arrays
2800           check for embedded scalars
2801           if (backslash) {
2802               deprecate \1 in substitution replacements
2803               handle string-changing backslashes \l \U \Q \E, etc.
2804               switch (what was escaped) {
2805                   handle \- in a transliteration (becomes a literal -)
2806                   if a pattern and not \N{, go treat as regular character
2807                   handle \132 (octal characters)
2808                   handle \x15 and \x{1234} (hex characters)
2809                   handle \N{name} (named characters, also \N{3,5} in a pattern)
2810                   handle \cV (control characters)
2811                   handle printf-style backslashes (\f, \r, \n, etc)
2812               } (end switch)
2813               continue
2814           } (end if backslash)
2815           handle regular character
2816     } (end while character to read)
2817                 
2818 */
2819
2820 STATIC char *
2821 S_scan_const(pTHX_ char *start)
2822 {
2823     char *send = PL_bufend;             /* end of the constant */
2824     SV *sv = newSV(send - start);       /* sv for the constant.  See note below
2825                                            on sizing. */
2826     char *s = start;                    /* start of the constant */
2827     char *d = SvPVX(sv);                /* destination for copies */
2828     bool dorange = FALSE;               /* are we in a translit range? */
2829     bool didrange = FALSE;              /* did we just finish a range? */
2830     bool in_charclass = FALSE;          /* within /[...]/ */
2831     bool has_utf8 = FALSE;              /* Output constant is UTF8 */
2832     bool  this_utf8 = cBOOL(UTF);       /* Is the source string assumed to be
2833                                            UTF8?  But, this can show as true
2834                                            when the source isn't utf8, as for
2835                                            example when it is entirely composed
2836                                            of hex constants */
2837     SV *res;                            /* result from charnames */
2838     STRLEN offset_to_max;   /* The offset in the output to where the range
2839                                high-end character is temporarily placed */
2840
2841     /* Note on sizing:  The scanned constant is placed into sv, which is
2842      * initialized by newSV() assuming one byte of output for every byte of
2843      * input.  This routine expects newSV() to allocate an extra byte for a
2844      * trailing NUL, which this routine will append if it gets to the end of
2845      * the input.  There may be more bytes of input than output (eg., \N{LATIN
2846      * CAPITAL LETTER A}), or more output than input if the constant ends up
2847      * recoded to utf8, but each time a construct is found that might increase
2848      * the needed size, SvGROW() is called.  Its size parameter each time is
2849      * based on the best guess estimate at the time, namely the length used so
2850      * far, plus the length the current construct will occupy, plus room for
2851      * the trailing NUL, plus one byte for every input byte still unscanned */ 
2852
2853     UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2854                        before set */
2855 #ifdef EBCDIC
2856     int backslash_N = 0;            /* ? was the character from \N{} */
2857     int non_portable_endpoint = 0;  /* ? In a range is an endpoint
2858                                        platform-specific like \x65 */
2859 #endif
2860
2861     PERL_ARGS_ASSERT_SCAN_CONST;
2862
2863     assert(PL_lex_inwhat != OP_TRANSR);
2864     if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
2865         /* If we are doing a trans and we know we want UTF8 set expectation */
2866         has_utf8   = PL_parser->lex_sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2867         this_utf8  = PL_parser->lex_sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2868     }
2869
2870     /* Protect sv from errors and fatal warnings. */
2871     ENTER_with_name("scan_const");
2872     SAVEFREESV(sv);
2873
2874     while (s < send
2875            || dorange   /* Handle tr/// range at right edge of input */
2876     ) {
2877
2878         /* get transliterations out of the way (they're most literal) */
2879         if (PL_lex_inwhat == OP_TRANS) {
2880
2881             /* But there isn't any special handling necessary unless there is a
2882              * range, so for most cases we just drop down and handle the value
2883              * as any other.  There are two exceptions.
2884              *
2885              * 1.  A minus sign indicates that we are actually going to have
2886              *     a range.  In this case, skip the '-', set a flag, then drop
2887              *     down to handle what should be the end range value.
2888              * 2.  After we've handled that value, the next time through, that
2889              *     flag is set and we fix up the range.
2890              *
2891              * Ranges entirely within Latin1 are expanded out entirely, in
2892              * order to avoid the significant overhead of making a swash.
2893              * Ranges that extend above Latin1 have to have a swash, so there
2894              * is no advantage to abbreviate them here, so they are stored here
2895              * as Min, ILLEGAL_UTF8_BYTE, Max.  The illegal byte signifies a
2896              * hyphen without any possible ambiguity.  On EBCDIC machines, if
2897              * the range is expressed as Unicode, the Latin1 portion is
2898              * expanded out even if the entire range extends above Latin1.
2899              * This is because each code point in it has to be processed here
2900              * individually to get its native translation */
2901
2902             if (! dorange) {
2903
2904                 /* Here, we don't think we're in a range.  If we've processed
2905                  * at least one character, then see if this next one is a '-',
2906                  * indicating the previous one was the start of a range.  But
2907                  * don't bother if we're too close to the end for the minus to
2908                  * mean that. */
2909                 if (*s != '-' || s >= send - 1 || s == start) {
2910
2911                     /* A regular character.  Process like any other, but first
2912                      * clear any flags */
2913                     didrange = FALSE;
2914                     dorange = FALSE;
2915 #ifdef EBCDIC
2916                     non_portable_endpoint = 0;
2917                     backslash_N = 0;
2918 #endif
2919                     /* Drops down to generic code to process current byte */
2920                 }
2921                 else {
2922                     if (didrange) { /* Something like y/A-C-Z// */
2923                         Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2924                     }
2925
2926                     dorange = TRUE;
2927
2928                     s++;    /* Skip past the minus */
2929
2930                     /* d now points to where the end-range character will be
2931                      * placed.  Save it so won't have to go finding it later,
2932                      * and drop down to get that character.  (Actually we
2933                      * instead save the offset, to handle the case where a
2934                      * realloc in the meantime could change the actual
2935                      * pointer).  We'll finish processing the range the next
2936                      * time through the loop */
2937                     offset_to_max = d - SvPVX_const(sv);
2938                 }
2939             }  /* End of not a range */
2940             else {
2941                 /* Here we have parsed a range.  Now must handle it.  At this
2942                  * point:
2943                  * 'sv' is a SV* that contains the output string we are
2944                  *      constructing.  The final two characters in that string
2945                  *      are the range start and range end, in order.
2946                  * 'd'  points to just beyond the range end in the 'sv' string,
2947                  *      where we would next place something
2948                  * 'offset_to_max' is the offset in 'sv' at which the character
2949                  *      before 'd' begins.
2950                  */
2951                 const char * max_ptr = SvPVX_const(sv) + offset_to_max;
2952                 const char * min_ptr;
2953                 IV range_min;
2954                 IV range_max;   /* last character in range */
2955                 STRLEN save_offset;
2956                 STRLEN grow;
2957 #ifndef EBCDIC  /* Not meaningful except in EBCDIC, so initialize to false */
2958                 const bool convert_unicode = FALSE;
2959                 const IV real_range_max = 0;
2960 #else
2961                 bool convert_unicode;
2962                 IV real_range_max = 0;
2963 #endif
2964
2965                 /* Get the range-ends code point values. */
2966                 if (has_utf8) {
2967                     /* We know the utf8 is valid, because we just constructed
2968                      * it ourselves in previous loop iterations */
2969                     min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1);
2970                     range_min = valid_utf8_to_uvchr( (U8*) min_ptr, NULL);
2971                     range_max = valid_utf8_to_uvchr( (U8*) max_ptr, NULL);
2972                 }
2973                 else {
2974                     min_ptr = max_ptr - 1;
2975                     range_min = * (U8*) min_ptr;
2976                     range_max = * (U8*) max_ptr;
2977                 }
2978
2979 #ifdef EBCDIC
2980                 /* On EBCDIC platforms, we may have to deal with portable
2981                  * ranges.  These happen if at least one range endpoint is a
2982                  * Unicode value (\N{...}), or if the range is a subset of
2983                  * [A-Z] or [a-z], and both ends are literal characters,
2984                  * like 'A', and not like \x{C1} */
2985                 if ((convert_unicode
2986                      = cBOOL(backslash_N)   /* \N{} forces Unicode, hence
2987                                                portable range */
2988                       || (   ! non_portable_endpoint
2989                           && ((  isLOWER_A(range_min) && isLOWER_A(range_max))
2990                              || (isUPPER_A(range_min) && isUPPER_A(range_max))))
2991                 )) {
2992
2993                     /* Special handling is needed for these portable ranges.
2994                      * They are defined to all be in Unicode terms, which
2995                      * include all Unicode code points between the end points.
2996                      * Convert to Unicode to get the Unicode range.  Later we
2997                      * will convert each code point in the range back to
2998                      * native.  */
2999                     range_min = NATIVE_TO_UNI(range_min);
3000                     range_max = NATIVE_TO_UNI(range_max);
3001                 }
3002 #endif
3003
3004                 if (range_min > range_max) {
3005                     if (convert_unicode) {
3006                         /* Need to convert back to native for meaningful
3007                          * messages for this platform */
3008                         range_min = UNI_TO_NATIVE(range_min);
3009                         range_max = UNI_TO_NATIVE(range_max);
3010                     }
3011
3012                     /* Use the characters themselves for the error message if
3013                      * ASCII printables; otherwise some visible representation
3014                      * of them */
3015                     if (isPRINT_A(range_min) && isPRINT_A(range_max)) {
3016                         Perl_croak(aTHX_
3017                          "Invalid range \"%c-%c\" in transliteration operator",
3018                          (char)range_min, (char)range_max);
3019                     }
3020                     else if (convert_unicode) {
3021                         /* diag_listed_as: Invalid range "%s" in transliteration operator */
3022                         Perl_croak(aTHX_
3023                                "Invalid range \"\\N{U+%04"UVXf"}-\\N{U+%04"UVXf"}\""
3024                                " in transliteration operator",
3025                                range_min, range_max);
3026                     }
3027                     else {
3028                         /* diag_listed_as: Invalid range "%s" in transliteration operator */
3029                         Perl_croak(aTHX_
3030                                "Invalid range \"\\x{%04"UVXf"}-\\x{%04"UVXf"}\""
3031                                " in transliteration operator",
3032                                range_min, range_max);
3033                     }
3034                 }
3035
3036                 if (has_utf8) {
3037
3038                     /* We try to avoid creating a swash.  If the upper end of
3039                      * this range is below 256, this range won't force a swash;
3040                      * otherwise it does force a swash, and as long as we have
3041                      * to have one, we might as well not expand things out.
3042                      * But if it's EBCDIC, we may have to look at each
3043                      * character below 256 if we have to convert to/from
3044                      * Unicode values */
3045                     if (range_max > 255
3046 #ifdef EBCDIC
3047                         && (range_min > 255 || ! convert_unicode)
3048 #endif
3049                     ) {
3050                         /* Move the high character one byte to the right; then
3051                          * insert between it and the range begin, an illegal
3052                          * byte which serves to indicate this is a range (using
3053                          * a '-' could be ambiguous). */
3054                         char *e = d++;
3055                         while (e-- > max_ptr) {
3056                             *(e + 1) = *e;
3057                         }
3058                         *(e + 1) = (char) ILLEGAL_UTF8_BYTE;
3059                         goto range_done;
3060                     }
3061
3062                     /* Here, we're going to expand out the range.  For EBCDIC
3063                      * the range can extend above 255 (not so in ASCII), so
3064                      * for EBCDIC, split it into the parts above and below
3065                      * 255/256 */
3066 #ifdef EBCDIC
3067                     if (range_max > 255) {
3068                         real_range_max = range_max;
3069                         range_max = 255;
3070                     }
3071 #endif
3072                 }
3073
3074                 /* Here we need to expand out the string to contain each
3075                  * character in the range.  Grow the output to handle this */
3076
3077                 save_offset  = min_ptr - SvPVX_const(sv);
3078
3079                 /* The base growth is the number of code points in the range */
3080                 grow = range_max - range_min + 1;
3081                 if (has_utf8) {
3082
3083                     /* But if the output is UTF-8, some of those characters may
3084                      * need two bytes (since the maximum range value here is
3085                      * 255, the max bytes per character is two).  On ASCII
3086                      * platforms, it's not much trouble to get an accurate
3087                      * count of what's needed.  But on EBCDIC, the ones that
3088                      * need 2 bytes are scattered around, so just use a worst
3089                      * case value instead of calculating for that platform.  */
3090 #ifdef EBCDIC
3091                     grow *= 2;
3092 #else
3093                     /* Only those above 127 require 2 bytes.  This may be
3094                      * everything in the range, or not */
3095                     if (range_min > 127) {
3096                         grow *= 2;
3097                     }
3098                     else if (range_max > 127) {
3099                         grow += range_max - 127;
3100                     }
3101 #endif
3102                 }
3103
3104                 /* Subtract 3 for the bytes that were already accounted for
3105                  * (min, max, and the hyphen) */
3106                 d = save_offset + SvGROW(sv, SvLEN(sv) + grow - 3);
3107
3108                 /* Here, we expand out the range.  On ASCII platforms, the
3109                  * compiler should optimize out the 'convert_unicode==TRUE'
3110                  * portion of this */
3111                 if (convert_unicode) {
3112                     IV i;
3113
3114                     /* Recall that the min and max are now in Unicode terms, so
3115                      * we have to convert each character to its native
3116                      * equivalent */
3117                     if (has_utf8) {
3118                         for (i = range_min; i <= range_max; i++) {
3119                             append_utf8_from_native_byte(LATIN1_TO_NATIVE((U8) i),
3120                                                          (U8 **) &d);
3121                         }
3122                     }
3123                     else {
3124                         for (i = range_min; i <= range_max; i++) {
3125                             *d++ = (char)LATIN1_TO_NATIVE((U8) i);
3126                         }
3127                     }
3128                 }
3129                 else {
3130                     IV i;
3131
3132                     /* Here, no conversions are necessary, which means that the
3133                      * first character in the range is already in 'd' and
3134                      * valid, so we can skip overwriting it */
3135                     if (has_utf8) {
3136                         d += UTF8SKIP(d);
3137                         for (i = range_min + 1; i <= range_max; i++) {
3138                             append_utf8_from_native_byte((U8) i, (U8 **) &d);
3139                         }
3140                     }
3141                     else {
3142                         d++;
3143                         for (i = range_min + 1; i <= range_max; i++) {
3144                             *d++ = (char)i;
3145                         }
3146                     }
3147                 }
3148
3149                 /* (Compilers should optimize this out for non-EBCDIC).  If the
3150                  * original range extended above 255, add in that portion */
3151                 if (real_range_max) {
3152                     *d++ = (char) UTF8_TWO_BYTE_HI(0x100);
3153                     *d++ = (char) UTF8_TWO_BYTE_LO(0x100);
3154                     if (real_range_max > 0x101)
3155                         *d++ = (char) ILLEGAL_UTF8_BYTE;
3156                     if (real_range_max > 0x100)
3157                         d = (char*)uvchr_to_utf8((U8*)d, real_range_max);
3158                 }
3159
3160               range_done:
3161                 /* mark the range as done, and continue */
3162                 didrange = TRUE;
3163                 dorange = FALSE;
3164 #ifdef EBCDIC
3165                 non_portable_endpoint = 0;
3166                 backslash_N = 0;
3167 #endif
3168                 continue;
3169             } /* End of is a range */
3170         } /* End of transliteration.  Joins main code after these else's */
3171         else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3172             char *s1 = s-1;
3173             int esc = 0;
3174             while (s1 >= start && *s1-- == '\\')
3175                 esc = !esc;
3176             if (!esc)
3177                 in_charclass = TRUE;
3178         }
3179
3180         else if (*s == ']' && PL_lex_inpat &&  in_charclass) {
3181             char *s1 = s-1;
3182             int esc = 0;
3183             while (s1 >= start && *s1-- == '\\')
3184                 esc = !esc;
3185             if (!esc)
3186                 in_charclass = FALSE;
3187         }
3188
3189         /* skip for regexp comments /(?#comment)/, except for the last
3190          * char, which will be done separately.
3191          * Stop on (?{..}) and friends */
3192
3193         else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3194             if (s[2] == '#') {
3195                 while (s+1 < send && *s != ')')
3196                     *d++ = *s++;
3197             }
3198             else if (!PL_lex_casemods
3199                      && (    s[2] == '{' /* This should match regcomp.c */
3200                          || (s[2] == '?' && s[3] == '{')))
3201             {
3202                 break;
3203             }
3204         }
3205
3206         /* likewise skip #-initiated comments in //x patterns */
3207         else if (*s == '#'
3208                  && PL_lex_inpat
3209                  && !in_charclass
3210                  && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED)
3211         {
3212             while (s+1 < send && *s != '\n')
3213                 *d++ = *s++;
3214         }
3215
3216         /* no further processing of single-quoted regex */
3217         else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3218             goto default_action;
3219
3220         /* check for embedded arrays
3221            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3222            */
3223         else if (*s == '@' && s[1]) {
3224             if (UTF ? isIDFIRST_utf8((U8*)s+1) : isWORDCHAR_A(s[1]))
3225                 break;
3226             if (strchr(":'{$", s[1]))
3227                 break;
3228             if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3229                 break; /* in regexp, neither @+ nor @- are interpolated */
3230         }
3231
3232         /* check for embedded scalars.  only stop if we're sure it's a
3233            variable.
3234         */
3235         else if (*s == '$') {
3236             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
3237                 break;
3238             if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3239                 if (s[1] == '\\') {
3240                     Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3241                                    "Possible unintended interpolation of $\\ in regex");
3242                 }
3243                 break;          /* in regexp, $ might be tail anchor */
3244             }
3245         }
3246
3247         /* End of else if chain - OP_TRANS rejoin rest */
3248
3249         /* backslashes */
3250         if (*s == '\\' && s+1 < send) {
3251             char* e;    /* Can be used for ending '}', etc. */
3252
3253             s++;
3254
3255             /* warn on \1 - \9 in substitution replacements, but note that \11
3256              * is an octal; and \19 is \1 followed by '9' */
3257             if (PL_lex_inwhat == OP_SUBST
3258                 && !PL_lex_inpat
3259                 && isDIGIT(*s)
3260                 && *s != '0'
3261                 && !isDIGIT(s[1]))
3262             {
3263                 /* diag_listed_as: \%d better written as $%d */
3264                 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3265                 *--s = '$';
3266                 break;
3267             }
3268
3269             /* string-change backslash escapes */
3270             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3271                 --s;
3272                 break;
3273             }
3274             /* In a pattern, process \N, but skip any other backslash escapes.
3275              * This is because we don't want to translate an escape sequence
3276              * into a meta symbol and have the regex compiler use the meta
3277              * symbol meaning, e.g. \x{2E} would be confused with a dot.  But
3278              * in spite of this, we do have to process \N here while the proper
3279              * charnames handler is in scope.  See bugs #56444 and #62056.
3280              *
3281              * There is a complication because \N in a pattern may also stand
3282              * for 'match a non-nl', and not mean a charname, in which case its
3283              * processing should be deferred to the regex compiler.  To be a
3284              * charname it must be followed immediately by a '{', and not look
3285              * like \N followed by a curly quantifier, i.e., not something like
3286              * \N{3,}.  regcurly returns a boolean indicating if it is a legal
3287              * quantifier */
3288             else if (PL_lex_inpat
3289                     && (*s != 'N'
3290                         || s[1] != '{'
3291                         || regcurly(s + 1)))
3292             {
3293                 *d++ = '\\';
3294                 goto default_action;
3295             }
3296
3297             switch (*s) {
3298             default:
3299                 {
3300                     if ((isALPHANUMERIC(*s)))
3301                         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3302                                        "Unrecognized escape \\%c passed through",
3303                                        *s);
3304                     /* default action is to copy the quoted character */
3305                     goto default_action;
3306                 }
3307
3308             /* eg. \132 indicates the octal constant 0132 */
3309             case '0': case '1': case '2': case '3':
3310             case '4': case '5': case '6': case '7':
3311                 {
3312                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3313                     STRLEN len = 3;
3314                     uv = grok_oct(s, &len, &flags, NULL);
3315                     s += len;
3316                     if (len < 3 && s < send && isDIGIT(*s)
3317                         && ckWARN(WARN_MISC))
3318                     {
3319                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3320                                     "%s", form_short_octal_warning(s, len));
3321                     }
3322                 }
3323                 goto NUM_ESCAPE_INSERT;
3324
3325             /* eg. \o{24} indicates the octal constant \024 */
3326             case 'o':
3327                 {
3328                     const char* error;
3329
3330                     bool valid = grok_bslash_o(&s, &uv, &error,
3331                                                TRUE, /* Output warning */
3332                                                FALSE, /* Not strict */
3333                                                TRUE, /* Output warnings for
3334                                                          non-portables */
3335                                                UTF);
3336                     if (! valid) {
3337                         yyerror(error);
3338                         continue;
3339                     }
3340                     goto NUM_ESCAPE_INSERT;
3341                 }
3342
3343             /* eg. \x24 indicates the hex constant 0x24 */
3344             case 'x':
3345                 {
3346                     const char* error;
3347
3348                     bool valid = grok_bslash_x(&s, &uv, &error,
3349                                                TRUE, /* Output warning */
3350                                                FALSE, /* Not strict */
3351                                                TRUE,  /* Output warnings for
3352                                                          non-portables */
3353                                                UTF);
3354                     if (! valid) {
3355                         yyerror(error);
3356                         continue;
3357                     }
3358                 }
3359
3360               NUM_ESCAPE_INSERT:
3361                 /* Insert oct or hex escaped character. */
3362                 
3363                 /* Here uv is the ordinal of the next character being added */
3364                 if (UVCHR_IS_INVARIANT(uv)) {
3365                     *d++ = (char) uv;
3366                 }
3367                 else {
3368                     if (!has_utf8 && uv > 255) {
3369                         /* Might need to recode whatever we have accumulated so
3370                          * far if it contains any chars variant in utf8 or
3371                          * utf-ebcdic. */
3372                           
3373                         SvCUR_set(sv, d - SvPVX_const(sv));
3374                         SvPOK_on(sv);
3375                         *d = '\0';
3376                         /* See Note on sizing above.  */
3377                         sv_utf8_upgrade_flags_grow(
3378                                        sv,
3379                                        SV_GMAGIC|SV_FORCE_UTF8_UPGRADE
3380                                                   /* Above-latin1 in string
3381                                                    * implies no encoding */
3382                                                   |SV_UTF8_NO_ENCODING,
3383                                        UVCHR_SKIP(uv) + (STRLEN)(send - s) + 1);
3384                         d = SvPVX(sv) + SvCUR(sv);
3385                         has_utf8 = TRUE;
3386                     }
3387
3388                     if (has_utf8) {
3389                        /* Usually, there will already be enough room in 'sv'
3390                         * since such escapes are likely longer than any UTF-8
3391                         * sequence they can end up as.  This isn't the case on
3392                         * EBCDIC where \x{40000000} contains 12 bytes, and the
3393                         * UTF-8 for it contains 14.  And, we have to allow for
3394                         * a trailing NUL.  It probably can't happen on ASCII
3395                         * platforms, but be safe */
3396                         const STRLEN needed = d - SvPVX(sv) + UVCHR_SKIP(uv)
3397                                             + 1;
3398                         if (UNLIKELY(needed > SvLEN(sv))) {
3399                             SvCUR_set(sv, d - SvPVX_const(sv));
3400                             d = sv_grow(sv, needed) + SvCUR(sv);
3401                         }
3402
3403                         d = (char*)uvchr_to_utf8((U8*)d, uv);
3404                         if (PL_lex_inwhat == OP_TRANS
3405                             && PL_parser->lex_sub_op)
3406                         {
3407                             PL_parser->lex_sub_op->op_private |=
3408                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
3409                                              : OPpTRANS_TO_UTF);
3410                         }
3411                     }
3412                     else {
3413                         *d++ = (char)uv;
3414                     }
3415                 }
3416 #ifdef EBCDIC
3417                 non_portable_endpoint++;
3418 #endif
3419                 continue;
3420
3421             case 'N':
3422                 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3423                  * named character, like \N{LATIN SMALL LETTER A}, or a named
3424                  * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3425                  * GRAVE} (except y/// can't handle the latter, croaking).  For
3426                  * convenience all three forms are referred to as "named
3427                  * characters" below.
3428                  *
3429                  * For patterns, \N also can mean to match a non-newline.  Code
3430                  * before this 'switch' statement should already have handled
3431                  * this situation, and hence this code only has to deal with
3432                  * the named character cases.
3433                  *
3434                  * For non-patterns, the named characters are converted to
3435                  * their string equivalents.  In patterns, named characters are
3436                  * not converted to their ultimate forms for the same reasons
3437                  * that other escapes aren't.  Instead, they are converted to
3438                  * the \N{U+...} form to get the value from the charnames that
3439                  * is in effect right now, while preserving the fact that it
3440                  * was a named character, so that the regex compiler knows
3441                  * this.
3442                  *
3443                  * The structure of this section of code (besides checking for
3444                  * errors and upgrading to utf8) is:
3445                  *    If the named character is of the form \N{U+...}, pass it
3446                  *      through if a pattern; otherwise convert the code point
3447                  *      to utf8
3448                  *    Otherwise must be some \N{NAME}: convert to
3449                  *      \N{U+c1.c2...} if a pattern; otherwise convert to utf8
3450                  *
3451                  * Transliteration is an exception.  The conversion to utf8 is
3452                  * only done if the code point requires it to be representable.
3453                  *
3454                  * Here, 's' points to the 'N'; the test below is guaranteed to
3455                  * succeed if we are being called on a pattern, as we already
3456                  * know from a test above that the next character is a '{'.  A
3457                  * non-pattern \N must mean 'named character', which requires
3458                  * braces */
3459                 s++;
3460                 if (*s != '{') {
3461                     yyerror("Missing braces on \\N{}"); 
3462                     continue;
3463                 }
3464                 s++;
3465
3466                 /* If there is no matching '}', it is an error. */
3467                 if (! (e = strchr(s, '}'))) {
3468                     if (! PL_lex_inpat) {
3469                         yyerror("Missing right brace on \\N{}");
3470                     } else {
3471                         yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3472                     }
3473                     continue;
3474                 }
3475
3476                 /* Here it looks like a named character */
3477
3478                 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3479                     s += 2;         /* Skip to next char after the 'U+' */
3480                     if (PL_lex_inpat) {
3481
3482                         /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3483                         /* Check the syntax.  */
3484                         const char *orig_s;
3485                         orig_s = s - 5;
3486                         if (!isXDIGIT(*s)) {
3487                           bad_NU:
3488                             yyerror(
3489                                 "Invalid hexadecimal number in \\N{U+...}"
3490                             );
3491                             s = e + 1;
3492                             continue;
3493                         }
3494                         while (++s < e) {
3495                             if (isXDIGIT(*s))
3496                                 continue;
3497                             else if ((*s == '.' || *s == '_')
3498                                   && isXDIGIT(s[1]))
3499                                 continue;
3500                             goto bad_NU;
3501                         }
3502
3503                         /* Pass everything through unchanged.
3504                          * +1 is for the '}' */
3505                         Copy(orig_s, d, e - orig_s + 1, char);
3506                         d += e - orig_s + 1;
3507                     }
3508                     else {  /* Not a pattern: convert the hex to string */
3509                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3510                                 | PERL_SCAN_SILENT_ILLDIGIT
3511                                 | PERL_SCAN_DISALLOW_PREFIX;
3512                         STRLEN len = e - s;
3513                         uv = grok_hex(s, &len, &flags, NULL);
3514                         if (len == 0 || (len != (STRLEN)(e - s)))
3515                             goto bad_NU;
3516
3517                          /* For non-tr///, if the destination is not in utf8,
3518                           * unconditionally recode it to be so.  This is
3519                           * because \N{} implies Unicode semantics, and scalars
3520                           * have to be in utf8 to guarantee those semantics.
3521                           * tr/// doesn't care about Unicode rules, so no need
3522                           * there to upgrade to UTF-8 for small enough code
3523                           * points */
3524                         if (! has_utf8 && (   uv > 0xFF
3525                                            || PL_lex_inwhat != OP_TRANS))
3526                         {
3527                             SvCUR_set(sv, d - SvPVX_const(sv));
3528                             SvPOK_on(sv);
3529                             *d = '\0';
3530                             /* See Note on sizing above.  */
3531                             sv_utf8_upgrade_flags_grow(
3532                                     sv,
3533                                     SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3534                                     UVCHR_SKIP(uv) + (STRLEN)(send - e) + 1);
3535                             d = SvPVX(sv) + SvCUR(sv);
3536                             has_utf8 = TRUE;
3537                         }
3538
3539                         /* Add the (Unicode) code point to the output. */
3540                         if (! has_utf8 || OFFUNI_IS_INVARIANT(uv)) {
3541                             *d++ = (char) LATIN1_TO_NATIVE(uv);
3542                         }
3543                         else {
3544                             d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3545                         }
3546                     }
3547                 }
3548                 else /* Here is \N{NAME} but not \N{U+...}. */
3549                      if ((res = get_and_check_backslash_N_name(s, e)))
3550                 {
3551                     STRLEN len;
3552                     const char *str = SvPV_const(res, len);
3553                     if (PL_lex_inpat) {
3554
3555                         if (! len) { /* The name resolved to an empty string */
3556                             Copy("\\N{}", d, 4, char);
3557                             d += 4;
3558                         }
3559                         else {
3560                             /* In order to not lose information for the regex
3561                             * compiler, pass the result in the specially made
3562                             * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3563                             * the code points in hex of each character
3564                             * returned by charnames */
3565
3566                             const char *str_end = str + len;
3567                             const STRLEN off = d - SvPVX_const(sv);
3568
3569                             if (! SvUTF8(res)) {
3570                                 /* For the non-UTF-8 case, we can determine the
3571                                  * exact length needed without having to parse
3572                                  * through the string.  Each character takes up
3573                                  * 2 hex digits plus either a trailing dot or
3574                                  * the "}" */
3575                                 const char initial_text[] = "\\N{U+";
3576                                 const STRLEN initial_len = sizeof(initial_text)
3577                                                            - 1;
3578                                 d = off + SvGROW(sv, off
3579                                                     + 3 * len
3580
3581                                                     /* +1 for trailing NUL */
3582                                                     + initial_len + 1
3583
3584                                                     + (STRLEN)(send - e));
3585                                 Copy(initial_text, d, initial_len, char);
3586                                 d += initial_len;
3587                                 while (str < str_end) {
3588                                     char hex_string[4];
3589                                     int len =
3590                                         my_snprintf(hex_string,
3591                                                   sizeof(hex_string),
3592                                                   "%02X.",
3593
3594                                                   /* The regex compiler is
3595                                                    * expecting Unicode, not
3596                                                    * native */
3597                                                   NATIVE_TO_LATIN1(*str));
3598                                     PERL_MY_SNPRINTF_POST_GUARD(len,
3599                                                            sizeof(hex_string));
3600                                     Copy(hex_string, d, 3, char);
3601                                     d += 3;
3602                                     str++;
3603                                 }
3604                                 d--;    /* Below, we will overwrite the final
3605                                            dot with a right brace */
3606                             }
3607                             else {
3608                                 STRLEN char_length; /* cur char's byte length */
3609
3610                                 /* and the number of bytes after this is
3611                                  * translated into hex digits */
3612                                 STRLEN output_length;
3613
3614                                 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3615                                  * for max('U+', '.'); and 1 for NUL */
3616                                 char hex_string[2 * UTF8_MAXBYTES + 5];
3617
3618                                 /* Get the first character of the result. */
3619                                 U32 uv = utf8n_to_uvchr((U8 *) str,
3620                                                         len,
3621                                                         &char_length,
3622                                                         UTF8_ALLOW_ANYUV);
3623                                 /* Convert first code point to Unicode hex,
3624                                  * including the boiler plate before it. */
3625                                 output_length =
3626                                     my_snprintf(hex_string, sizeof(hex_string),
3627                                              "\\N{U+%X",
3628                                              (unsigned int) NATIVE_TO_UNI(uv));
3629
3630                                 /* Make sure there is enough space to hold it */
3631                                 d = off + SvGROW(sv, off
3632                                                     + output_length
3633                                                     + (STRLEN)(send - e)
3634                                                     + 2);       /* '}' + NUL */
3635                                 /* And output it */
3636                                 Copy(hex_string, d, output_length, char);
3637                                 d += output_length;
3638
3639                                 /* For each subsequent character, append dot and
3640                                 * its Unicode code point in hex */
3641                                 while ((str += char_length) < str_end) {
3642                                     const STRLEN off = d - SvPVX_const(sv);
3643                                     U32 uv = utf8n_to_uvchr((U8 *) str,
3644                                                             str_end - str,
3645                                                             &char_length,
3646                                                             UTF8_ALLOW_ANYUV);
3647                                     output_length =
3648                                         my_snprintf(hex_string,
3649                                              sizeof(hex_string),
3650                                              ".%X",
3651                                              (unsigned int) NATIVE_TO_UNI(uv));
3652
3653                                     d = off + SvGROW(sv, off
3654                                                         + output_length
3655                                                         + (STRLEN)(send - e)
3656                                                         + 2);   /* '}' +  NUL */
3657                                     Copy(hex_string, d, output_length, char);
3658                                     d += output_length;
3659                                 }
3660                             }
3661
3662                             *d++ = '}'; /* Done.  Add the trailing brace */
3663                         }
3664                     }
3665                     else { /* Here, not in a pattern.  Convert the name to a
3666                             * string. */
3667
3668                         if (PL_lex_inwhat == OP_TRANS) {
3669                             str = SvPV_const(res, len);
3670                             if (len > ((SvUTF8(res))
3671                                        ? UTF8SKIP(str)
3672                                        : 1U))
3673                             {
3674                                 yyerror(Perl_form(aTHX_
3675                                     "%.*s must not be a named sequence"
3676                                     " in transliteration operator",
3677                                         /*  +1 to include the "}" */
3678                                     (int) (e + 1 - start), start));
3679                                 goto end_backslash_N;
3680                             }
3681                         }
3682                         else if (! SvUTF8(res)) {
3683                             /* Make sure \N{} return is UTF-8.  This is because
3684                              * \N{} implies Unicode semantics, and scalars have
3685                              * to be in utf8 to guarantee those semantics; but
3686                              * not needed in tr/// */
3687                             sv_utf8_upgrade_flags(res, SV_UTF8_NO_ENCODING);
3688                             str = SvPV_const(res, len);
3689                         }
3690
3691                          /* Upgrade destination to be utf8 if this new
3692                           * component is */
3693                         if (! has_utf8 && SvUTF8(res)) {
3694                             SvCUR_set(sv, d - SvPVX_const(sv));
3695                             SvPOK_on(sv);
3696                             *d = '\0';
3697                             /* See Note on sizing above.  */
3698                             sv_utf8_upgrade_flags_grow(sv,
3699                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3700                                                 len + (STRLEN)(send - s) + 1);
3701                             d = SvPVX(sv) + SvCUR(sv);
3702                             has_utf8 = TRUE;
3703                         } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3704
3705                             /* See Note on sizing above.  (NOTE: SvCUR() is not
3706                              * set correctly here). */
3707                             const STRLEN off = d - SvPVX_const(sv);
3708                             d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3709                         }
3710                         Copy(str, d, len, char);
3711                         d += len;
3712                     }
3713
3714                     SvREFCNT_dec(res);
3715
3716                 } /* End \N{NAME} */
3717
3718               end_backslash_N:
3719 #ifdef EBCDIC
3720                 backslash_N++; /* \N{} is defined to be Unicode */
3721 #endif
3722                 s = e + 1;  /* Point to just after the '}' */
3723                 continue;
3724
3725             /* \c is a control character */
3726             case 'c':
3727                 s++;
3728                 if (s < send) {
3729                     *d++ = grok_bslash_c(*s++, 1);
3730                 }
3731                 else {
3732                     yyerror("Missing control char name in \\c");
3733                 }
3734 #ifdef EBCDIC
3735                 non_portable_endpoint++;
3736 #endif
3737                 continue;
3738
3739             /* printf-style backslashes, formfeeds, newlines, etc */
3740             case 'b':
3741                 *d++ = '\b';
3742                 break;
3743             case 'n':
3744                 *d++ = '\n';
3745                 break;
3746             case 'r':
3747                 *d++ = '\r';
3748                 break;
3749             case 'f':
3750                 *d++ = '\f';
3751                 break;
3752             case 't':
3753                 *d++ = '\t';
3754                 break;
3755             case 'e':
3756                 *d++ = ESC_NATIVE;
3757                 break;
3758             case 'a':
3759                 *d++ = '\a';
3760                 break;
3761             } /* end switch */
3762
3763             s++;
3764             continue;
3765         } /* end if (backslash) */
3766
3767     default_action:
3768         /* If we started with encoded form, or already know we want it,
3769            then encode the next character */
3770         if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3771             STRLEN len  = 1;
3772
3773             /* One might think that it is wasted effort in the case of the
3774              * source being utf8 (this_utf8 == TRUE) to take the next character
3775              * in the source, convert it to an unsigned value, and then convert
3776              * it back again.  But the source has not been validated here.  The
3777              * routine that does the conversion checks for errors like
3778              * malformed utf8 */
3779
3780             const UV nextuv   = (this_utf8)
3781                                 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3782                                 : (UV) ((U8) *s);
3783             const STRLEN need = UVCHR_SKIP(nextuv);
3784             if (!has_utf8) {
3785                 SvCUR_set(sv, d - SvPVX_const(sv));
3786                 SvPOK_on(sv);
3787                 *d = '\0';
3788                 /* See Note on sizing above.  */
3789                 sv_utf8_upgrade_flags_grow(sv,
3790                                         SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3791                                         need + (STRLEN)(send - s) + 1);
3792                 d = SvPVX(sv) + SvCUR(sv);
3793                 has_utf8 = TRUE;
3794             } else if (need > len) {
3795                 /* encoded value larger than old, may need extra space (NOTE:
3796                  * SvCUR() is not set correctly here).   See Note on sizing
3797                  * above.  */
3798                 const STRLEN off = d - SvPVX_const(sv);
3799                 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3800             }
3801             s += len;
3802
3803             d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3804         }
3805         else {
3806             *d++ = *s++;
3807         }
3808     } /* while loop to process each character */
3809
3810     /* terminate the string and set up the sv */
3811     *d = '\0';
3812     SvCUR_set(sv, d - SvPVX_const(sv));
3813     if (SvCUR(sv) >= SvLEN(sv))
3814         Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3815                    " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3816
3817     SvPOK_on(sv);
3818     if (has_utf8) {
3819         SvUTF8_on(sv);
3820         if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
3821             PL_parser->lex_sub_op->op_private |=
3822                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3823         }
3824     }
3825
3826     /* shrink the sv if we allocated more than we used */
3827     if (SvCUR(sv) + 5 < SvLEN(sv)) {
3828         SvPV_shrink_to_cur(sv);
3829     }
3830
3831     /* return the substring (via pl_yylval) only if we parsed anything */
3832     if (s > start) {
3833         char *s2 = start;
3834         for (; s2 < s; s2++) {
3835             if (*s2 == '\n')
3836                 COPLINE_INC_WITH_HERELINES;
3837         }
3838         SvREFCNT_inc_simple_void_NN(sv);
3839         if (   (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3840             && ! PL_parser->lex_re_reparsing)
3841         {
3842             const char *const key = PL_lex_inpat ? "qr" : "q";
3843             const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3844             const char *type;
3845             STRLEN typelen;
3846
3847             if (PL_lex_inwhat == OP_TRANS) {
3848                 type = "tr";
3849                 typelen = 2;
3850             } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3851                 type = "s";
3852                 typelen = 1;
3853             } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3854                 type = "q";
3855                 typelen = 1;
3856             } else  {
3857                 type = "qq";
3858                 typelen = 2;
3859             }
3860
3861             sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3862                                 type, typelen);
3863         }
3864         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3865     }
3866     LEAVE_with_name("scan_const");
3867     return s;
3868 }
3869
3870 /* S_intuit_more
3871  * Returns TRUE if there's more to the expression (e.g., a subscript),
3872  * FALSE otherwise.
3873  *
3874  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3875  *
3876  * ->[ and ->{ return TRUE
3877  * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
3878  * { and [ outside a pattern are always subscripts, so return TRUE
3879  * if we're outside a pattern and it's not { or [, then return FALSE
3880  * if we're in a pattern and the first char is a {
3881  *   {4,5} (any digits around the comma) returns FALSE
3882  * if we're in a pattern and the first char is a [
3883  *   [] returns FALSE
3884  *   [SOMETHING] has a funky algorithm to decide whether it's a
3885  *      character class or not.  It has to deal with things like
3886  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3887  * anything else returns TRUE
3888  */
3889
3890 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3891
3892 STATIC int
3893 S_intuit_more(pTHX_ char *s)
3894 {
3895     PERL_ARGS_ASSERT_INTUIT_MORE;
3896
3897     if (PL_lex_brackets)
3898         return TRUE;
3899     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3900         return TRUE;
3901     if (*s == '-' && s[1] == '>'
3902      && FEATURE_POSTDEREF_QQ_IS_ENABLED
3903      && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
3904         ||(s[2] == '@' && strchr("*[{",s[3])) ))
3905         return TRUE;
3906     if (*s != '{' && *s != '[')
3907         return FALSE;
3908     if (!PL_lex_inpat)
3909         return TRUE;
3910
3911     /* In a pattern, so maybe we have {n,m}. */
3912     if (*s == '{') {
3913         if (regcurly(s)) {
3914             return FALSE;
3915         }
3916         return TRUE;
3917     }
3918
3919     /* On the other hand, maybe we have a character class */
3920
3921     s++;
3922     if (*s == ']' || *s == '^')
3923         return FALSE;
3924     else {
3925         /* this is terrifying, and it works */
3926         int weight;
3927         char seen[256];
3928         const char * const send = strchr(s,']');
3929         unsigned char un_char, last_un_char;
3930         char tmpbuf[sizeof PL_tokenbuf * 4];
3931
3932         if (!send)              /* has to be an expression */
3933             return TRUE;
3934         weight = 2;             /* let's weigh the evidence */
3935
3936         if (*s == '$')
3937             weight -= 3;
3938         else if (isDIGIT(*s)) {
3939             if (s[1] != ']') {
3940                 if (isDIGIT(s[1]) && s[2] == ']')
3941                     weight -= 10;
3942             }
3943             else
3944                 weight -= 100;
3945         }
3946         Zero(seen,256,char);
3947         un_char = 255;
3948         for (; s < send; s++) {
3949             last_un_char = un_char;
3950             un_char = (unsigned char)*s;
3951             switch (*s) {
3952             case '@':
3953             case '&':
3954             case '$':
3955                 weight -= seen[un_char] * 10;
3956                 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3957                     int len;
3958                     char *tmp = PL_bufend;
3959                     PL_bufend = (char*)send;
3960                     scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
3961                     PL_bufend = tmp;
3962                     len = (int)strlen(tmpbuf);
3963                     if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3964                                                     UTF ? SVf_UTF8 : 0, SVt_PV))
3965                         weight -= 100;
3966                     else
3967                         weight -= 10;
3968                 }
3969                 else if (*s == '$'
3970                          && s[1]
3971                          && strchr("[#!%*<>()-=",s[1]))
3972                 {
3973                     if (/*{*/ strchr("])} =",s[2]))
3974                         weight -= 10;
3975                     else
3976                         weight -= 1;
3977                 }
3978                 break;
3979             case '\\':
3980                 un_char = 254;
3981                 if (s[1]) {
3982                     if (strchr("wds]",s[1]))
3983                         weight += 100;
3984                     else if (seen[(U8)'\''] || seen[(U8)'"'])
3985                         weight += 1;
3986                     else if (strchr("rnftbxcav",s[1]))
3987                         weight += 40;
3988                     else if (isDIGIT(s[1])) {
3989                         weight += 40;
3990                         while (s[1] && isDIGIT(s[1]))
3991                             s++;
3992                     }
3993                 }
3994                 else
3995                     weight += 100;
3996                 break;
3997             case '-':
3998                 if (s[1] == '\\')
3999                     weight += 50;
4000                 if (strchr("aA01! ",last_un_char))
4001                     weight += 30;
4002                 if (strchr("zZ79~",s[1]))
4003                     weight += 30;
4004                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
4005                     weight -= 5;        /* cope with negative subscript */
4006                 break;
4007             default:
4008                 if (!isWORDCHAR(last_un_char)
4009                     && !(last_un_char == '$' || last_un_char == '@'
4010                          || last_un_char == '&')
4011                     && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4012                     char *d = s;
4013                     while (isALPHA(*s))
4014                         s++;
4015                     if (keyword(d, s - d, 0))
4016                         weight -= 150;
4017                 }
4018                 if (un_char == last_un_char + 1)
4019                     weight += 5;
4020                 weight -= seen[un_char];
4021                 break;
4022             }
4023             seen[un_char]++;
4024         }
4025         if (weight >= 0)        /* probably a character class */
4026             return FALSE;
4027     }
4028
4029     return TRUE;
4030 }
4031
4032 /*
4033  * S_intuit_method
4034  *
4035  * Does all the checking to disambiguate
4036  *   foo bar
4037  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
4038  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4039  *
4040  * First argument is the stuff after the first token, e.g. "bar".
4041  *
4042  * Not a method if foo is a filehandle.
4043  * Not a method if foo is a subroutine prototyped to take a filehandle.
4044  * Not a method if it's really "Foo $bar"
4045  * Method if it's "foo $bar"
4046  * Not a method if it's really "print foo $bar"
4047  * Method if it's really "foo package::" (interpreted as package->foo)
4048  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4049  * Not a method if bar is a filehandle or package, but is quoted with
4050  *   =>
4051  */
4052
4053 STATIC int
4054 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
4055 {
4056     char *s = start + (*start == '$');
4057     char tmpbuf[sizeof PL_tokenbuf];
4058     STRLEN len;
4059     GV* indirgv;
4060         /* Mustn't actually add anything to a symbol table.
4061            But also don't want to "initialise" any placeholder
4062            constants that might already be there into full
4063            blown PVGVs with attached PVCV.  */
4064     GV * const gv =
4065         ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
4066
4067     PERL_ARGS_ASSERT_INTUIT_METHOD;
4068
4069     if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4070             return 0;
4071     if (cv && SvPOK(cv)) {
4072         const char *proto = CvPROTO(cv);
4073         if (proto) {
4074             while (*proto && (isSPACE(*proto) || *proto == ';'))
4075                 proto++;
4076             if (*proto == '*')
4077                 return 0;
4078         }
4079     }
4080
4081     if (*start == '$') {
4082         if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY
4083             || isUPPER(*PL_tokenbuf))
4084             return 0;
4085         s = skipspace(s);
4086         PL_bufptr = start;
4087         PL_expect = XREF;
4088         return *s == '(' ? FUNCMETH : METHOD;
4089     }
4090
4091     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4092     /* start is the beginning of the possible filehandle/object,
4093      * and s is the end of it
4094      * tmpbuf is a copy of it (but with single quotes as double colons)
4095      */
4096
4097     if (!keyword(tmpbuf, len, 0)) {
4098         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4099             len -= 2;
4100             tmpbuf[len] = '\0';
4101             goto bare_package;
4102         }
4103         indirgv = gv_fetchpvn_flags(tmpbuf, len,
4104                                     GV_NOADD_NOINIT|( UTF ? SVf_UTF8 : 0 ),
4105                                     SVt_PVCV);
4106         if (indirgv && SvTYPE(indirgv) != SVt_NULL
4107          && (!isGV(indirgv) || GvCVu(indirgv)))
4108             return 0;
4109         /* filehandle or package name makes it a method */
4110         if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4111             s = skipspace(s);
4112             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4113                 return 0;       /* no assumptions -- "=>" quotes bareword */
4114       bare_package:
4115             NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
4116                                                   S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4117             NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4118             PL_expect = XTERM;
4119             force_next(BAREWORD);
4120             PL_bufptr = s;
4121             return *s == '(' ? FUNCMETH : METHOD;
4122         }
4123     }
4124     return 0;
4125 }
4126
4127 /* Encoded script support. filter_add() effectively inserts a
4128  * 'pre-processing' function into the current source input stream.
4129  * Note that the filter function only applies to the current source file
4130  * (e.g., it will not affect files 'require'd or 'use'd by this one).
4131  *
4132  * The datasv parameter (which may be NULL) can be used to pass
4133  * private data to this instance of the filter. The filter function
4134  * can recover the SV using the FILTER_DATA macro and use it to
4135  * store private buffers and state information.
4136  *
4137  * The supplied datasv parameter is upgraded to a PVIO type
4138  * and the IoDIRP/IoANY field is used to store the function pointer,
4139  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4140  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4141  * private use must be set using malloc'd pointers.
4142  */
4143
4144 SV *
4145 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4146 {
4147     if (!funcp)
4148         return NULL;
4149
4150     if (!PL_parser)
4151         return NULL;
4152
4153     if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4154         Perl_croak(aTHX_ "Source filters apply only to byte streams");
4155
4156     if (!PL_rsfp_filters)
4157         PL_rsfp_filters = newAV();
4158     if (!datasv)
4159         datasv = newSV(0);
4160     SvUPGRADE(datasv, SVt_PVIO);
4161     IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4162     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4163     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4164                           FPTR2DPTR(void *, IoANY(datasv)),
4165                           SvPV_nolen(datasv)));
4166     av_unshift(PL_rsfp_filters, 1);
4167     av_store(PL_rsfp_filters, 0, datasv) ;
4168     if (
4169         !PL_parser->filtered
4170      && PL_parser->lex_flags & LEX_EVALBYTES
4171      && PL_bufptr < PL_bufend
4172     ) {
4173         const char *s = PL_bufptr;
4174         while (s < PL_bufend) {
4175             if (*s == '\n') {
4176                 SV *linestr = PL_parser->linestr;
4177                 char *buf = SvPVX(linestr);
4178                 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4179                 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4180                 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4181                 STRLEN const linestart_pos = PL_parser->linestart - buf;
4182                 STRLEN const last_uni_pos =
4183                     PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4184                 STRLEN const last_lop_pos =
4185                     PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4186                 av_push(PL_rsfp_filters, linestr);
4187                 PL_parser->linestr = 
4188                     newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4189                 buf = SvPVX(PL_parser->linestr);
4190                 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4191                 PL_parser->bufptr = buf + bufptr_pos;
4192                 PL_parser->oldbufptr = buf + oldbufptr_pos;
4193                 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4194                 PL_parser->linestart = buf + linestart_pos;
4195                 if (PL_parser->last_uni)
4196                     PL_parser->last_uni = buf + last_uni_pos;
4197                 if (PL_parser->last_lop)
4198                     PL_parser->last_lop = buf + last_lop_pos;
4199                 SvLEN(linestr) = SvCUR(linestr);
4200                 SvCUR(linestr) = s-SvPVX(linestr);
4201                 PL_parser->filtered = 1;
4202                 break;
4203             }
4204             s++;
4205         }
4206     }
4207     return(datasv);
4208 }
4209
4210
4211 /* Delete most recently added instance of this filter function. */
4212 void
4213 Perl_filter_del(pTHX_ filter_t funcp)
4214 {
4215     SV *datasv;
4216
4217     PERL_ARGS_ASSERT_FILTER_DEL;
4218
4219 #ifdef DEBUGGING
4220     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4221                           FPTR2DPTR(void*, funcp)));
4222 #endif
4223     if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4224         return;
4225     /* if filter is on top of stack (usual case) just pop it off */
4226     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4227     if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4228         sv_free(av_pop(PL_rsfp_filters));
4229
4230         return;
4231     }
4232     /* we need to search for the correct entry and clear it     */
4233     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4234 }
4235
4236
4237 /* Invoke the idxth filter function for the current rsfp.        */
4238 /* maxlen 0 = read one text line */
4239 I32
4240 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4241 {
4242     filter_t funcp;
4243     SV *datasv = NULL;
4244     /* This API is bad. It should have been using unsigned int for maxlen.
4245        Not sure if we want to change the API, but if not we should sanity
4246        check the value here.  */
4247     unsigned int correct_length = maxlen < 0 ?  PERL_INT_MAX : maxlen;
4248
4249     PERL_ARGS_ASSERT_FILTER_READ;
4250
4251     if (!PL_parser || !PL_rsfp_filters)
4252         return -1;
4253     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
4254         /* Provide a default input filter to make life easy.    */
4255         /* Note that we append to the line. This is handy.      */
4256         DEBUG_P(PerlIO_printf(Perl_debug_log,
4257                               "filter_read %d: from rsfp\n", idx));
4258         if (correct_length) {
4259             /* Want a block */
4260             int len ;
4261             const int old_len = SvCUR(buf_sv);
4262
4263             /* ensure buf_sv is large enough */
4264             SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4265             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4266                                    correct_length)) <= 0) {
4267                 if (PerlIO_error(PL_rsfp))
4268                     return -1;          /* error */
4269                 else
4270                     return 0 ;          /* end of file */
4271             }
4272             SvCUR_set(buf_sv, old_len + len) ;
4273             SvPVX(buf_sv)[old_len + len] = '\0';
4274         } else {
4275             /* Want a line */
4276             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4277                 if (PerlIO_error(PL_rsfp))
4278                     return -1;          /* error */
4279                 else
4280                     return 0 ;          /* end of file */
4281             }
4282         }
4283         return SvCUR(buf_sv);
4284     }
4285     /* Skip this filter slot if filter has been deleted */
4286     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4287         DEBUG_P(PerlIO_printf(Perl_debug_log,
4288                               "filter_read %d: skipped (filter deleted)\n",
4289                               idx));
4290         return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4291     }
4292     if (SvTYPE(datasv) != SVt_PVIO) {
4293         if (correct_length) {
4294             /* Want a block */
4295             const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4296             if (!remainder) return 0; /* eof */
4297             if (correct_length > remainder) correct_length = remainder;
4298             sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4299             SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4300         } else {
4301             /* Want a line */
4302             const char *s = SvEND(datasv);
4303             const char *send = SvPVX(datasv) + SvLEN(datasv);
4304             while (s < send) {
4305                 if (*s == '\n') {
4306                     s++;
4307                     break;
4308                 }
4309                 s++;
4310             }
4311             if (s == send) return 0; /* eof */
4312             sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));