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