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