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