cpan/: bump $VERSION as needed
[perl.git] / toke.c
1 /*    toke.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *  'It all comes from here, the stench and the peril.'    --Frodo
13  *
14  *     [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
15  */
16
17 /*
18  * This file is the lexer for Perl.  It's closely linked to the
19  * parser, perly.y.
20  *
21  * The main routine is yylex(), which returns the next token.
22  */
23
24 /*
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,BAREWORD,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     { BAREWORD,         TOKENTYPE_OPVAL,        "BAREWORD" },
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
1999  *                 (e.g., METHOD,BAREWORD)
2000  *   int check_keyword : if true, Perl checks to make sure the word isn't
2001  *       a keyword (do this if the word is a label, e.g. goto FOO)
2002  *   int allow_pack : if true, : characters will also be allowed (require,
2003  *       use, etc. do this)
2004  */
2005
2006 STATIC char *
2007 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2008 {
2009     char *s;
2010     STRLEN len;
2011
2012     PERL_ARGS_ASSERT_FORCE_WORD;
2013
2014     start = skipspace(start);
2015     s = start;
2016     if (isIDFIRST_lazy_if(s,UTF)
2017         || (allow_pack && *s == ':' && s[1] == ':') )
2018     {
2019         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2020         if (check_keyword) {
2021           char *s2 = PL_tokenbuf;
2022           STRLEN len2 = len;
2023           if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2024             s2 += 6, len2 -= 6;
2025           if (keyword(s2, len2, 0))
2026             return start;
2027         }
2028         if (token == METHOD) {
2029             s = skipspace(s);
2030             if (*s == '(')
2031                 PL_expect = XTERM;
2032             else {
2033                 PL_expect = XOPERATOR;
2034             }
2035         }
2036         NEXTVAL_NEXTTOKE.opval
2037             = (OP*)newSVOP(OP_CONST,0,
2038                            S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2039         NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2040         force_next(token);
2041     }
2042     return s;
2043 }
2044
2045 /*
2046  * S_force_ident
2047  * Called when the lexer wants $foo *foo &foo etc, but the program
2048  * text only contains the "foo" portion.  The first argument is a pointer
2049  * to the "foo", and the second argument is the type symbol to prefix.
2050  * Forces the next token to be a "BAREWORD".
2051  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2052  */
2053
2054 STATIC void
2055 S_force_ident(pTHX_ const char *s, int kind)
2056 {
2057     PERL_ARGS_ASSERT_FORCE_IDENT;
2058
2059     if (s[0]) {
2060         const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2061         OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2062                                                                 UTF ? SVf_UTF8 : 0));
2063         NEXTVAL_NEXTTOKE.opval = o;
2064         force_next(BAREWORD);
2065         if (kind) {
2066             o->op_private = OPpCONST_ENTERED;
2067             /* XXX see note in pp_entereval() for why we forgo typo
2068                warnings if the symbol must be introduced in an eval.
2069                GSAR 96-10-12 */
2070             gv_fetchpvn_flags(s, len,
2071                               (PL_in_eval ? GV_ADDMULTI
2072                               : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2073                               kind == '$' ? SVt_PV :
2074                               kind == '@' ? SVt_PVAV :
2075                               kind == '%' ? SVt_PVHV :
2076                               SVt_PVGV
2077                               );
2078         }
2079     }
2080 }
2081
2082 static void
2083 S_force_ident_maybe_lex(pTHX_ char pit)
2084 {
2085     NEXTVAL_NEXTTOKE.ival = pit;
2086     force_next('p');
2087 }
2088
2089 NV
2090 Perl_str_to_version(pTHX_ SV *sv)
2091 {
2092     NV retval = 0.0;
2093     NV nshift = 1.0;
2094     STRLEN len;
2095     const char *start = SvPV_const(sv,len);
2096     const char * const end = start + len;
2097     const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2098
2099     PERL_ARGS_ASSERT_STR_TO_VERSION;
2100
2101     while (start < end) {
2102         STRLEN skip;
2103         UV n;
2104         if (utf)
2105             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2106         else {
2107             n = *(U8*)start;
2108             skip = 1;
2109         }
2110         retval += ((NV)n)/nshift;
2111         start += skip;
2112         nshift *= 1000;
2113     }
2114     return retval;
2115 }
2116
2117 /*
2118  * S_force_version
2119  * Forces the next token to be a version number.
2120  * If the next token appears to be an invalid version number, (e.g. "v2b"),
2121  * and if "guessing" is TRUE, then no new token is created (and the caller
2122  * must use an alternative parsing method).
2123  */
2124
2125 STATIC char *
2126 S_force_version(pTHX_ char *s, int guessing)
2127 {
2128     OP *version = NULL;
2129     char *d;
2130
2131     PERL_ARGS_ASSERT_FORCE_VERSION;
2132
2133     s = skipspace(s);
2134
2135     d = s;
2136     if (*d == 'v')
2137         d++;
2138     if (isDIGIT(*d)) {
2139         while (isDIGIT(*d) || *d == '_' || *d == '.')
2140             d++;
2141         if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2142             SV *ver;
2143             s = scan_num(s, &pl_yylval);
2144             version = pl_yylval.opval;
2145             ver = cSVOPx(version)->op_sv;
2146             if (SvPOK(ver) && !SvNIOK(ver)) {
2147                 SvUPGRADE(ver, SVt_PVNV);
2148                 SvNV_set(ver, str_to_version(ver));
2149                 SvNOK_on(ver);          /* hint that it is a version */
2150             }
2151         }
2152         else if (guessing) {
2153             return s;
2154         }
2155     }
2156
2157     /* NOTE: The parser sees the package name and the VERSION swapped */
2158     NEXTVAL_NEXTTOKE.opval = version;
2159     force_next(BAREWORD);
2160
2161     return s;
2162 }
2163
2164 /*
2165  * S_force_strict_version
2166  * Forces the next token to be a version number using strict syntax rules.
2167  */
2168
2169 STATIC char *
2170 S_force_strict_version(pTHX_ char *s)
2171 {
2172     OP *version = NULL;
2173     const char *errstr = NULL;
2174
2175     PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2176
2177     while (isSPACE(*s)) /* leading whitespace */
2178         s++;
2179
2180     if (is_STRICT_VERSION(s,&errstr)) {
2181         SV *ver = newSV(0);
2182         s = (char *)scan_version(s, ver, 0);
2183         version = newSVOP(OP_CONST, 0, ver);
2184     }
2185     else if ((*s != ';' && *s != '{' && *s != '}' )
2186              && (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2187     {
2188         PL_bufptr = s;
2189         if (errstr)
2190             yyerror(errstr); /* version required */
2191         return s;
2192     }
2193
2194     /* NOTE: The parser sees the package name and the VERSION swapped */
2195     NEXTVAL_NEXTTOKE.opval = version;
2196     force_next(BAREWORD);
2197
2198     return s;
2199 }
2200
2201 /*
2202  * S_tokeq
2203  * Tokenize a quoted string passed in as an SV.  It finds the next
2204  * chunk, up to end of string or a backslash.  It may make a new
2205  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
2206  * turns \\ into \.
2207  */
2208
2209 STATIC SV *
2210 S_tokeq(pTHX_ SV *sv)
2211 {
2212     char *s;
2213     char *send;
2214     char *d;
2215     SV *pv = sv;
2216
2217     PERL_ARGS_ASSERT_TOKEQ;
2218
2219     assert (SvPOK(sv));
2220     assert (SvLEN(sv));
2221     assert (!SvIsCOW(sv));
2222     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2223         goto finish;
2224     s = SvPVX(sv);
2225     send = SvEND(sv);
2226     /* This is relying on the SV being "well formed" with a trailing '\0'  */
2227     while (s < send && !(*s == '\\' && s[1] == '\\'))
2228         s++;
2229     if (s == send)
2230         goto finish;
2231     d = s;
2232     if ( PL_hints & HINT_NEW_STRING ) {
2233         pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2234                             SVs_TEMP | SvUTF8(sv));
2235     }
2236     while (s < send) {
2237         if (*s == '\\') {
2238             if (s + 1 < send && (s[1] == '\\'))
2239                 s++;            /* all that, just for this */
2240         }
2241         *d++ = *s++;
2242     }
2243     *d = '\0';
2244     SvCUR_set(sv, d - SvPVX_const(sv));
2245   finish:
2246     if ( PL_hints & HINT_NEW_STRING )
2247        return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2248     return sv;
2249 }
2250
2251 /*
2252  * Now come three functions related to double-quote context,
2253  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
2254  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
2255  * interact with PL_lex_state, and create fake ( ... ) argument lists
2256  * to handle functions and concatenation.
2257  * For example,
2258  *   "foo\lbar"
2259  * is tokenised as
2260  *    stringify ( const[foo] concat lcfirst ( const[bar] ) )
2261  */
2262
2263 /*
2264  * S_sublex_start
2265  * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2266  *
2267  * Pattern matching will set PL_lex_op to the pattern-matching op to
2268  * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2269  *
2270  * OP_CONST and OP_READLINE are easy--just make the new op and return.
2271  *
2272  * Everything else becomes a FUNC.
2273  *
2274  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2275  * had an OP_CONST or OP_READLINE).  This just sets us up for a
2276  * call to S_sublex_push().
2277  */
2278
2279 STATIC I32
2280 S_sublex_start(pTHX)
2281 {
2282     const I32 op_type = pl_yylval.ival;
2283
2284     if (op_type == OP_NULL) {
2285         pl_yylval.opval = PL_lex_op;
2286         PL_lex_op = NULL;
2287         return THING;
2288     }
2289     if (op_type == OP_CONST) {
2290         SV *sv = PL_lex_stuff;
2291         PL_lex_stuff = NULL;
2292         sv = tokeq(sv);
2293
2294         if (SvTYPE(sv) == SVt_PVIV) {
2295             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2296             STRLEN len;
2297             const char * const p = SvPV_const(sv, len);
2298             SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2299             SvREFCNT_dec(sv);
2300             sv = nsv;
2301         }
2302         pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2303         return THING;
2304     }
2305
2306     PL_sublex_info.super_state = PL_lex_state;
2307     PL_sublex_info.sub_inwhat = (U16)op_type;
2308     PL_sublex_info.sub_op = PL_lex_op;
2309     PL_lex_state = LEX_INTERPPUSH;
2310
2311     PL_expect = XTERM;
2312     if (PL_lex_op) {
2313         pl_yylval.opval = PL_lex_op;
2314         PL_lex_op = NULL;
2315         return PMFUNC;
2316     }
2317     else
2318         return FUNC;
2319 }
2320
2321 /*
2322  * S_sublex_push
2323  * Create a new scope to save the lexing state.  The scope will be
2324  * ended in S_sublex_done.  Returns a '(', starting the function arguments
2325  * to the uc, lc, etc. found before.
2326  * Sets PL_lex_state to LEX_INTERPCONCAT.
2327  */
2328
2329 STATIC I32
2330 S_sublex_push(pTHX)
2331 {
2332     LEXSHARED *shared;
2333     const bool is_heredoc = PL_multi_close == '<';
2334     ENTER;
2335
2336     PL_lex_state = PL_sublex_info.super_state;
2337     SAVEI8(PL_lex_dojoin);
2338     SAVEI32(PL_lex_brackets);
2339     SAVEI32(PL_lex_allbrackets);
2340     SAVEI32(PL_lex_formbrack);
2341     SAVEI8(PL_lex_fakeeof);
2342     SAVEI32(PL_lex_casemods);
2343     SAVEI32(PL_lex_starts);
2344     SAVEI8(PL_lex_state);
2345     SAVESPTR(PL_lex_repl);
2346     SAVEVPTR(PL_lex_inpat);
2347     SAVEI16(PL_lex_inwhat);
2348     if (is_heredoc)
2349     {
2350         SAVECOPLINE(PL_curcop);
2351         SAVEI32(PL_multi_end);
2352         SAVEI32(PL_parser->herelines);
2353         PL_parser->herelines = 0;
2354     }
2355     SAVEI8(PL_multi_close);
2356     SAVEPPTR(PL_bufptr);
2357     SAVEPPTR(PL_bufend);
2358     SAVEPPTR(PL_oldbufptr);
2359     SAVEPPTR(PL_oldoldbufptr);
2360     SAVEPPTR(PL_last_lop);
2361     SAVEPPTR(PL_last_uni);
2362     SAVEPPTR(PL_linestart);
2363     SAVESPTR(PL_linestr);
2364     SAVEGENERICPV(PL_lex_brackstack);
2365     SAVEGENERICPV(PL_lex_casestack);
2366     SAVEGENERICPV(PL_parser->lex_shared);
2367     SAVEBOOL(PL_parser->lex_re_reparsing);
2368     SAVEI32(PL_copline);
2369
2370     /* The here-doc parser needs to be able to peek into outer lexing
2371        scopes to find the body of the here-doc.  So we put PL_linestr and
2372        PL_bufptr into lex_shared, to ‘share’ those values.
2373      */
2374     PL_parser->lex_shared->ls_linestr = PL_linestr;
2375     PL_parser->lex_shared->ls_bufptr  = PL_bufptr;
2376
2377     PL_linestr = PL_lex_stuff;
2378     PL_lex_repl = PL_sublex_info.repl;
2379     PL_lex_stuff = NULL;
2380     PL_sublex_info.repl = NULL;
2381
2382     /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2383        set for an inner quote-like operator and then an error causes scope-
2384        popping.  We must not have a PL_lex_stuff value left dangling, as
2385        that breaks assumptions elsewhere.  See bug #123617.  */
2386     SAVEGENERICSV(PL_lex_stuff);
2387     SAVEGENERICSV(PL_sublex_info.repl);
2388
2389     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2390         = SvPVX(PL_linestr);
2391     PL_bufend += SvCUR(PL_linestr);
2392     PL_last_lop = PL_last_uni = NULL;
2393     SAVEFREESV(PL_linestr);
2394     if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2395
2396     PL_lex_dojoin = FALSE;
2397     PL_lex_brackets = PL_lex_formbrack = 0;
2398     PL_lex_allbrackets = 0;
2399     PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2400     Newx(PL_lex_brackstack, 120, char);
2401     Newx(PL_lex_casestack, 12, char);
2402     PL_lex_casemods = 0;
2403     *PL_lex_casestack = '\0';
2404     PL_lex_starts = 0;
2405     PL_lex_state = LEX_INTERPCONCAT;
2406     if (is_heredoc)
2407         CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2408     PL_copline = NOLINE;
2409     
2410     Newxz(shared, 1, LEXSHARED);
2411     shared->ls_prev = PL_parser->lex_shared;
2412     PL_parser->lex_shared = shared;
2413
2414     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2415     if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2416     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2417         PL_lex_inpat = PL_sublex_info.sub_op;
2418     else
2419         PL_lex_inpat = NULL;
2420
2421     PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2422     PL_in_eval &= ~EVAL_RE_REPARSING;
2423
2424     return '(';
2425 }
2426
2427 /*
2428  * S_sublex_done
2429  * Restores lexer state after a S_sublex_push.
2430  */
2431
2432 STATIC I32
2433 S_sublex_done(pTHX)
2434 {
2435     if (!PL_lex_starts++) {
2436         SV * const sv = newSVpvs("");
2437         if (SvUTF8(PL_linestr))
2438             SvUTF8_on(sv);
2439         PL_expect = XOPERATOR;
2440         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2441         return THING;
2442     }
2443
2444     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
2445         PL_lex_state = LEX_INTERPCASEMOD;
2446         return yylex();
2447     }
2448
2449     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2450     assert(PL_lex_inwhat != OP_TRANSR);
2451     if (PL_lex_repl) {
2452         assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2453         PL_linestr = PL_lex_repl;
2454         PL_lex_inpat = 0;
2455         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2456         PL_bufend += SvCUR(PL_linestr);
2457         PL_last_lop = PL_last_uni = NULL;
2458         PL_lex_dojoin = FALSE;
2459         PL_lex_brackets = 0;
2460         PL_lex_allbrackets = 0;
2461         PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2462         PL_lex_casemods = 0;
2463         *PL_lex_casestack = '\0';
2464         PL_lex_starts = 0;
2465         if (SvEVALED(PL_lex_repl)) {
2466             PL_lex_state = LEX_INTERPNORMAL;
2467             PL_lex_starts++;
2468             /*  we don't clear PL_lex_repl here, so that we can check later
2469                 whether this is an evalled subst; that means we rely on the
2470                 logic to ensure sublex_done() is called again only via the
2471                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2472         }
2473         else {
2474             PL_lex_state = LEX_INTERPCONCAT;
2475             PL_lex_repl = NULL;
2476         }
2477         if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2478             CopLINE(PL_curcop) +=
2479                 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
2480                  + PL_parser->herelines;
2481             PL_parser->herelines = 0;
2482         }
2483         return '/';
2484     }
2485     else {
2486         const line_t l = CopLINE(PL_curcop);
2487         LEAVE;
2488         if (PL_multi_close == '<')
2489             PL_parser->herelines += l - PL_multi_end;
2490         PL_bufend = SvPVX(PL_linestr);
2491         PL_bufend += SvCUR(PL_linestr);
2492         PL_expect = XOPERATOR;
2493         return ')';
2494     }
2495 }
2496
2497 PERL_STATIC_INLINE SV*
2498 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2499 {
2500     /* <s> points to first character of interior of \N{}, <e> to one beyond the
2501      * interior, hence to the "}".  Finds what the name resolves to, returning
2502      * an SV* containing it; NULL if no valid one found */
2503
2504     SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2505
2506     HV * table;
2507     SV **cvp;
2508     SV *cv;
2509     SV *rv;
2510     HV *stash;
2511     const U8* first_bad_char_loc;
2512     const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2513
2514     PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2515
2516     if (!SvCUR(res)) {
2517         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
2518                        "Unknown charname '' is deprecated");
2519         return res;
2520     }
2521
2522     if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2523                                      e - backslash_ptr,
2524                                      &first_bad_char_loc))
2525     {
2526         /* If warnings are on, this will print a more detailed analysis of what
2527          * is wrong than the error message below */
2528         utf8n_to_uvchr(first_bad_char_loc,
2529                        e - ((char *) first_bad_char_loc),
2530                        NULL, 0);
2531
2532         /* We deliberately don't try to print the malformed character, which
2533          * might not print very well; it also may be just the first of many
2534          * malformations, so don't print what comes after it */
2535         yyerror_pv(Perl_form(aTHX_
2536             "Malformed UTF-8 character immediately after '%.*s'",
2537             (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr),
2538                    SVf_UTF8);
2539         return NULL;
2540     }
2541
2542     res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2543                         /* include the <}> */
2544                         e - backslash_ptr + 1);
2545     if (! SvPOK(res)) {
2546         SvREFCNT_dec_NN(res);
2547         return NULL;
2548     }
2549
2550     /* See if the charnames handler is the Perl core's, and if so, we can skip
2551      * the validation needed for a user-supplied one, as Perl's does its own
2552      * validation. */
2553     table = GvHV(PL_hintgv);             /* ^H */
2554     cvp = hv_fetchs(table, "charnames", FALSE);
2555     if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2556         SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2557     {
2558         const char * const name = HvNAME(stash);
2559         if (HvNAMELEN(stash) == sizeof("_charnames")-1
2560          && strEQ(name, "_charnames")) {
2561            return res;
2562        }
2563     }
2564
2565     /* Here, it isn't Perl's charname handler.  We can't rely on a
2566      * user-supplied handler to validate the input name.  For non-ut8 input,
2567      * look to see that the first character is legal.  Then loop through the
2568      * rest checking that each is a continuation */
2569
2570     /* This code makes the reasonable assumption that the only Latin1-range
2571      * characters that begin a character name alias are alphabetic, otherwise
2572      * would have to create a isCHARNAME_BEGIN macro */
2573
2574     if (! UTF) {
2575         if (! isALPHAU(*s)) {
2576             goto bad_charname;
2577         }
2578         s++;
2579         while (s < e) {
2580             if (! isCHARNAME_CONT(*s)) {
2581                 goto bad_charname;
2582             }
2583             if (*s == ' ' && *(s-1) == ' ') {
2584                 goto multi_spaces;
2585             }
2586             s++;
2587         }
2588     }
2589     else {
2590         /* Similarly for utf8.  For invariants can check directly; for other
2591          * Latin1, can calculate their code point and check; otherwise  use a
2592          * swash */
2593         if (UTF8_IS_INVARIANT(*s)) {
2594             if (! isALPHAU(*s)) {
2595                 goto bad_charname;
2596             }
2597             s++;
2598         } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2599             if (! isALPHAU(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1)))) {
2600                 goto bad_charname;
2601             }
2602             s += 2;
2603         }
2604         else {
2605             if (! PL_utf8_charname_begin) {
2606                 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2607                 PL_utf8_charname_begin = _core_swash_init("utf8",
2608                                                         "_Perl_Charname_Begin",
2609                                                         &PL_sv_undef,
2610                                                         1, 0, NULL, &flags);
2611             }
2612             if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2613                 goto bad_charname;
2614             }
2615             s += UTF8SKIP(s);
2616         }
2617
2618         while (s < e) {
2619             if (UTF8_IS_INVARIANT(*s)) {
2620                 if (! isCHARNAME_CONT(*s)) {
2621                     goto bad_charname;
2622                 }
2623                 if (*s == ' ' && *(s-1) == ' ') {
2624                     goto multi_spaces;
2625                 }
2626                 s++;
2627             }
2628             else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2629                 if (! isCHARNAME_CONT(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1))))
2630                 {
2631                     goto bad_charname;
2632                 }
2633                 s += 2;
2634             }
2635             else {
2636                 if (! PL_utf8_charname_continue) {
2637                     U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2638                     PL_utf8_charname_continue = _core_swash_init("utf8",
2639                                                 "_Perl_Charname_Continue",
2640                                                 &PL_sv_undef,
2641                                                 1, 0, NULL, &flags);
2642                 }
2643                 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2644                     goto bad_charname;
2645                 }
2646                 s += UTF8SKIP(s);
2647             }
2648         }
2649     }
2650     if (*(s-1) == ' ') {
2651         yyerror_pv(
2652             Perl_form(aTHX_
2653             "charnames alias definitions may not contain trailing "
2654             "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2655             (int)(s - backslash_ptr + 1), backslash_ptr,
2656             (int)(e - s + 1), s + 1
2657             ),
2658         UTF ? SVf_UTF8 : 0);
2659         return NULL;
2660     }
2661
2662     if (SvUTF8(res)) { /* Don't accept malformed input */
2663         const U8* first_bad_char_loc;
2664         STRLEN len;
2665         const char* const str = SvPV_const(res, len);
2666         if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2667             /* If warnings are on, this will print a more detailed analysis of
2668              * what is wrong than the error message below */
2669             utf8n_to_uvchr(first_bad_char_loc,
2670                            (char *) first_bad_char_loc - str,
2671                            NULL, 0);
2672
2673             /* We deliberately don't try to print the malformed character,
2674              * which might not print very well; it also may be just the first
2675              * of many malformations, so don't print what comes after it */
2676             yyerror_pv(
2677               Perl_form(aTHX_
2678                 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2679                  (int) (e - backslash_ptr + 1), backslash_ptr,
2680                  (int) ((char *) first_bad_char_loc - str), str
2681               ),
2682               SVf_UTF8);
2683             return NULL;
2684         }
2685     }
2686
2687     return res;
2688
2689   bad_charname: {
2690
2691         /* The final %.*s makes sure that should the trailing NUL be missing
2692          * that this print won't run off the end of the string */
2693         yyerror_pv(
2694           Perl_form(aTHX_
2695             "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2696             (int)(s - backslash_ptr + 1), backslash_ptr,
2697             (int)(e - s + 1), s + 1
2698           ),
2699           UTF ? SVf_UTF8 : 0);
2700         return NULL;
2701     }
2702
2703   multi_spaces:
2704         yyerror_pv(
2705           Perl_form(aTHX_
2706             "charnames alias definitions may not contain a sequence of "
2707             "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2708             (int)(s - backslash_ptr + 1), backslash_ptr,
2709             (int)(e - s + 1), s + 1
2710           ),
2711           UTF ? SVf_UTF8 : 0);
2712         return NULL;
2713 }
2714
2715 /*
2716   scan_const
2717
2718   Extracts the next constant part of a pattern, double-quoted string,
2719   or transliteration.  This is terrifying code.
2720
2721   For example, in parsing the double-quoted string "ab\x63$d", it would
2722   stop at the '$' and return an OP_CONST containing 'abc'.
2723
2724   It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2725   processing a pattern (PL_lex_inpat is true), a transliteration
2726   (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2727
2728   Returns a pointer to the character scanned up to. If this is
2729   advanced from the start pointer supplied (i.e. if anything was
2730   successfully parsed), will leave an OP_CONST for the substring scanned
2731   in pl_yylval. Caller must intuit reason for not parsing further
2732   by looking at the next characters herself.
2733
2734   In patterns:
2735     expand:
2736       \N{FOO}  => \N{U+hex_for_character_FOO}
2737       (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2738
2739     pass through:
2740         all other \-char, including \N and \N{ apart from \N{ABC}
2741
2742     stops on:
2743         @ and $ where it appears to be a var, but not for $ as tail anchor
2744         \l \L \u \U \Q \E
2745         (?{  or  (??{
2746
2747   In transliterations:
2748     characters are VERY literal, except for - not at the start or end
2749     of the string, which indicates a range. If the range is in bytes,
2750     scan_const expands the range to the full set of intermediate
2751     characters. If the range is in utf8, the hyphen is replaced with
2752     a certain range mark which will be handled by pmtrans() in op.c.
2753
2754   In double-quoted strings:
2755     backslashes:
2756       double-quoted style: \r and \n
2757       constants: \x31, etc.
2758       deprecated backrefs: \1 (in substitution replacements)
2759       case and quoting: \U \Q \E
2760     stops on @ and $
2761
2762   scan_const does *not* construct ops to handle interpolated strings.
2763   It stops processing as soon as it finds an embedded $ or @ variable
2764   and leaves it to the caller to work out what's going on.
2765
2766   embedded arrays (whether in pattern or not) could be:
2767       @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2768
2769   $ in double-quoted strings must be the symbol of an embedded scalar.
2770
2771   $ in pattern could be $foo or could be tail anchor.  Assumption:
2772   it's a tail anchor if $ is the last thing in the string, or if it's
2773   followed by one of "()| \r\n\t"
2774
2775   \1 (backreferences) are turned into $1 in substitutions
2776
2777   The structure of the code is
2778       while (there's a character to process) {
2779           handle transliteration ranges
2780           skip regexp comments /(?#comment)/ and codes /(?{code})/
2781           skip #-initiated comments in //x patterns
2782           check for embedded arrays
2783           check for embedded scalars
2784           if (backslash) {
2785               deprecate \1 in substitution replacements
2786               handle string-changing backslashes \l \U \Q \E, etc.
2787               switch (what was escaped) {
2788                   handle \- in a transliteration (becomes a literal -)
2789                   if a pattern and not \N{, go treat as regular character
2790                   handle \132 (octal characters)
2791                   handle \x15 and \x{1234} (hex characters)
2792                   handle \N{name} (named characters, also \N{3,5} in a pattern)
2793                   handle \cV (control characters)
2794                   handle printf-style backslashes (\f, \r, \n, etc)
2795               } (end switch)
2796               continue
2797           } (end if backslash)
2798           handle regular character
2799     } (end while character to read)
2800                 
2801 */
2802
2803 STATIC char *
2804 S_scan_const(pTHX_ char *start)
2805 {
2806     char *send = PL_bufend;             /* end of the constant */
2807     SV *sv = newSV(send - start);       /* sv for the constant.  See note below
2808                                            on sizing. */
2809     char *s = start;                    /* start of the constant */
2810     char *d = SvPVX(sv);                /* destination for copies */
2811     bool dorange = FALSE;               /* are we in a translit range? */
2812     bool didrange = FALSE;              /* did we just finish a range? */
2813     bool in_charclass = FALSE;          /* within /[...]/ */
2814     bool has_utf8 = FALSE;              /* Output constant is UTF8 */
2815     bool  this_utf8 = cBOOL(UTF);       /* Is the source string assumed to be
2816                                            UTF8?  But, this can show as true
2817                                            when the source isn't utf8, as for
2818                                            example when it is entirely composed
2819                                            of hex constants */
2820     SV *res;                            /* result from charnames */
2821     STRLEN offset_to_max;   /* The offset in the output to where the range
2822                                high-end character is temporarily placed */
2823
2824     /* Note on sizing:  The scanned constant is placed into sv, which is
2825      * initialized by newSV() assuming one byte of output for every byte of
2826      * input.  This routine expects newSV() to allocate an extra byte for a
2827      * trailing NUL, which this routine will append if it gets to the end of
2828      * the input.  There may be more bytes of input than output (eg., \N{LATIN
2829      * CAPITAL LETTER A}), or more output than input if the constant ends up
2830      * recoded to utf8, but each time a construct is found that might increase
2831      * the needed size, SvGROW() is called.  Its size parameter each time is
2832      * based on the best guess estimate at the time, namely the length used so
2833      * far, plus the length the current construct will occupy, plus room for
2834      * the trailing NUL, plus one byte for every input byte still unscanned */ 
2835
2836     UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2837                        before set */
2838 #ifdef EBCDIC
2839     int backslash_N = 0;            /* ? was the character from \N{} */
2840     int non_portable_endpoint = 0;  /* ? In a range is an endpoint
2841                                        platform-specific like \x65 */
2842 #endif
2843
2844     PERL_ARGS_ASSERT_SCAN_CONST;
2845
2846     assert(PL_lex_inwhat != OP_TRANSR);
2847     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2848         /* If we are doing a trans and we know we want UTF8 set expectation */
2849         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2850         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2851     }
2852
2853     /* Protect sv from errors and fatal warnings. */
2854     ENTER_with_name("scan_const");
2855     SAVEFREESV(sv);
2856
2857     while (s < send
2858            || dorange   /* Handle tr/// range at right edge of input */
2859     ) {
2860
2861         /* get transliterations out of the way (they're most literal) */
2862         if (PL_lex_inwhat == OP_TRANS) {
2863
2864             /* But there isn't any special handling necessary unless there is a
2865              * range, so for most cases we just drop down and handle the value
2866              * as any other.  There are two exceptions.
2867              *
2868              * 1.  A minus sign indicates that we are actually going to have
2869              *     a range.  In this case, skip the '-', set a flag, then drop
2870              *     down to handle what should be the end range value.
2871              * 2.  After we've handled that value, the next time through, that
2872              *     flag is set and we fix up the range.
2873              *
2874              * Ranges entirely within Latin1 are expanded out entirely, in
2875              * order to avoid the significant overhead of making a swash.
2876              * Ranges that extend above Latin1 have to have a swash, so there
2877              * is no advantage to abbreviate them here, so they are stored here
2878              * as Min, ILLEGAL_UTF8_BYTE, Max.  The illegal byte signifies a
2879              * hyphen without any possible ambiguity.  On EBCDIC machines, if
2880              * the range is expressed as Unicode, the Latin1 portion is
2881              * expanded out even if the entire range extends above Latin1.
2882              * This is because each code point in it has to be processed here
2883              * individually to get its native translation */
2884
2885             if (! dorange) {
2886
2887                 /* Here, we don't think we're in a range.  If we've processed
2888                  * at least one character, then see if this next one is a '-',
2889                  * indicating the previous one was the start of a range.  But
2890                  * don't bother if we're too close to the end for the minus to
2891                  * mean that. */
2892                 if (*s != '-' || s >= send - 1 || s == start) {
2893
2894                     /* A regular character.  Process like any other, but first
2895                      * clear any flags */
2896                     didrange = FALSE;
2897                     dorange = FALSE;
2898 #ifdef EBCDIC
2899                     non_portable_endpoint = 0;
2900                     backslash_N = 0;
2901 #endif
2902                     /* Drops down to generic code to process current byte */
2903                 }
2904                 else {
2905                     if (didrange) { /* Something like y/A-C-Z// */
2906                         Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2907                     }
2908
2909                     dorange = TRUE;
2910
2911                     s++;    /* Skip past the minus */
2912
2913                     /* d now points to where the end-range character will be
2914                      * placed.  Save it so won't have to go finding it later,
2915                      * and drop down to get that character.  (Actually we
2916                      * instead save the offset, to handle the case where a
2917                      * realloc in the meantime could change the actual
2918                      * pointer).  We'll finish processing the range the next
2919                      * time through the loop */
2920                     offset_to_max = d - SvPVX_const(sv);
2921                 }
2922             }  /* End of not a range */
2923             else {
2924                 /* Here we have parsed a range.  Now must handle it.  At this
2925                  * point:
2926                  * 'sv' is a SV* that contains the output string we are
2927                  *      constructing.  The final two characters in that string
2928                  *      are the range start and range end, in order.
2929                  * 'd'  points to just beyond the range end in the 'sv' string,
2930                  *      where we would next place something
2931                  * 'offset_to_max' is the offset in 'sv' at which the character
2932                  *      before 'd' begins.
2933                  */
2934                 const char * max_ptr = SvPVX_const(sv) + offset_to_max;
2935                 const char * min_ptr;
2936                 IV range_min;
2937                 IV range_max;   /* last character in range */
2938                 STRLEN save_offset;
2939                 STRLEN grow;
2940 #ifndef EBCDIC  /* Not meaningful except in EBCDIC, so initialize to false */
2941                 const bool convert_unicode = FALSE;
2942                 const IV real_range_max = 0;
2943 #else
2944                 bool convert_unicode;
2945                 IV real_range_max = 0;
2946 #endif
2947
2948                 /* Get the range-ends code point values. */
2949                 if (has_utf8) {
2950                     /* We know the utf8 is valid, because we just constructed
2951                      * it ourselves in previous loop iterations */
2952                     min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1);
2953                     range_min = valid_utf8_to_uvchr( (U8*) min_ptr, NULL);
2954                     range_max = valid_utf8_to_uvchr( (U8*) max_ptr, NULL);
2955                 }
2956                 else {
2957                     min_ptr = max_ptr - 1;
2958                     range_min = * (U8*) min_ptr;
2959                     range_max = * (U8*) max_ptr;
2960                 }
2961
2962 #ifdef EBCDIC
2963                 /* On EBCDIC platforms, we may have to deal with portable
2964                  * ranges.  These happen if at least one range endpoint is a
2965                  * Unicode value (\N{...}), or if the range is a subset of
2966                  * [A-Z] or [a-z], and both ends are literal characters,
2967                  * like 'A', and not like \x{C1} */
2968                 if ((convert_unicode
2969                      = cBOOL(backslash_N)   /* \N{} forces Unicode, hence
2970                                                portable range */
2971                       || (   ! non_portable_endpoint
2972                           && ((  isLOWER_A(range_min) && isLOWER_A(range_max))
2973                              || (isUPPER_A(range_min) && isUPPER_A(range_max))))
2974                 )) {
2975
2976                     /* Special handling is needed for these portable ranges.
2977                      * They are defined to all be in Unicode terms, which
2978                      * include all Unicode code points between the end points.
2979                      * Convert to Unicode to get the Unicode range.  Later we
2980                      * will convert each code point in the range back to
2981                      * native.  */
2982                     range_min = NATIVE_TO_UNI(range_min);
2983                     range_max = NATIVE_TO_UNI(range_max);
2984                 }
2985 #endif
2986
2987                 if (range_min > range_max) {
2988                     if (convert_unicode) {
2989                         /* Need to convert back to native for meaningful
2990                          * messages for this platform */
2991                         range_min = UNI_TO_NATIVE(range_min);
2992                         range_max = UNI_TO_NATIVE(range_max);
2993                     }
2994
2995                     /* Use the characters themselves for the error message if
2996                      * ASCII printables; otherwise some visible representation
2997                      * of them */
2998                     if (isPRINT_A(range_min) && isPRINT_A(range_max)) {
2999                         Perl_croak(aTHX_
3000                          "Invalid range \"%c-%c\" in transliteration operator",
3001                          (char)range_min, (char)range_max);
3002                     }
3003                     else if (convert_unicode) {
3004                         /* diag_listed_as: Invalid range "%s" in transliteration operator */
3005                         Perl_croak(aTHX_
3006                                "Invalid range \"\\N{U+%04"UVXf"}-\\N{U+%04"UVXf"}\""
3007                                " in transliteration operator",
3008                                range_min, range_max);
3009                     }
3010                     else {
3011                         /* diag_listed_as: Invalid range "%s" in transliteration operator */
3012                         Perl_croak(aTHX_
3013                                "Invalid range \"\\x{%04"UVXf"}-\\x{%04"UVXf"}\""
3014                                " in transliteration operator",
3015                                range_min, range_max);
3016                     }
3017                 }
3018
3019                 if (has_utf8) {
3020
3021                     /* We try to avoid creating a swash.  If the upper end of
3022                      * this range is below 256, this range won't force a swash;
3023                      * otherwise it does force a swash, and as long as we have
3024                      * to have one, we might as well not expand things out.
3025                      * But if it's EBCDIC, we may have to look at each
3026                      * character below 256 if we have to convert to/from
3027                      * Unicode values */
3028                     if (range_max > 255
3029 #ifdef EBCDIC
3030                         && (range_min > 255 || ! convert_unicode)
3031 #endif
3032                     ) {
3033                         /* Move the high character one byte to the right; then
3034                          * insert between it and the range begin, an illegal
3035                          * byte which serves to indicate this is a range (using
3036                          * a '-' could be ambiguous). */
3037                         char *e = d++;
3038                         while (e-- > max_ptr) {
3039                             *(e + 1) = *e;
3040                         }
3041                         *(e + 1) = (char) ILLEGAL_UTF8_BYTE;
3042                         goto range_done;
3043                     }
3044
3045                     /* Here, we're going to expand out the range.  For EBCDIC
3046                      * the range can extend above 255 (not so in ASCII), so
3047                      * for EBCDIC, split it into the parts above and below
3048                      * 255/256 */
3049 #ifdef EBCDIC
3050                     if (range_max > 255) {
3051                         real_range_max = range_max;
3052                         range_max = 255;
3053                     }
3054 #endif
3055                 }
3056
3057                 /* Here we need to expand out the string to contain each
3058                  * character in the range.  Grow the output to handle this */
3059
3060                 save_offset  = min_ptr - SvPVX_const(sv);
3061
3062                 /* The base growth is the number of code points in the range */
3063                 grow = range_max - range_min + 1;
3064                 if (has_utf8) {
3065
3066                     /* But if the output is UTF-8, some of those characters may
3067                      * need two bytes (since the maximum range value here is
3068                      * 255, the max bytes per character is two).  On ASCII
3069                      * platforms, it's not much trouble to get an accurate
3070                      * count of what's needed.  But on EBCDIC, the ones that
3071                      * need 2 bytes are scattered around, so just use a worst
3072                      * case value instead of calculating for that platform.  */
3073 #ifdef EBCDIC
3074                     grow *= 2;
3075 #else
3076                     /* Only those above 127 require 2 bytes.  This may be
3077                      * everything in the range, or not */
3078                     if (range_min > 127) {
3079                         grow *= 2;
3080                     }
3081                     else if (range_max > 127) {
3082                         grow += range_max - 127;
3083                     }
3084 #endif
3085                 }
3086
3087                 /* Subtract 3 for the bytes that were already accounted for
3088                  * (min, max, and the hyphen) */
3089                 SvGROW(sv, SvLEN(sv) + grow - 3);
3090                 d = SvPVX(sv) + save_offset;    /* refresh d after realloc */
3091
3092                 /* Here, we expand out the range.  On ASCII platforms, the
3093                  * compiler should optimize out the 'convert_unicode==TRUE'
3094                  * portion of this */
3095                 if (convert_unicode) {
3096                     IV i;
3097
3098                     /* Recall that the min and max are now in Unicode terms, so
3099                      * we have to convert each character to its native
3100                      * equivalent */
3101                     if (has_utf8) {
3102                         for (i = range_min; i <= range_max; i++) {
3103                             append_utf8_from_native_byte(LATIN1_TO_NATIVE((U8) i),
3104                                                          (U8 **) &d);
3105                         }
3106                     }
3107                     else {
3108                         for (i = range_min; i <= range_max; i++) {
3109                             *d++ = (char)LATIN1_TO_NATIVE((U8) i);
3110                         }
3111                     }
3112                 }
3113                 else {
3114                     IV i;
3115
3116                     /* Here, no conversions are necessary, which means that the
3117                      * first character in the range is already in 'd' and
3118                      * valid, so we can skip overwriting it */
3119                     if (has_utf8) {
3120                         d += UTF8SKIP(d);
3121                         for (i = range_min + 1; i <= range_max; i++) {
3122                             append_utf8_from_native_byte((U8) i, (U8 **) &d);
3123                         }
3124                     }
3125                     else {
3126                         d++;
3127                         for (i = range_min + 1; i <= range_max; i++) {
3128                             *d++ = (char)i;
3129                         }
3130                     }
3131                 }
3132
3133                 /* (Compilers should optimize this out for non-EBCDIC).  If the
3134                  * original range extended above 255, add in that portion */
3135                 if (real_range_max) {
3136                     *d++ = (char) UTF8_TWO_BYTE_HI(0x100);
3137                     *d++ = (char) UTF8_TWO_BYTE_LO(0x100);
3138                     if (real_range_max > 0x101)
3139                         *d++ = (char) ILLEGAL_UTF8_BYTE;
3140                     if (real_range_max > 0x100)
3141                         d = (char*)uvchr_to_utf8((U8*)d, real_range_max);
3142                 }
3143
3144               range_done:
3145                 /* mark the range as done, and continue */
3146                 didrange = TRUE;
3147                 dorange = FALSE;
3148 #ifdef EBCDIC
3149                 non_portable_endpoint = 0;
3150                 backslash_N = 0;
3151 #endif
3152                 continue;
3153             } /* End of is a range */
3154         } /* End of transliteration.  Joins main code after these else's */
3155         else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3156             char *s1 = s-1;
3157             int esc = 0;
3158             while (s1 >= start && *s1-- == '\\')
3159                 esc = !esc;
3160             if (!esc)
3161                 in_charclass = TRUE;
3162         }
3163
3164         else if (*s == ']' && PL_lex_inpat &&  in_charclass) {
3165             char *s1 = s-1;
3166             int esc = 0;
3167             while (s1 >= start && *s1-- == '\\')
3168                 esc = !esc;
3169             if (!esc)
3170                 in_charclass = FALSE;
3171         }
3172
3173         /* skip for regexp comments /(?#comment)/, except for the last
3174          * char, which will be done separately.
3175          * Stop on (?{..}) and friends */
3176
3177         else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3178             if (s[2] == '#') {
3179                 while (s+1 < send && *s != ')')
3180                     *d++ = *s++;
3181             }
3182             else if (!PL_lex_casemods
3183                      && (    s[2] == '{' /* This should match regcomp.c */
3184                          || (s[2] == '?' && s[3] == '{')))
3185             {
3186                 break;
3187             }
3188         }
3189
3190         /* likewise skip #-initiated comments in //x patterns */
3191         else if (*s == '#'
3192                  && PL_lex_inpat
3193                  && !in_charclass
3194                  && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED)
3195         {
3196             while (s+1 < send && *s != '\n')
3197                 *d++ = *s++;
3198         }
3199
3200         /* no further processing of single-quoted regex */
3201         else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3202             goto default_action;
3203
3204         /* check for embedded arrays
3205            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3206            */
3207         else if (*s == '@' && s[1]) {
3208             if (UTF ? isIDFIRST_utf8((U8*)s+1) : isWORDCHAR_A(s[1]))
3209                 break;
3210             if (strchr(":'{$", s[1]))
3211                 break;
3212             if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3213                 break; /* in regexp, neither @+ nor @- are interpolated */
3214         }
3215
3216         /* check for embedded scalars.  only stop if we're sure it's a
3217            variable.
3218         */
3219         else if (*s == '$') {
3220             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
3221                 break;
3222             if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3223                 if (s[1] == '\\') {
3224                     Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3225                                    "Possible unintended interpolation of $\\ in regex");
3226                 }
3227                 break;          /* in regexp, $ might be tail anchor */
3228             }
3229         }
3230
3231         /* End of else if chain - OP_TRANS rejoin rest */
3232
3233         /* backslashes */
3234         if (*s == '\\' && s+1 < send) {
3235             char* e;    /* Can be used for ending '}', etc. */
3236
3237             s++;
3238
3239             /* warn on \1 - \9 in substitution replacements, but note that \11
3240              * is an octal; and \19 is \1 followed by '9' */
3241             if (PL_lex_inwhat == OP_SUBST
3242                 && !PL_lex_inpat
3243                 && isDIGIT(*s)
3244                 && *s != '0'
3245                 && !isDIGIT(s[1]))
3246             {
3247                 /* diag_listed_as: \%d better written as $%d */
3248                 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3249                 *--s = '$';
3250                 break;
3251             }
3252
3253             /* string-change backslash escapes */
3254             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3255                 --s;
3256                 break;
3257             }
3258             /* In a pattern, process \N, but skip any other backslash escapes.
3259              * This is because we don't want to translate an escape sequence
3260              * into a meta symbol and have the regex compiler use the meta
3261              * symbol meaning, e.g. \x{2E} would be confused with a dot.  But
3262              * in spite of this, we do have to process \N here while the proper
3263              * charnames handler is in scope.  See bugs #56444 and #62056.
3264              *
3265              * There is a complication because \N in a pattern may also stand
3266              * for 'match a non-nl', and not mean a charname, in which case its
3267              * processing should be deferred to the regex compiler.  To be a
3268              * charname it must be followed immediately by a '{', and not look
3269              * like \N followed by a curly quantifier, i.e., not something like
3270              * \N{3,}.  regcurly returns a boolean indicating if it is a legal
3271              * quantifier */
3272             else if (PL_lex_inpat
3273                     && (*s != 'N'
3274                         || s[1] != '{'
3275                         || regcurly(s + 1)))
3276             {
3277                 *d++ = '\\';
3278                 goto default_action;
3279             }
3280
3281             switch (*s) {
3282             default:
3283                 {
3284                     if ((isALPHANUMERIC(*s)))
3285                         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3286                                        "Unrecognized escape \\%c passed through",
3287                                        *s);
3288                     /* default action is to copy the quoted character */
3289                     goto default_action;
3290                 }
3291
3292             /* eg. \132 indicates the octal constant 0132 */
3293             case '0': case '1': case '2': case '3':
3294             case '4': case '5': case '6': case '7':
3295                 {
3296                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3297                     STRLEN len = 3;
3298                     uv = grok_oct(s, &len, &flags, NULL);
3299                     s += len;
3300                     if (len < 3 && s < send && isDIGIT(*s)
3301                         && ckWARN(WARN_MISC))
3302                     {
3303                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3304                                     "%s", form_short_octal_warning(s, len));
3305                     }
3306                 }
3307                 goto NUM_ESCAPE_INSERT;
3308
3309             /* eg. \o{24} indicates the octal constant \024 */
3310             case 'o':
3311                 {
3312                     const char* error;
3313
3314                     bool valid = grok_bslash_o(&s, &uv, &error,
3315                                                TRUE, /* Output warning */
3316                                                FALSE, /* Not strict */
3317                                                TRUE, /* Output warnings for
3318                                                          non-portables */
3319                                                UTF);
3320                     if (! valid) {
3321                         yyerror(error);
3322                         continue;
3323                     }
3324                     goto NUM_ESCAPE_INSERT;
3325                 }
3326
3327             /* eg. \x24 indicates the hex constant 0x24 */
3328             case 'x':
3329                 {
3330                     const char* error;
3331
3332                     bool valid = grok_bslash_x(&s, &uv, &error,
3333                                                TRUE, /* Output warning */
3334                                                FALSE, /* Not strict */
3335                                                TRUE,  /* Output warnings for
3336                                                          non-portables */
3337                                                UTF);
3338                     if (! valid) {
3339                         yyerror(error);
3340                         continue;
3341                     }
3342                 }
3343
3344               NUM_ESCAPE_INSERT:
3345                 /* Insert oct or hex escaped character. */
3346                 
3347                 /* Here uv is the ordinal of the next character being added */
3348                 if (UVCHR_IS_INVARIANT(uv)) {
3349                     *d++ = (char) uv;
3350                 }
3351                 else {
3352                     if (!has_utf8 && uv > 255) {
3353                         /* Might need to recode whatever we have accumulated so
3354                          * far if it contains any chars variant in utf8 or
3355                          * utf-ebcdic. */
3356                           
3357                         SvCUR_set(sv, d - SvPVX_const(sv));
3358                         SvPOK_on(sv);
3359                         *d = '\0';
3360                         /* See Note on sizing above.  */
3361                         sv_utf8_upgrade_flags_grow(
3362                                        sv,
3363                                        SV_GMAGIC|SV_FORCE_UTF8_UPGRADE
3364                                                   /* Above-latin1 in string
3365                                                    * implies no encoding */
3366                                                   |SV_UTF8_NO_ENCODING,
3367                                        UVCHR_SKIP(uv) + (STRLEN)(send - s) + 1);
3368                         d = SvPVX(sv) + SvCUR(sv);
3369                         has_utf8 = TRUE;
3370                     }
3371
3372                     if (has_utf8) {
3373                        /* Usually, there will already be enough room in 'sv'
3374                         * since such escapes are likely longer than any UTF-8
3375                         * sequence they can end up as.  This isn't the case on
3376                         * EBCDIC where \x{40000000} contains 12 bytes, and the
3377                         * UTF-8 for it contains 14.  And, we have to allow for
3378                         * a trailing NUL.  It probably can't happen on ASCII
3379                         * platforms, but be safe */
3380                         const STRLEN needed = d - SvPVX(sv) + UVCHR_SKIP(uv)
3381                                             + 1;
3382                         if (UNLIKELY(needed > SvLEN(sv))) {
3383                             SvCUR_set(sv, d - SvPVX_const(sv));
3384                             d = sv_grow(sv, needed) + SvCUR(sv);
3385                         }
3386
3387                         d = (char*)uvchr_to_utf8((U8*)d, uv);
3388                         if (PL_lex_inwhat == OP_TRANS
3389                             && PL_sublex_info.sub_op)
3390                         {
3391                             PL_sublex_info.sub_op->op_private |=
3392                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
3393                                              : OPpTRANS_TO_UTF);
3394                         }
3395                     }
3396                     else {
3397                         *d++ = (char)uv;
3398                     }
3399                 }
3400 #ifdef EBCDIC
3401                 non_portable_endpoint++;
3402 #endif
3403                 continue;
3404
3405             case 'N':
3406                 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3407                  * named character, like \N{LATIN SMALL LETTER A}, or a named
3408                  * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3409                  * GRAVE} (except y/// can't handle the latter, croaking).  For
3410                  * convenience all three forms are referred to as "named
3411                  * characters" below.
3412                  *
3413                  * For patterns, \N also can mean to match a non-newline.  Code
3414                  * before this 'switch' statement should already have handled
3415                  * this situation, and hence this code only has to deal with
3416                  * the named character cases.
3417                  *
3418                  * For non-patterns, the named characters are converted to
3419                  * their string equivalents.  In patterns, named characters are
3420                  * not converted to their ultimate forms for the same reasons
3421                  * that other escapes aren't.  Instead, they are converted to
3422                  * the \N{U+...} form to get the value from the charnames that
3423                  * is in effect right now, while preserving the fact that it
3424                  * was a named character, so that the regex compiler knows
3425                  * this.
3426                  *
3427                  * The structure of this section of code (besides checking for
3428                  * errors and upgrading to utf8) is:
3429                  *    If the named character is of the form \N{U+...}, pass it
3430                  *      through if a pattern; otherwise convert the code point
3431                  *      to utf8
3432                  *    Otherwise must be some \N{NAME}: convert to
3433                  *      \N{U+c1.c2...} if a pattern; otherwise convert to utf8
3434                  *
3435                  * Transliteration is an exception.  The conversion to utf8 is
3436                  * only done if the code point requires it to be representable.
3437                  *
3438                  * Here, 's' points to the 'N'; the test below is guaranteed to
3439                  * succeed if we are being called on a pattern, as we already
3440                  * know from a test above that the next character is a '{'.  A
3441                  * non-pattern \N must mean 'named character', which requires
3442                  * braces */
3443                 s++;
3444                 if (*s != '{') {
3445                     yyerror("Missing braces on \\N{}"); 
3446                     continue;
3447                 }
3448                 s++;
3449
3450                 /* If there is no matching '}', it is an error. */
3451                 if (! (e = strchr(s, '}'))) {
3452                     if (! PL_lex_inpat) {
3453                         yyerror("Missing right brace on \\N{}");
3454                     } else {
3455                         yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3456                     }
3457                     continue;
3458                 }
3459
3460                 /* Here it looks like a named character */
3461
3462                 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3463                     s += 2;         /* Skip to next char after the 'U+' */
3464                     if (PL_lex_inpat) {
3465
3466                         /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3467                         /* Check the syntax.  */
3468                         const char *orig_s;
3469                         orig_s = s - 5;
3470                         if (!isXDIGIT(*s)) {
3471                           bad_NU:
3472                             yyerror(
3473                                 "Invalid hexadecimal number in \\N{U+...}"
3474                             );
3475                             s = e + 1;
3476                             continue;
3477                         }
3478                         while (++s < e) {
3479                             if (isXDIGIT(*s))
3480                                 continue;
3481                             else if ((*s == '.' || *s == '_')
3482                                   && isXDIGIT(s[1]))
3483                                 continue;
3484                             goto bad_NU;
3485                         }
3486
3487                         /* Pass everything through unchanged.
3488                          * +1 is for the '}' */
3489                         Copy(orig_s, d, e - orig_s + 1, char);
3490                         d += e - orig_s + 1;
3491                     }
3492                     else {  /* Not a pattern: convert the hex to string */
3493                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3494                                 | PERL_SCAN_SILENT_ILLDIGIT
3495                                 | PERL_SCAN_DISALLOW_PREFIX;
3496                         STRLEN len = e - s;
3497                         uv = grok_hex(s, &len, &flags, NULL);
3498                         if (len == 0 || (len != (STRLEN)(e - s)))
3499                             goto bad_NU;
3500
3501                          /* For non-tr///, if the destination is not in utf8,
3502                           * unconditionally recode it to be so.  This is
3503                           * because \N{} implies Unicode semantics, and scalars
3504                           * have to be in utf8 to guarantee those semantics.
3505                           * tr/// doesn't care about Unicode rules, so no need
3506                           * there to upgrade to UTF-8 for small enough code
3507                           * points */
3508                         if (! has_utf8 && (   uv > 0xFF
3509                                            || PL_lex_inwhat != OP_TRANS))
3510                         {
3511                             SvCUR_set(sv, d - SvPVX_const(sv));
3512                             SvPOK_on(sv);
3513                             *d = '\0';
3514                             /* See Note on sizing above.  */
3515                             sv_utf8_upgrade_flags_grow(
3516                                     sv,
3517                                     SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3518                                     UVCHR_SKIP(uv) + (STRLEN)(send - e) + 1);
3519                             d = SvPVX(sv) + SvCUR(sv);
3520                             has_utf8 = TRUE;
3521                         }
3522
3523                         /* Add the (Unicode) code point to the output. */
3524                         if (OFFUNI_IS_INVARIANT(uv)) {
3525                             *d++ = (char) LATIN1_TO_NATIVE(uv);
3526                         }
3527                         else {
3528                             d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3529                         }
3530                     }
3531                 }
3532                 else /* Here is \N{NAME} but not \N{U+...}. */
3533                      if ((res = get_and_check_backslash_N_name(s, e)))
3534                 {
3535                     STRLEN len;
3536                     const char *str = SvPV_const(res, len);
3537                     if (PL_lex_inpat) {
3538
3539                         if (! len) { /* The name resolved to an empty string */
3540                             Copy("\\N{}", d, 4, char);
3541                             d += 4;
3542                         }
3543                         else {
3544                             /* In order to not lose information for the regex
3545                             * compiler, pass the result in the specially made
3546                             * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3547                             * the code points in hex of each character
3548                             * returned by charnames */
3549
3550                             const char *str_end = str + len;
3551                             const STRLEN off = d - SvPVX_const(sv);
3552
3553                             if (! SvUTF8(res)) {
3554                                 /* For the non-UTF-8 case, we can determine the
3555                                  * exact length needed without having to parse
3556                                  * through the string.  Each character takes up
3557                                  * 2 hex digits plus either a trailing dot or
3558                                  * the "}" */
3559                                 const char initial_text[] = "\\N{U+";
3560                                 const STRLEN initial_len = sizeof(initial_text)
3561                                                            - 1;
3562                                 d = off + SvGROW(sv, off
3563                                                     + 3 * len
3564
3565                                                     /* +1 for trailing NUL */
3566                                                     + initial_len + 1
3567
3568                                                     + (STRLEN)(send - e));
3569                                 Copy(initial_text, d, initial_len, char);
3570                                 d += initial_len;
3571                                 while (str < str_end) {
3572                                     char hex_string[4];
3573                                     int len =
3574                                         my_snprintf(hex_string,
3575                                                   sizeof(hex_string),
3576                                                   "%02X.",
3577
3578                                                   /* The regex compiler is
3579                                                    * expecting Unicode, not
3580                                                    * native */
3581                                                   NATIVE_TO_LATIN1(*str));
3582                                     PERL_MY_SNPRINTF_POST_GUARD(len,
3583                                                            sizeof(hex_string));
3584                                     Copy(hex_string, d, 3, char);
3585                                     d += 3;
3586                                     str++;
3587                                 }
3588                                 d--;    /* Below, we will overwrite the final
3589                                            dot with a right brace */
3590                             }
3591                             else {
3592                                 STRLEN char_length; /* cur char's byte length */
3593
3594                                 /* and the number of bytes after this is
3595                                  * translated into hex digits */
3596                                 STRLEN output_length;
3597
3598                                 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3599                                  * for max('U+', '.'); and 1 for NUL */
3600                                 char hex_string[2 * UTF8_MAXBYTES + 5];
3601
3602                                 /* Get the first character of the result. */
3603                                 U32 uv = utf8n_to_uvchr((U8 *) str,
3604                                                         len,
3605                                                         &char_length,
3606                                                         UTF8_ALLOW_ANYUV);
3607                                 /* Convert first code point to Unicode hex,
3608                                  * including the boiler plate before it. */
3609                                 output_length =
3610                                     my_snprintf(hex_string, sizeof(hex_string),
3611                                              "\\N{U+%X",
3612                                              (unsigned int) NATIVE_TO_UNI(uv));
3613
3614                                 /* Make sure there is enough space to hold it */
3615                                 d = off + SvGROW(sv, off
3616                                                     + output_length
3617                                                     + (STRLEN)(send - e)
3618                                                     + 2);       /* '}' + NUL */
3619                                 /* And output it */
3620                                 Copy(hex_string, d, output_length, char);
3621                                 d += output_length;
3622
3623                                 /* For each subsequent character, append dot and
3624                                 * its Unicode code point in hex */
3625                                 while ((str += char_length) < str_end) {
3626                                     const STRLEN off = d - SvPVX_const(sv);
3627                                     U32 uv = utf8n_to_uvchr((U8 *) str,
3628                                                             str_end - str,
3629                                                             &char_length,
3630                                                             UTF8_ALLOW_ANYUV);
3631                                     output_length =
3632                                         my_snprintf(hex_string,
3633                                              sizeof(hex_string),
3634                                              ".%X",
3635                                              (unsigned int) NATIVE_TO_UNI(uv));
3636
3637                                     d = off + SvGROW(sv, off
3638                                                         + output_length
3639                                                         + (STRLEN)(send - e)
3640                                                         + 2);   /* '}' +  NUL */
3641                                     Copy(hex_string, d, output_length, char);
3642                                     d += output_length;
3643                                 }
3644                             }
3645
3646                             *d++ = '}'; /* Done.  Add the trailing brace */
3647                         }
3648                     }
3649                     else { /* Here, not in a pattern.  Convert the name to a
3650                             * string. */
3651
3652                         if (PL_lex_inwhat == OP_TRANS) {
3653                             str = SvPV_const(res, len);
3654                             if (len > ((SvUTF8(res))
3655                                        ? UTF8SKIP(str)
3656                                        : 1U))
3657                             {
3658                                 yyerror(Perl_form(aTHX_
3659                                     "%.*s must not be a named sequence"
3660                                     " in transliteration operator",
3661                                         /*  +1 to include the "}" */
3662                                     (int) (e + 1 - start), start));
3663                                 goto end_backslash_N;
3664                             }
3665                         }
3666                         else if (! SvUTF8(res)) {
3667                             /* Make sure \N{} return is UTF-8.  This is because
3668                             * \N{} implies Unicode semantics, and scalars have to
3669                             * be in utf8 to guarantee those semantics; but not
3670                             * needed in tr/// */
3671                             sv_utf8_upgrade_flags(res, SV_UTF8_NO_ENCODING);
3672                             str = SvPV_const(res, len);
3673                         }
3674
3675                          /* Upgrade destination to be utf8 if this new
3676                           * component is */
3677                         if (! has_utf8 && SvUTF8(res)) {
3678                             SvCUR_set(sv, d - SvPVX_const(sv));
3679                             SvPOK_on(sv);
3680                             *d = '\0';
3681                             /* See Note on sizing above.  */
3682                             sv_utf8_upgrade_flags_grow(sv,
3683                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3684                                                 len + (STRLEN)(send - s) + 1);
3685                             d = SvPVX(sv) + SvCUR(sv);
3686                             has_utf8 = TRUE;
3687                         } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3688
3689                             /* See Note on sizing above.  (NOTE: SvCUR() is not
3690                              * set correctly here). */
3691                             const STRLEN off = d - SvPVX_const(sv);
3692                             d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3693                         }
3694                         Copy(str, d, len, char);
3695                         d += len;
3696                     }
3697
3698                     SvREFCNT_dec(res);
3699
3700                 } /* End \N{NAME} */
3701
3702               end_backslash_N:
3703 #ifdef EBCDIC
3704                 backslash_N++; /* \N{} is defined to be Unicode */
3705 #endif
3706                 s = e + 1;  /* Point to just after the '}' */
3707                 continue;
3708
3709             /* \c is a control character */
3710             case 'c':
3711                 s++;
3712                 if (s < send) {
3713                     *d++ = grok_bslash_c(*s++, 1);
3714                 }
3715                 else {
3716                     yyerror("Missing control char name in \\c");
3717                 }
3718 #ifdef EBCDIC
3719                 non_portable_endpoint++;
3720 #endif
3721                 continue;
3722
3723             /* printf-style backslashes, formfeeds, newlines, etc */
3724             case 'b':
3725                 *d++ = '\b';
3726                 break;
3727             case 'n':
3728                 *d++ = '\n';
3729                 break;
3730             case 'r':
3731                 *d++ = '\r';
3732                 break;
3733             case 'f':
3734                 *d++ = '\f';
3735                 break;
3736             case 't':
3737                 *d++ = '\t';
3738                 break;
3739             case 'e':
3740                 *d++ = ESC_NATIVE;
3741                 break;
3742             case 'a':
3743                 *d++ = '\a';
3744                 break;
3745             } /* end switch */
3746
3747             s++;
3748             continue;
3749         } /* end if (backslash) */
3750
3751     default_action:
3752         /* If we started with encoded form, or already know we want it,
3753            then encode the next character */
3754         if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3755             STRLEN len  = 1;
3756
3757             /* One might think that it is wasted effort in the case of the
3758              * source being utf8 (this_utf8 == TRUE) to take the next character
3759              * in the source, convert it to an unsigned value, and then convert
3760              * it back again.  But the source has not been validated here.  The
3761              * routine that does the conversion checks for errors like
3762              * malformed utf8 */
3763
3764             const UV nextuv   = (this_utf8)
3765                                 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3766                                 : (UV) ((U8) *s);
3767             const STRLEN need = UVCHR_SKIP(nextuv);
3768             if (!has_utf8) {
3769                 SvCUR_set(sv, d - SvPVX_const(sv));
3770                 SvPOK_on(sv);
3771                 *d = '\0';
3772                 /* See Note on sizing above.  */
3773                 sv_utf8_upgrade_flags_grow(sv,
3774                                         SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3775                                         need + (STRLEN)(send - s) + 1);
3776                 d = SvPVX(sv) + SvCUR(sv);
3777                 has_utf8 = TRUE;
3778             } else if (need > len) {
3779                 /* encoded value larger than old, may need extra space (NOTE:
3780                  * SvCUR() is not set correctly here).   See Note on sizing
3781                  * above.  */
3782                 const STRLEN off = d - SvPVX_const(sv);
3783                 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3784             }
3785             s += len;
3786
3787             d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3788         }
3789         else {
3790             *d++ = *s++;
3791         }
3792     } /* while loop to process each character */
3793
3794     /* terminate the string and set up the sv */
3795     *d = '\0';
3796     SvCUR_set(sv, d - SvPVX_const(sv));
3797     if (SvCUR(sv) >= SvLEN(sv))
3798         Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3799                    " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3800
3801     SvPOK_on(sv);
3802     if (has_utf8) {
3803         SvUTF8_on(sv);
3804         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3805             PL_sublex_info.sub_op->op_private |=
3806                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3807         }
3808     }
3809
3810     /* shrink the sv if we allocated more than we used */
3811     if (SvCUR(sv) + 5 < SvLEN(sv)) {
3812         SvPV_shrink_to_cur(sv);
3813     }
3814
3815     /* return the substring (via pl_yylval) only if we parsed anything */
3816     if (s > start) {
3817         char *s2 = start;
3818         for (; s2 < s; s2++) {
3819             if (*s2 == '\n')
3820                 COPLINE_INC_WITH_HERELINES;
3821         }
3822         SvREFCNT_inc_simple_void_NN(sv);
3823         if (   (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3824             && ! PL_parser->lex_re_reparsing)
3825         {
3826             const char *const key = PL_lex_inpat ? "qr" : "q";
3827             const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3828             const char *type;
3829             STRLEN typelen;
3830
3831             if (PL_lex_inwhat == OP_TRANS) {
3832                 type = "tr";
3833                 typelen = 2;
3834             } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3835                 type = "s";
3836                 typelen = 1;
3837             } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3838                 type = "q";
3839                 typelen = 1;
3840             } else  {
3841                 type = "qq";
3842                 typelen = 2;
3843             }
3844
3845             sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3846                                 type, typelen);
3847         }
3848         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3849     }
3850     LEAVE_with_name("scan_const");
3851     return s;
3852 }
3853
3854 /* S_intuit_more
3855  * Returns TRUE if there's more to the expression (e.g., a subscript),
3856  * FALSE otherwise.
3857  *
3858  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3859  *
3860  * ->[ and ->{ return TRUE
3861  * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
3862  * { and [ outside a pattern are always subscripts, so return TRUE
3863  * if we're outside a pattern and it's not { or [, then return FALSE
3864  * if we're in a pattern and the first char is a {
3865  *   {4,5} (any digits around the comma) returns FALSE
3866  * if we're in a pattern and the first char is a [
3867  *   [] returns FALSE
3868  *   [SOMETHING] has a funky algorithm to decide whether it's a
3869  *      character class or not.  It has to deal with things like
3870  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3871  * anything else returns TRUE
3872  */
3873
3874 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3875
3876 STATIC int
3877 S_intuit_more(pTHX_ char *s)
3878 {
3879     PERL_ARGS_ASSERT_INTUIT_MORE;
3880
3881     if (PL_lex_brackets)
3882         return TRUE;
3883     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3884         return TRUE;
3885     if (*s == '-' && s[1] == '>'
3886      && FEATURE_POSTDEREF_QQ_IS_ENABLED
3887      && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
3888         ||(s[2] == '@' && strchr("*[{",s[3])) ))
3889         return TRUE;
3890     if (*s != '{' && *s != '[')
3891         return FALSE;
3892     if (!PL_lex_inpat)
3893         return TRUE;
3894
3895     /* In a pattern, so maybe we have {n,m}. */
3896     if (*s == '{') {
3897         if (regcurly(s)) {
3898             return FALSE;
3899         }
3900         return TRUE;
3901     }
3902
3903     /* On the other hand, maybe we have a character class */
3904
3905     s++;
3906     if (*s == ']' || *s == '^')
3907         return FALSE;
3908     else {
3909         /* this is terrifying, and it works */
3910         int weight;
3911         char seen[256];
3912         const char * const send = strchr(s,']');
3913         unsigned char un_char, last_un_char;
3914         char tmpbuf[sizeof PL_tokenbuf * 4];
3915
3916         if (!send)              /* has to be an expression */
3917             return TRUE;
3918         weight = 2;             /* let's weigh the evidence */
3919
3920         if (*s == '$')
3921             weight -= 3;
3922         else if (isDIGIT(*s)) {
3923             if (s[1] != ']') {
3924                 if (isDIGIT(s[1]) && s[2] == ']')
3925                     weight -= 10;
3926             }
3927             else
3928                 weight -= 100;
3929         }
3930         Zero(seen,256,char);
3931         un_char = 255;
3932         for (; s < send; s++) {
3933             last_un_char = un_char;
3934             un_char = (unsigned char)*s;
3935             switch (*s) {
3936             case '@':
3937             case '&':
3938             case '$':
3939                 weight -= seen[un_char] * 10;
3940                 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3941                     int len;
3942                     char *tmp = PL_bufend;
3943                     PL_bufend = (char*)send;
3944                     scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
3945                     PL_bufend = tmp;
3946                     len = (int)strlen(tmpbuf);
3947                     if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3948                                                     UTF ? SVf_UTF8 : 0, SVt_PV))
3949                         weight -= 100;
3950                     else
3951                         weight -= 10;
3952                 }
3953                 else if (*s == '$'
3954                          && s[1]
3955                          && strchr("[#!%*<>()-=",s[1]))
3956                 {
3957                     if (/*{*/ strchr("])} =",s[2]))
3958                         weight -= 10;
3959                     else
3960                         weight -= 1;
3961                 }
3962                 break;
3963             case '\\':
3964                 un_char = 254;
3965                 if (s[1]) {
3966                     if (strchr("wds]",s[1]))
3967                         weight += 100;
3968                     else if (seen[(U8)'\''] || seen[(U8)'"'])
3969                         weight += 1;
3970                     else if (strchr("rnftbxcav",s[1]))
3971                         weight += 40;
3972                     else if (isDIGIT(s[1])) {
3973                         weight += 40;
3974                         while (s[1] && isDIGIT(s[1]))
3975                             s++;
3976                     }
3977                 }
3978                 else
3979                     weight += 100;
3980                 break;
3981             case '-':
3982                 if (s[1] == '\\')
3983                     weight += 50;
3984                 if (strchr("aA01! ",last_un_char))
3985                     weight += 30;
3986                 if (strchr("zZ79~",s[1]))
3987                     weight += 30;
3988                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3989                     weight -= 5;        /* cope with negative subscript */
3990                 break;
3991             default:
3992                 if (!isWORDCHAR(last_un_char)
3993                     && !(last_un_char == '$' || last_un_char == '@'
3994                          || last_un_char == '&')
3995                     && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3996                     char *d = s;
3997                     while (isALPHA(*s))
3998                         s++;
3999                     if (keyword(d, s - d, 0))
4000                         weight -= 150;
4001                 }
4002                 if (un_char == last_un_char + 1)
4003                     weight += 5;
4004                 weight -= seen[un_char];
4005                 break;
4006             }
4007             seen[un_char]++;
4008         }
4009         if (weight >= 0)        /* probably a character class */
4010             return FALSE;
4011     }
4012
4013     return TRUE;
4014 }
4015
4016 /*
4017  * S_intuit_method
4018  *
4019  * Does all the checking to disambiguate
4020  *   foo bar
4021  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
4022  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4023  *
4024  * First argument is the stuff after the first token, e.g. "bar".
4025  *
4026  * Not a method if foo is a filehandle.
4027  * Not a method if foo is a subroutine prototyped to take a filehandle.
4028  * Not a method if it's really "Foo $bar"
4029  * Method if it's "foo $bar"
4030  * Not a method if it's really "print foo $bar"
4031  * Method if it's really "foo package::" (interpreted as package->foo)
4032  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4033  * Not a method if bar is a filehandle or package, but is quoted with
4034  *   =>
4035  */
4036
4037 STATIC int
4038 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
4039 {
4040     char *s = start + (*start == '$');
4041     char tmpbuf[sizeof PL_tokenbuf];
4042     STRLEN len;
4043     GV* indirgv;
4044         /* Mustn't actually add anything to a symbol table.
4045            But also don't want to "initialise" any placeholder
4046            constants that might already be there into full
4047            blown PVGVs with attached PVCV.  */
4048     GV * const gv =
4049         ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
4050
4051     PERL_ARGS_ASSERT_INTUIT_METHOD;
4052
4053     if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4054             return 0;
4055     if (cv && SvPOK(cv)) {
4056         const char *proto = CvPROTO(cv);
4057         if (proto) {
4058             while (*proto && (isSPACE(*proto) || *proto == ';'))
4059                 proto++;
4060             if (*proto == '*')
4061                 return 0;
4062         }
4063     }
4064
4065     if (*start == '$') {
4066         if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY
4067             || isUPPER(*PL_tokenbuf))
4068             return 0;
4069         s = skipspace(s);
4070         PL_bufptr = start;
4071         PL_expect = XREF;
4072         return *s == '(' ? FUNCMETH : METHOD;
4073     }
4074
4075     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4076     /* start is the beginning of the possible filehandle/object,
4077      * and s is the end of it
4078      * tmpbuf is a copy of it (but with single quotes as double colons)
4079      */
4080
4081     if (!keyword(tmpbuf, len, 0)) {
4082         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4083             len -= 2;
4084             tmpbuf[len] = '\0';
4085             goto bare_package;
4086         }
4087         indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
4088         if (indirgv && GvCVu(indirgv))
4089             return 0;
4090         /* filehandle or package name makes it a method */
4091         if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4092             s = skipspace(s);
4093             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4094                 return 0;       /* no assumptions -- "=>" quotes bareword */
4095       bare_package:
4096             NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
4097                                                   S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4098             NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4099             PL_expect = XTERM;
4100             force_next(BAREWORD);
4101             PL_bufptr = s;
4102             return *s == '(' ? FUNCMETH : METHOD;
4103         }
4104     }
4105     return 0;
4106 }
4107
4108 /* Encoded script support. filter_add() effectively inserts a
4109  * 'pre-processing' function into the current source input stream.
4110  * Note that the filter function only applies to the current source file
4111  * (e.g., it will not affect files 'require'd or 'use'd by this one).
4112  *
4113  * The datasv parameter (which may be NULL) can be used to pass
4114  * private data to this instance of the filter. The filter function
4115  * can recover the SV using the FILTER_DATA macro and use it to
4116  * store private buffers and state information.
4117  *
4118  * The supplied datasv parameter is upgraded to a PVIO type
4119  * and the IoDIRP/IoANY field is used to store the function pointer,
4120  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4121  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4122  * private use must be set using malloc'd pointers.
4123  */
4124
4125 SV *
4126 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4127 {
4128     if (!funcp)
4129         return NULL;
4130
4131     if (!PL_parser)
4132         return NULL;
4133
4134     if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4135         Perl_croak(aTHX_ "Source filters apply only to byte streams");
4136
4137     if (!PL_rsfp_filters)
4138         PL_rsfp_filters = newAV();
4139     if (!datasv)
4140         datasv = newSV(0);
4141     SvUPGRADE(datasv, SVt_PVIO);
4142     IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4143     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4144     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4145                           FPTR2DPTR(void *, IoANY(datasv)),
4146                           SvPV_nolen(datasv)));
4147     av_unshift(PL_rsfp_filters, 1);
4148     av_store(PL_rsfp_filters, 0, datasv) ;
4149     if (
4150         !PL_parser->filtered
4151      && PL_parser->lex_flags & LEX_EVALBYTES
4152      && PL_bufptr < PL_bufend
4153     ) {
4154         const char *s = PL_bufptr;
4155         while (s < PL_bufend) {
4156             if (*s == '\n') {
4157                 SV *linestr = PL_parser->linestr;
4158                 char *buf = SvPVX(linestr);
4159                 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4160                 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4161                 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4162                 STRLEN const linestart_pos = PL_parser->linestart - buf;
4163                 STRLEN const last_uni_pos =
4164                     PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4165                 STRLEN const last_lop_pos =
4166                     PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4167                 av_push(PL_rsfp_filters, linestr);
4168                 PL_parser->linestr = 
4169                     newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4170                 buf = SvPVX(PL_parser->linestr);
4171                 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4172                 PL_parser->bufptr = buf + bufptr_pos;
4173                 PL_parser->oldbufptr = buf + oldbufptr_pos;
4174                 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4175                 PL_parser->linestart = buf + linestart_pos;
4176                 if (PL_parser->last_uni)
4177                     PL_parser->last_uni = buf + last_uni_pos;
4178                 if (PL_parser->last_lop)
4179                     PL_parser->last_lop = buf + last_lop_pos;
4180                 SvLEN(linestr) = SvCUR(linestr);
4181                 SvCUR(linestr) = s-SvPVX(linestr);
4182                 PL_parser->filtered = 1;
4183                 break;
4184             }
4185             s++;
4186         }
4187     }
4188     return(datasv);
4189 }
4190
4191
4192 /* Delete most recently added instance of this filter function. */
4193 void
4194 Perl_filter_del(pTHX_ filter_t funcp)
4195 {
4196     SV *datasv;
4197
4198     PERL_ARGS_ASSERT_FILTER_DEL;
4199
4200 #ifdef DEBUGGING
4201     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4202                           FPTR2DPTR(void*, funcp)));
4203 #endif
4204     if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4205         return;
4206     /* if filter is on top of stack (usual case) just pop it off */
4207     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4208     if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4209         sv_free(av_pop(PL_rsfp_filters));
4210
4211         return;
4212     }
4213     /* we need to search for the correct entry and clear it     */
4214     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4215 }
4216
4217
4218 /* Invoke the idxth filter function for the current rsfp.        */
4219 /* maxlen 0 = read one text line */
4220 I32
4221 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4222 {
4223     filter_t funcp;
4224     SV *datasv = NULL;
4225     /* This API is bad. It should have been using unsigned int for maxlen.
4226        Not sure if we want to change the API, but if not we should sanity
4227        check the value here.  */
4228     unsigned int correct_length = maxlen < 0 ?  PERL_INT_MAX : maxlen;
4229
4230     PERL_ARGS_ASSERT_FILTER_READ;
4231
4232     if (!PL_parser || !PL_rsfp_filters)
4233         return -1;
4234     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
4235         /* Provide a default input filter to make life easy.    */
4236         /* Note that we append to the line. This is handy.      */
4237         DEBUG_P(PerlIO_printf(Perl_debug_log,
4238                               "filter_read %d: from rsfp\n", idx));
4239         if (correct_length) {
4240             /* Want a block */
4241             int len ;
4242             const int old_len = SvCUR(buf_sv);
4243
4244             /* ensure buf_sv is large enough */
4245             SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4246             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4247                                    correct_length)) <= 0) {
4248                 if (PerlIO_error(PL_rsfp))
4249                     return -1;          /* error */
4250                 else
4251                     return 0 ;          /* end of file */
4252             }
4253             SvCUR_set(buf_sv, old_len + len) ;
4254             SvPVX(buf_sv)[old_len + len] = '\0';
4255         } else {
4256             /* Want a line */
4257             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4258                 if (PerlIO_error(PL_rsfp))
4259                     return -1;          /* error */
4260                 else
4261                     return 0 ;          /* end of file */
4262             }
4263         }
4264         return SvCUR(buf_sv);
4265     }
4266     /* Skip this filter slot if filter has been deleted */
4267     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4268         DEBUG_P(PerlIO_printf(Perl_debug_log,
4269                               "filter_read %d: skipped (filter deleted)\n",
4270                               idx));
4271         return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4272     }
4273     if (SvTYPE(datasv) != SVt_PVIO) {
4274         if (correct_length) {
4275             /* Want a block */
4276             const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4277             if (!remainder) return 0; /* eof */
4278             if (correct_length > remainder) correct_length = remainder;
4279             sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4280             SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4281         } else {
4282             /* Want a line */
4283             const char *s = SvEND(datasv);
4284             const char *send = SvPVX(datasv) + SvLEN(datasv);
4285             while (s < send) {
4286                 if (*s == '\n') {
4287                     s++;
4288                     break;
4289                 }
4290                 s++;
4291             }
4292             if (s == send) return 0; /* eof */
4293             sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4294             SvCUR_set(datasv, s-SvPVX(datasv));
4295         }
4296         return SvCUR(buf_sv);
4297     }
4298     /* Get function pointer hidden within datasv        */
4299     funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4300     DEBUG_P(PerlIO_printf(Perl_debug_log,
4301                           "filter_read %d: via function %p (%s)\n",
4302                           idx, (void*)datasv, SvPV_nolen_const(datasv)));
4303     /* Call function. The function is expected to       */
4304     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
4305     /* Return: <0:error, =0:eof, >0:not eof             */
4306     return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4307 }
4308
4309 STATIC char *
4310 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4311 {
4312     PERL_ARGS_ASSERT_FILTER_GETS;
4313
4314 #ifdef PERL_CR_FILTER
4315     if (!PL_rsfp_filters) {
4316         filter_add(S_cr_textfilter,NULL);
4317     }
4318 #endif
4319     if (PL_rsfp_filters) {
4320         if (!append)
4321             SvCUR_set(sv, 0);   /* start with empty line        */
4322         if (FILTER_READ(0, sv, 0) > 0)
4323             return ( SvPVX(sv) ) ;
4324         else
4325             return NULL ;
4326     }
4327     else
4328         return (sv_gets(sv, PL_rsfp, append));
4329 }
4330
4331 STATIC HV *
4332 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4333 {
4334     GV *gv;
4335