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