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