This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
toke.c: Remove redundant PL_lex_stuff null checks
[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     /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2372        set for an inner quote-like operator and then an error causes scope-
2373        popping.  We must not have a PL_lex_stuff value left dangling, as
2374        that breaks assumptions elsewhere.  See bug #123617.  */
2375     SAVEGENERICSV(PL_lex_stuff);
2376
2377     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2378         = SvPVX(PL_linestr);
2379     PL_bufend += SvCUR(PL_linestr);
2380     PL_last_lop = PL_last_uni = NULL;
2381     SAVEFREESV(PL_linestr);
2382     if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2383
2384     PL_lex_dojoin = FALSE;
2385     PL_lex_brackets = PL_lex_formbrack = 0;
2386     PL_lex_allbrackets = 0;
2387     PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2388     Newx(PL_lex_brackstack, 120, char);
2389     Newx(PL_lex_casestack, 12, char);
2390     PL_lex_casemods = 0;
2391     *PL_lex_casestack = '\0';
2392     PL_lex_starts = 0;
2393     PL_lex_state = LEX_INTERPCONCAT;
2394     if (is_heredoc)
2395         CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2396     PL_copline = NOLINE;
2397     
2398     Newxz(shared, 1, LEXSHARED);
2399     shared->ls_prev = PL_parser->lex_shared;
2400     PL_parser->lex_shared = shared;
2401
2402     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2403     if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2404     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2405         PL_lex_inpat = PL_sublex_info.sub_op;
2406     else
2407         PL_lex_inpat = NULL;
2408
2409     PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2410     PL_in_eval &= ~EVAL_RE_REPARSING;
2411
2412     return '(';
2413 }
2414
2415 /*
2416  * S_sublex_done
2417  * Restores lexer state after a S_sublex_push.
2418  */
2419
2420 STATIC I32
2421 S_sublex_done(pTHX)
2422 {
2423     if (!PL_lex_starts++) {
2424         SV * const sv = newSVpvs("");
2425         if (SvUTF8(PL_linestr))
2426             SvUTF8_on(sv);
2427         PL_expect = XOPERATOR;
2428         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2429         return THING;
2430     }
2431
2432     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
2433         PL_lex_state = LEX_INTERPCASEMOD;
2434         return yylex();
2435     }
2436
2437     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2438     assert(PL_lex_inwhat != OP_TRANSR);
2439     if (PL_lex_repl) {
2440         assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2441         PL_linestr = PL_lex_repl;
2442         PL_lex_inpat = 0;
2443         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2444         PL_bufend += SvCUR(PL_linestr);
2445         PL_last_lop = PL_last_uni = NULL;
2446         PL_lex_dojoin = FALSE;
2447         PL_lex_brackets = 0;
2448         PL_lex_allbrackets = 0;
2449         PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2450         PL_lex_casemods = 0;
2451         *PL_lex_casestack = '\0';
2452         PL_lex_starts = 0;
2453         if (SvEVALED(PL_lex_repl)) {
2454             PL_lex_state = LEX_INTERPNORMAL;
2455             PL_lex_starts++;
2456             /*  we don't clear PL_lex_repl here, so that we can check later
2457                 whether this is an evalled subst; that means we rely on the
2458                 logic to ensure sublex_done() is called again only via the
2459                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2460         }
2461         else {
2462             PL_lex_state = LEX_INTERPCONCAT;
2463             PL_lex_repl = NULL;
2464         }
2465         if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2466             CopLINE(PL_curcop) +=
2467                 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
2468                  + PL_parser->herelines;
2469             PL_parser->herelines = 0;
2470         }
2471         return '/';
2472     }
2473     else {
2474         const line_t l = CopLINE(PL_curcop);
2475         LEAVE;
2476         if (PL_multi_close == '<')
2477             PL_parser->herelines += l - PL_multi_end;
2478         PL_bufend = SvPVX(PL_linestr);
2479         PL_bufend += SvCUR(PL_linestr);
2480         PL_expect = XOPERATOR;
2481         PL_sublex_info.sub_inwhat = 0;
2482         return ')';
2483     }
2484 }
2485
2486 PERL_STATIC_INLINE SV*
2487 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2488 {
2489     /* <s> points to first character of interior of \N{}, <e> to one beyond the
2490      * interior, hence to the "}".  Finds what the name resolves to, returning
2491      * an SV* containing it; NULL if no valid one found */
2492
2493     SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2494
2495     HV * table;
2496     SV **cvp;
2497     SV *cv;
2498     SV *rv;
2499     HV *stash;
2500     const U8* first_bad_char_loc;
2501     const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2502
2503     PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2504
2505     if (!SvCUR(res))
2506         return res;
2507
2508     if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2509                                      e - backslash_ptr,
2510                                      &first_bad_char_loc))
2511     {
2512         /* If warnings are on, this will print a more detailed analysis of what
2513          * is wrong than the error message below */
2514         utf8n_to_uvchr(first_bad_char_loc,
2515                        e - ((char *) first_bad_char_loc),
2516                        NULL, 0);
2517
2518         /* We deliberately don't try to print the malformed character, which
2519          * might not print very well; it also may be just the first of many
2520          * malformations, so don't print what comes after it */
2521         yyerror(Perl_form(aTHX_
2522             "Malformed UTF-8 character immediately after '%.*s'",
2523             (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2524         return NULL;
2525     }
2526
2527     res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2528                         /* include the <}> */
2529                         e - backslash_ptr + 1);
2530     if (! SvPOK(res)) {
2531         SvREFCNT_dec_NN(res);
2532         return NULL;
2533     }
2534
2535     /* See if the charnames handler is the Perl core's, and if so, we can skip
2536      * the validation needed for a user-supplied one, as Perl's does its own
2537      * validation. */
2538     table = GvHV(PL_hintgv);             /* ^H */
2539     cvp = hv_fetchs(table, "charnames", FALSE);
2540     if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2541         SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2542     {
2543         const char * const name = HvNAME(stash);
2544         if (HvNAMELEN(stash) == sizeof("_charnames")-1
2545          && strEQ(name, "_charnames")) {
2546            return res;
2547        }
2548     }
2549
2550     /* Here, it isn't Perl's charname handler.  We can't rely on a
2551      * user-supplied handler to validate the input name.  For non-ut8 input,
2552      * look to see that the first character is legal.  Then loop through the
2553      * rest checking that each is a continuation */
2554
2555     /* This code makes the reasonable assumption that the only Latin1-range
2556      * characters that begin a character name alias are alphabetic, otherwise
2557      * would have to create a isCHARNAME_BEGIN macro */
2558
2559     if (! UTF) {
2560         if (! isALPHAU(*s)) {
2561             goto bad_charname;
2562         }
2563         s++;
2564         while (s < e) {
2565             if (! isCHARNAME_CONT(*s)) {
2566                 goto bad_charname;
2567             }
2568             if (*s == ' ' && *(s-1) == ' ') {
2569                 goto multi_spaces;
2570             }
2571             if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) {
2572                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2573                            "NO-BREAK SPACE in a charnames "
2574                            "alias definition is deprecated");
2575             }
2576             s++;
2577         }
2578     }
2579     else {
2580         /* Similarly for utf8.  For invariants can check directly; for other
2581          * Latin1, can calculate their code point and check; otherwise  use a
2582          * swash */
2583         if (UTF8_IS_INVARIANT(*s)) {
2584             if (! isALPHAU(*s)) {
2585                 goto bad_charname;
2586             }
2587             s++;
2588         } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2589             if (! isALPHAU(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)))) {
2590                 goto bad_charname;
2591             }
2592             s += 2;
2593         }
2594         else {
2595             if (! PL_utf8_charname_begin) {
2596                 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2597                 PL_utf8_charname_begin = _core_swash_init("utf8",
2598                                                         "_Perl_Charname_Begin",
2599                                                         &PL_sv_undef,
2600                                                         1, 0, NULL, &flags);
2601             }
2602             if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2603                 goto bad_charname;
2604             }
2605             s += UTF8SKIP(s);
2606         }
2607
2608         while (s < e) {
2609             if (UTF8_IS_INVARIANT(*s)) {
2610                 if (! isCHARNAME_CONT(*s)) {
2611                     goto bad_charname;
2612                 }
2613                 if (*s == ' ' && *(s-1) == ' ') {
2614                     goto multi_spaces;
2615                 }
2616                 s++;
2617             }
2618             else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2619                 if (! isCHARNAME_CONT(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1))))
2620                 {
2621                     goto bad_charname;
2622                 }
2623                 if (*s == *NBSP_UTF8
2624                     && *(s+1) == *(NBSP_UTF8+1)
2625                     && ckWARN_d(WARN_DEPRECATED))
2626                 {
2627                     Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2628                                 "NO-BREAK SPACE in a charnames "
2629                                 "alias definition is deprecated");
2630                 }
2631                 s += 2;
2632             }
2633             else {
2634                 if (! PL_utf8_charname_continue) {
2635                     U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2636                     PL_utf8_charname_continue = _core_swash_init("utf8",
2637                                                 "_Perl_Charname_Continue",
2638                                                 &PL_sv_undef,
2639                                                 1, 0, NULL, &flags);
2640                 }
2641                 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2642                     goto bad_charname;
2643                 }
2644                 s += UTF8SKIP(s);
2645             }
2646         }
2647     }
2648     if (*(s-1) == ' ') {
2649         yyerror_pv(
2650             Perl_form(aTHX_
2651             "charnames alias definitions may not contain trailing "
2652             "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2653             (int)(s - backslash_ptr + 1), backslash_ptr,
2654             (int)(e - s + 1), s + 1
2655             ),
2656         UTF ? SVf_UTF8 : 0);
2657         return NULL;
2658     }
2659
2660     if (SvUTF8(res)) { /* Don't accept malformed input */
2661         const U8* first_bad_char_loc;
2662         STRLEN len;
2663         const char* const str = SvPV_const(res, len);
2664         if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2665             /* If warnings are on, this will print a more detailed analysis of
2666              * what is wrong than the error message below */
2667             utf8n_to_uvchr(first_bad_char_loc,
2668                            (char *) first_bad_char_loc - str,
2669                            NULL, 0);
2670
2671             /* We deliberately don't try to print the malformed character,
2672              * which might not print very well; it also may be just the first
2673              * of many malformations, so don't print what comes after it */
2674             yyerror_pv(
2675               Perl_form(aTHX_
2676                 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2677                  (int) (e - backslash_ptr + 1), backslash_ptr,
2678                  (int) ((char *) first_bad_char_loc - str), str
2679               ),
2680               SVf_UTF8);
2681             return NULL;
2682         }
2683     }
2684
2685     return res;
2686
2687   bad_charname: {
2688
2689         /* The final %.*s makes sure that should the trailing NUL be missing
2690          * that this print won't run off the end of the string */
2691         yyerror_pv(
2692           Perl_form(aTHX_
2693             "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2694             (int)(s - backslash_ptr + 1), backslash_ptr,
2695             (int)(e - s + 1), s + 1
2696           ),
2697           UTF ? SVf_UTF8 : 0);
2698         return NULL;
2699     }
2700
2701   multi_spaces:
2702         yyerror_pv(
2703           Perl_form(aTHX_
2704             "charnames alias definitions may not contain a sequence of "
2705             "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2706             (int)(s - backslash_ptr + 1), backslash_ptr,
2707             (int)(e - s + 1), s + 1
2708           ),
2709           UTF ? SVf_UTF8 : 0);
2710         return NULL;
2711 }
2712
2713 /*
2714   scan_const
2715
2716   Extracts the next constant part of a pattern, double-quoted string,
2717   or transliteration.  This is terrifying code.
2718
2719   For example, in parsing the double-quoted string "ab\x63$d", it would
2720   stop at the '$' and return an OP_CONST containing 'abc'.
2721
2722   It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2723   processing a pattern (PL_lex_inpat is true), a transliteration
2724   (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2725
2726   Returns a pointer to the character scanned up to. If this is
2727   advanced from the start pointer supplied (i.e. if anything was
2728   successfully parsed), will leave an OP_CONST for the substring scanned
2729   in pl_yylval. Caller must intuit reason for not parsing further
2730   by looking at the next characters herself.
2731
2732   In patterns:
2733     expand:
2734       \N{FOO}  => \N{U+hex_for_character_FOO}
2735       (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2736
2737     pass through:
2738         all other \-char, including \N and \N{ apart from \N{ABC}
2739
2740     stops on:
2741         @ and $ where it appears to be a var, but not for $ as tail anchor
2742         \l \L \u \U \Q \E
2743         (?{  or  (??{
2744
2745
2746   In transliterations:
2747     characters are VERY literal, except for - not at the start or end
2748     of the string, which indicates a range. If the range is in bytes,
2749     scan_const expands the range to the full set of intermediate
2750     characters. If the range is in utf8, the hyphen is replaced with
2751     a certain range mark which will be handled by pmtrans() in op.c.
2752
2753   In double-quoted strings:
2754     backslashes:
2755       double-quoted style: \r and \n
2756       constants: \x31, etc.
2757       deprecated backrefs: \1 (in substitution replacements)
2758       case and quoting: \U \Q \E
2759     stops on @ and $
2760
2761   scan_const does *not* construct ops to handle interpolated strings.
2762   It stops processing as soon as it finds an embedded $ or @ variable
2763   and leaves it to the caller to work out what's going on.
2764
2765   embedded arrays (whether in pattern or not) could be:
2766       @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2767
2768   $ in double-quoted strings must be the symbol of an embedded scalar.
2769
2770   $ in pattern could be $foo or could be tail anchor.  Assumption:
2771   it's a tail anchor if $ is the last thing in the string, or if it's
2772   followed by one of "()| \r\n\t"
2773
2774   \1 (backreferences) are turned into $1 in substitutions
2775
2776   The structure of the code is
2777       while (there's a character to process) {
2778           handle transliteration ranges
2779           skip regexp comments /(?#comment)/ and codes /(?{code})/
2780           skip #-initiated comments in //x patterns
2781           check for embedded arrays
2782           check for embedded scalars
2783           if (backslash) {
2784               deprecate \1 in substitution replacements
2785               handle string-changing backslashes \l \U \Q \E, etc.
2786               switch (what was escaped) {
2787                   handle \- in a transliteration (becomes a literal -)
2788                   if a pattern and not \N{, go treat as regular character
2789                   handle \132 (octal characters)
2790                   handle \x15 and \x{1234} (hex characters)
2791                   handle \N{name} (named characters, also \N{3,5} in a pattern)
2792                   handle \cV (control characters)
2793                   handle printf-style backslashes (\f, \r, \n, etc)
2794               } (end switch)
2795               continue
2796           } (end if backslash)
2797           handle regular character
2798     } (end while character to read)
2799                 
2800 */
2801
2802 STATIC char *
2803 S_scan_const(pTHX_ char *start)
2804 {
2805     char *send = PL_bufend;             /* end of the constant */
2806     SV *sv = newSV(send - start);       /* sv for the constant.  See note below
2807                                            on sizing. */
2808     char *s = start;                    /* start of the constant */
2809     char *d = SvPVX(sv);                /* destination for copies */
2810     bool dorange = FALSE;               /* are we in a translit range? */
2811     bool didrange = FALSE;              /* did we just finish a range? */
2812     bool in_charclass = FALSE;          /* within /[...]/ */
2813     bool has_utf8 = FALSE;              /* Output constant is UTF8 */
2814     bool  this_utf8 = cBOOL(UTF);       /* Is the source string assumed to be
2815                                            UTF8?  But, this can show as true
2816                                            when the source isn't utf8, as for
2817                                            example when it is entirely composed
2818                                            of hex constants */
2819     SV *res;                            /* result from charnames */
2820
2821     /* Note on sizing:  The scanned constant is placed into sv, which is
2822      * initialized by newSV() assuming one byte of output for every byte of
2823      * input.  This routine expects newSV() to allocate an extra byte for a
2824      * trailing NUL, which this routine will append if it gets to the end of
2825      * the input.  There may be more bytes of input than output (eg., \N{LATIN
2826      * CAPITAL LETTER A}), or more output than input if the constant ends up
2827      * recoded to utf8, but each time a construct is found that might increase
2828      * the needed size, SvGROW() is called.  Its size parameter each time is
2829      * based on the best guess estimate at the time, namely the length used so
2830      * far, plus the length the current construct will occupy, plus room for
2831      * the trailing NUL, plus one byte for every input byte still unscanned */ 
2832
2833     UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2834                        before set */
2835 #ifdef EBCDIC
2836     UV literal_endpoint = 0;
2837     bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2838 #endif
2839
2840     PERL_ARGS_ASSERT_SCAN_CONST;
2841
2842     assert(PL_lex_inwhat != OP_TRANSR);
2843     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2844         /* If we are doing a trans and we know we want UTF8 set expectation */
2845         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2846         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2847     }
2848
2849     /* Protect sv from errors and fatal warnings. */
2850     ENTER_with_name("scan_const");
2851     SAVEFREESV(sv);
2852
2853     while (s < send || dorange) {
2854
2855         /* get transliterations out of the way (they're most literal) */
2856         if (PL_lex_inwhat == OP_TRANS) {
2857             /* expand a range A-Z to the full set of characters.  AIE! */
2858             if (dorange) {
2859                 I32 i;                          /* current expanded character */
2860                 I32 min;                        /* first character in range */
2861                 I32 max;                        /* last character in range */
2862
2863 #ifdef EBCDIC
2864                 UV uvmax = 0;
2865 #endif
2866
2867                 if (has_utf8
2868 #ifdef EBCDIC
2869                     && !native_range
2870 #endif
2871                 ) {
2872                     char * const c = (char*)utf8_hop((U8*)d, -1);
2873                     char *e = d++;
2874                     while (e-- > c)
2875                         *(e + 1) = *e;
2876                     *c = (char) ILLEGAL_UTF8_BYTE;
2877                     /* mark the range as done, and continue */
2878                     dorange = FALSE;
2879                     didrange = TRUE;
2880                     continue;
2881                 }
2882
2883                 i = d - SvPVX_const(sv);                /* remember current offset */
2884 #ifdef EBCDIC
2885                 SvGROW(sv,
2886                        SvLEN(sv) + ((has_utf8)
2887                                     ?  (512 - UTF_CONTINUATION_MARK
2888                                         + UNISKIP(0x100))
2889                                     : 256));
2890                 /* How many two-byte within 0..255: 128 in UTF-8,
2891                  * 96 in UTF-8-mod. */
2892 #else
2893                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
2894 #endif
2895                 d = SvPVX(sv) + i;              /* refresh d after realloc */
2896 #ifdef EBCDIC
2897                 if (has_utf8) {
2898                     int j;
2899                     for (j = 0; j <= 1; j++) {
2900                         char * const c = (char*)utf8_hop((U8*)d, -1);
2901                         const UV uv    = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2902                         if (j)
2903                             min = (U8)uv;
2904                         else if (uv < 256)
2905                             max = (U8)uv;
2906                         else {
2907                             max = (U8)0xff; /* only to \xff */
2908                             uvmax = uv; /* \x{100} to uvmax */
2909                         }
2910                         d = c; /* eat endpoint chars */
2911                      }
2912                 }
2913                else {
2914 #endif
2915                    d -= 2;              /* eat the first char and the - */
2916                    min = (U8)*d;        /* first char in range */
2917                    max = (U8)d[1];      /* last char in range  */
2918 #ifdef EBCDIC
2919                }
2920 #endif
2921
2922                 if (min > max) {
2923                     Perl_croak(aTHX_
2924                                "Invalid range \"%c-%c\" in transliteration operator",
2925                                (char)min, (char)max);
2926                 }
2927
2928 #ifdef EBCDIC
2929                 /* Because of the discontinuities in EBCDIC A-Z and a-z, expand
2930                  * any subsets of these ranges into individual characters */
2931                 if (literal_endpoint == 2 &&
2932                     ((isLOWER_A(min) && isLOWER_A(max)) ||
2933                      (isUPPER_A(min) && isUPPER_A(max))))
2934                 {
2935                     for (i = min; i <= max; i++) {
2936                         if (isALPHA_A(i))
2937                             *d++ = i;
2938                     }
2939                 }
2940                 else
2941 #endif
2942                     for (i = min; i <= max; i++)
2943 #ifdef EBCDIC
2944                         if (has_utf8) {
2945                             append_utf8_from_native_byte(i, &d);
2946                         }
2947                         else
2948 #endif
2949                             *d++ = (char)i;
2950  
2951 #ifdef EBCDIC
2952                 if (uvmax) {
2953                     d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2954                     if (uvmax > 0x101)
2955                         *d++ = (char) ILLEGAL_UTF8_BYTE;
2956                     if (uvmax > 0x100)
2957                         d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2958                 }
2959 #endif
2960
2961                 /* mark the range as done, and continue */
2962                 dorange = FALSE;
2963                 didrange = TRUE;
2964 #ifdef EBCDIC
2965                 literal_endpoint = 0;
2966 #endif
2967                 continue;
2968             }
2969
2970             /* range begins (ignore - as first or last char) */
2971             else if (*s == '-' && s+1 < send  && s != start) {
2972                 if (didrange) {
2973                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2974                 }
2975                 if (has_utf8
2976 #ifdef EBCDIC
2977                     && !native_range
2978 #endif
2979                     ) {
2980                     *d++ = (char) ILLEGAL_UTF8_BYTE;    /* use illegal utf8 byte--see pmtrans */
2981                     s++;
2982                     continue;
2983                 }
2984                 dorange = TRUE;
2985                 s++;
2986             }
2987             else {
2988                 didrange = FALSE;
2989 #ifdef EBCDIC
2990                 literal_endpoint = 0;
2991                 native_range = TRUE;
2992 #endif
2993             }
2994         }
2995
2996         /* if we get here, we're not doing a transliteration */
2997
2998         else if (*s == '[' && PL_lex_inpat && !in_charclass) {
2999             char *s1 = s-1;
3000             int esc = 0;
3001             while (s1 >= start && *s1-- == '\\')
3002                 esc = !esc;
3003             if (!esc)
3004                 in_charclass = TRUE;
3005         }
3006
3007         else if (*s == ']' && PL_lex_inpat &&  in_charclass) {
3008             char *s1 = s-1;
3009             int esc = 0;
3010             while (s1 >= start && *s1-- == '\\')
3011                 esc = !esc;
3012             if (!esc)
3013                 in_charclass = FALSE;
3014         }
3015
3016         /* skip for regexp comments /(?#comment)/, except for the last
3017          * char, which will be done separately.
3018          * Stop on (?{..}) and friends */
3019
3020         else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3021             if (s[2] == '#') {
3022                 while (s+1 < send && *s != ')')
3023                     *d++ = *s++;
3024             }
3025             else if (!PL_lex_casemods &&
3026                      (    s[2] == '{' /* This should match regcomp.c */
3027                       || (s[2] == '?' && s[3] == '{')))
3028             {
3029                 break;
3030             }
3031         }
3032
3033         /* likewise skip #-initiated comments in //x patterns */
3034         else if (*s == '#' && PL_lex_inpat && !in_charclass &&
3035           ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3036             while (s+1 < send && *s != '\n')
3037                 *d++ = *s++;
3038         }
3039
3040         /* no further processing of single-quoted regex */
3041         else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3042             goto default_action;
3043
3044         /* check for embedded arrays
3045            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3046            */
3047         else if (*s == '@' && s[1]) {
3048             if (isWORDCHAR_lazy_if(s+1,UTF))
3049                 break;
3050             if (strchr(":'{$", s[1]))
3051                 break;
3052             if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3053                 break; /* in regexp, neither @+ nor @- are interpolated */
3054         }
3055
3056         /* check for embedded scalars.  only stop if we're sure it's a
3057            variable.
3058         */
3059         else if (*s == '$') {
3060             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
3061                 break;
3062             if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3063                 if (s[1] == '\\') {
3064                     Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3065                                    "Possible unintended interpolation of $\\ in regex");
3066                 }
3067                 break;          /* in regexp, $ might be tail anchor */
3068             }
3069         }
3070
3071         /* End of else if chain - OP_TRANS rejoin rest */
3072
3073         /* backslashes */
3074         if (*s == '\\' && s+1 < send) {
3075             char* e;    /* Can be used for ending '}', etc. */
3076
3077             s++;
3078
3079             /* warn on \1 - \9 in substitution replacements, but note that \11
3080              * is an octal; and \19 is \1 followed by '9' */
3081             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3082                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3083             {
3084                 /* diag_listed_as: \%d better written as $%d */
3085                 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3086                 *--s = '$';
3087                 break;
3088             }
3089
3090             /* string-change backslash escapes */
3091             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3092                 --s;
3093                 break;
3094             }
3095             /* In a pattern, process \N, but skip any other backslash escapes.
3096              * This is because we don't want to translate an escape sequence
3097              * into a meta symbol and have the regex compiler use the meta
3098              * symbol meaning, e.g. \x{2E} would be confused with a dot.  But
3099              * in spite of this, we do have to process \N here while the proper
3100              * charnames handler is in scope.  See bugs #56444 and #62056.
3101              *
3102              * There is a complication because \N in a pattern may also stand
3103              * for 'match a non-nl', and not mean a charname, in which case its
3104              * processing should be deferred to the regex compiler.  To be a
3105              * charname it must be followed immediately by a '{', and not look
3106              * like \N followed by a curly quantifier, i.e., not something like
3107              * \N{3,}.  regcurly returns a boolean indicating if it is a legal
3108              * quantifier */
3109             else if (PL_lex_inpat
3110                     && (*s != 'N'
3111                         || s[1] != '{'
3112                         || regcurly(s + 1)))
3113             {
3114                 *d++ = '\\';
3115                 goto default_action;
3116             }
3117
3118             switch (*s) {
3119
3120             /* quoted - in transliterations */
3121             case '-':
3122                 if (PL_lex_inwhat == OP_TRANS) {
3123                     *d++ = *s++;
3124                     continue;
3125                 }
3126                 /* FALLTHROUGH */
3127             default:
3128                 {
3129                     if ((isALPHANUMERIC(*s)))
3130                         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3131                                        "Unrecognized escape \\%c passed through",
3132                                        *s);
3133                     /* default action is to copy the quoted character */
3134                     goto default_action;
3135                 }
3136
3137             /* eg. \132 indicates the octal constant 0132 */
3138             case '0': case '1': case '2': case '3':
3139             case '4': case '5': case '6': case '7':
3140                 {
3141                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3142                     STRLEN len = 3;
3143                     uv = grok_oct(s, &len, &flags, NULL);
3144                     s += len;
3145                     if (len < 3 && s < send && isDIGIT(*s)
3146                         && ckWARN(WARN_MISC))
3147                     {
3148                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3149                                     "%s", form_short_octal_warning(s, len));
3150                     }
3151                 }
3152                 goto NUM_ESCAPE_INSERT;
3153
3154             /* eg. \o{24} indicates the octal constant \024 */
3155             case 'o':
3156                 {
3157                     const char* error;
3158
3159                     bool valid = grok_bslash_o(&s, &uv, &error,
3160                                                TRUE, /* Output warning */
3161                                                FALSE, /* Not strict */
3162                                                TRUE, /* Output warnings for
3163                                                          non-portables */
3164                                                UTF);
3165                     if (! valid) {
3166                         yyerror(error);
3167                         continue;
3168                     }
3169                     goto NUM_ESCAPE_INSERT;
3170                 }
3171
3172             /* eg. \x24 indicates the hex constant 0x24 */
3173             case 'x':
3174                 {
3175                     const char* error;
3176
3177                     bool valid = grok_bslash_x(&s, &uv, &error,
3178                                                TRUE, /* Output warning */
3179                                                FALSE, /* Not strict */
3180                                                TRUE,  /* Output warnings for
3181                                                          non-portables */
3182                                                UTF);
3183                     if (! valid) {
3184                         yyerror(error);
3185                         continue;
3186                     }
3187                 }
3188
3189               NUM_ESCAPE_INSERT:
3190                 /* Insert oct or hex escaped character.  There will always be
3191                  * enough room in sv since such escapes will be longer than any
3192                  * UTF-8 sequence they can end up as, except if they force us
3193                  * to recode the rest of the string into utf8 */
3194                 
3195                 /* Here uv is the ordinal of the next character being added */
3196                 if (!UVCHR_IS_INVARIANT(uv)) {
3197                     if (!has_utf8 && uv > 255) {
3198                         /* Might need to recode whatever we have accumulated so
3199                          * far if it contains any chars variant in utf8 or
3200                          * utf-ebcdic. */
3201                           
3202                         SvCUR_set(sv, d - SvPVX_const(sv));
3203                         SvPOK_on(sv);
3204                         *d = '\0';
3205                         /* See Note on sizing above.  */
3206                         sv_utf8_upgrade_flags_grow(
3207                                          sv,
3208                                          SV_GMAGIC|SV_FORCE_UTF8_UPGRADE
3209                                                   /* Above-latin1 in string
3210                                                    * implies no encoding */
3211                                                   |SV_UTF8_NO_ENCODING,
3212                                          UNISKIP(uv) + (STRLEN)(send - s) + 1);
3213                         d = SvPVX(sv) + SvCUR(sv);
3214                         has_utf8 = TRUE;
3215                     }
3216
3217                     if (has_utf8) {
3218                         d = (char*)uvchr_to_utf8((U8*)d, uv);
3219                         if (PL_lex_inwhat == OP_TRANS &&
3220                             PL_sublex_info.sub_op) {
3221                             PL_sublex_info.sub_op->op_private |=
3222                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
3223                                              : OPpTRANS_TO_UTF);
3224                         }
3225 #ifdef EBCDIC
3226                         if (uv > 255 && !dorange)
3227                             native_range = FALSE;
3228 #endif
3229                     }
3230                     else {
3231                         *d++ = (char)uv;
3232                     }
3233                 }
3234                 else {
3235                     *d++ = (char) uv;
3236                 }
3237                 continue;
3238
3239             case 'N':
3240                 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3241                  * named character, like \N{LATIN SMALL LETTER A}, or a named
3242                  * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3243                  * GRAVE}.  For convenience all three forms are referred to as
3244                  * "named characters" below.
3245                  *
3246                  * For patterns, \N also can mean to match a non-newline.  Code
3247                  * before this 'switch' statement should already have handled
3248                  * this situation, and hence this code only has to deal with
3249                  * the named character cases.
3250                  *
3251                  * For non-patterns, the named characters are converted to
3252                  * their string equivalents.  In patterns, named characters are
3253                  * not converted to their ultimate forms for the same reasons
3254                  * that other escapes aren't.  Instead, they are converted to
3255                  * the \N{U+...} form to get the value from the charnames that
3256                  * is in effect right now, while preserving the fact that it
3257                  * was a named character, so that the regex compiler knows
3258                  * this.
3259                  *
3260                  * The structure of this section of code (besides checking for
3261                  * errors and upgrading to utf8) is:
3262                  *  If the named character is of the form \N{U+...}, pass it
3263                  *      through if a pattern; otherwise convert the code point
3264                  *      to utf8
3265                  *  Otherwise must be some \N{NAME}: convert to \N{U+c1.c2...}
3266                  *      if a pattern; otherwise convert to utf8
3267                  *
3268                  * If the regex compiler should ever need to differentiate
3269                  * between the \N{U+...} and \N{name} forms, that could easily
3270                  * be done here by stripping any leading zeros from the
3271                  * \N{U+...} case, and adding them to the other one. */
3272
3273                 /* Here, 's' points to the 'N'; the test below is guaranteed to
3274                  * succeed if we are being called on a pattern, as we already
3275                  * know from a test above that the next character is a '{'.  A
3276                  * non-pattern \N must mean 'named character', which requires
3277                  * braces */
3278                 s++;
3279                 if (*s != '{') {
3280                     yyerror("Missing braces on \\N{}"); 
3281                     continue;
3282                 }
3283                 s++;
3284
3285                 /* If there is no matching '}', it is an error. */
3286                 if (! (e = strchr(s, '}'))) {
3287                     if (! PL_lex_inpat) {
3288                         yyerror("Missing right brace on \\N{}");
3289                     } else {
3290                         yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3291                     }
3292                     continue;
3293                 }
3294
3295                 /* Here it looks like a named character */
3296
3297                 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3298                     s += 2;         /* Skip to next char after the 'U+' */
3299                     if (PL_lex_inpat) {
3300
3301                         /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3302                         /* Check the syntax.  */
3303                         const char *orig_s;
3304                         orig_s = s - 5;
3305                         if (!isXDIGIT(*s)) {
3306                           bad_NU:
3307                             yyerror(
3308                                 "Invalid hexadecimal number in \\N{U+...}"
3309                             );
3310                             s = e + 1;
3311                             continue;
3312                         }
3313                         while (++s < e) {
3314                             if (isXDIGIT(*s))
3315                                 continue;
3316                             else if ((*s == '.' || *s == '_')
3317                                   && isXDIGIT(s[1]))
3318                                 continue;
3319                             goto bad_NU;
3320                         }
3321
3322                         /* Pass everything through unchanged.
3323                          * +1 is for the '}' */
3324                         Copy(orig_s, d, e - orig_s + 1, char);
3325                         d += e - orig_s + 1;
3326                     }
3327                     else {  /* Not a pattern: convert the hex to string */
3328                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3329                                 | PERL_SCAN_SILENT_ILLDIGIT
3330                                 | PERL_SCAN_DISALLOW_PREFIX;
3331                         STRLEN len = e - s;
3332                         uv = grok_hex(s, &len, &flags, NULL);
3333                         if (len == 0 || (len != (STRLEN)(e - s)))
3334                             goto bad_NU;
3335
3336                          /* If the destination is not in utf8, unconditionally
3337                           * recode it to be so.  This is because \N{} implies
3338                           * Unicode semantics, and scalars have to be in utf8
3339                           * to guarantee those semantics */
3340                         if (! has_utf8) {
3341                             SvCUR_set(sv, d - SvPVX_const(sv));
3342                             SvPOK_on(sv);
3343                             *d = '\0';
3344                             /* See Note on sizing above.  */
3345                             sv_utf8_upgrade_flags_grow(
3346                                         sv,
3347                                         SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3348                                         UNISKIP(uv) + (STRLEN)(send - e) + 1);
3349                             d = SvPVX(sv) + SvCUR(sv);
3350                             has_utf8 = TRUE;
3351                         }
3352
3353                         /* Add the (Unicode) code point to the output. */
3354                         if (UNI_IS_INVARIANT(uv)) {
3355                             *d++ = (char) LATIN1_TO_NATIVE(uv);
3356                         }
3357                         else {
3358                             d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3359                         }
3360                     }
3361                 }
3362                 else /* Here is \N{NAME} but not \N{U+...}. */
3363                      if ((res = get_and_check_backslash_N_name(s, e)))
3364                 {
3365                     STRLEN len;
3366                     const char *str = SvPV_const(res, len);
3367                     if (PL_lex_inpat) {
3368
3369                         if (! len) { /* The name resolved to an empty string */
3370                             Copy("\\N{}", d, 4, char);
3371                             d += 4;
3372                         }
3373                         else {
3374                             /* In order to not lose information for the regex
3375                             * compiler, pass the result in the specially made
3376                             * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3377                             * the code points in hex of each character
3378                             * returned by charnames */
3379
3380                             const char *str_end = str + len;
3381                             const STRLEN off = d - SvPVX_const(sv);
3382
3383                             if (! SvUTF8(res)) {
3384                                 /* For the non-UTF-8 case, we can determine the
3385                                  * exact length needed without having to parse
3386                                  * through the string.  Each character takes up
3387                                  * 2 hex digits plus either a trailing dot or
3388                                  * the "}" */
3389                                 const char initial_text[] = "\\N{U+";
3390                                 const STRLEN initial_len = sizeof(initial_text)
3391                                                            - 1;
3392                                 d = off + SvGROW(sv, off
3393                                                     + 3 * len
3394
3395                                                     /* +1 for trailing NUL */
3396                                                     + initial_len + 1
3397
3398                                                     + (STRLEN)(send - e));
3399                                 Copy(initial_text, d, initial_len, char);
3400                                 d += initial_len;
3401                                 while (str < str_end) {
3402                                     char hex_string[4];
3403                                     int len =
3404                                         my_snprintf(hex_string,
3405                                                     sizeof(hex_string),
3406                                                     "%02X.", (U8) *str);
3407                                     PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(hex_string));
3408                                     Copy(hex_string, d, 3, char);
3409                                     d += 3;
3410                                     str++;
3411                                 }
3412                                 d--;    /* Below, we will overwrite the final
3413                                            dot with a right brace */
3414                             }
3415                             else {
3416                                 STRLEN char_length; /* cur char's byte length */
3417
3418                                 /* and the number of bytes after this is
3419                                  * translated into hex digits */
3420                                 STRLEN output_length;
3421
3422                                 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3423                                  * for max('U+', '.'); and 1 for NUL */
3424                                 char hex_string[2 * UTF8_MAXBYTES + 5];
3425
3426                                 /* Get the first character of the result. */
3427                                 U32 uv = utf8n_to_uvchr((U8 *) str,
3428                                                         len,
3429                                                         &char_length,
3430                                                         UTF8_ALLOW_ANYUV);
3431                                 /* Convert first code point to hex, including
3432                                  * the boiler plate before it. */
3433                                 output_length =
3434                                     my_snprintf(hex_string, sizeof(hex_string),
3435                                                 "\\N{U+%X",
3436                                                 (unsigned int) uv);
3437
3438                                 /* Make sure there is enough space to hold it */
3439                                 d = off + SvGROW(sv, off
3440                                                     + output_length
3441                                                     + (STRLEN)(send - e)
3442                                                     + 2);       /* '}' + NUL */
3443                                 /* And output it */
3444                                 Copy(hex_string, d, output_length, char);
3445                                 d += output_length;
3446
3447                                 /* For each subsequent character, append dot and
3448                                 * its ordinal in hex */
3449                                 while ((str += char_length) < str_end) {
3450                                     const STRLEN off = d - SvPVX_const(sv);
3451                                     U32 uv = utf8n_to_uvchr((U8 *) str,
3452                                                             str_end - str,
3453                                                             &char_length,
3454                                                             UTF8_ALLOW_ANYUV);
3455                                     output_length =
3456                                         my_snprintf(hex_string,
3457                                                     sizeof(hex_string),
3458                                                     ".%X",
3459                                                     (unsigned int) uv);
3460
3461                                     d = off + SvGROW(sv, off
3462                                                         + output_length
3463                                                         + (STRLEN)(send - e)
3464                                                         + 2);   /* '}' +  NUL */
3465                                     Copy(hex_string, d, output_length, char);
3466                                     d += output_length;
3467                                 }
3468                             }
3469
3470                             *d++ = '}'; /* Done.  Add the trailing brace */
3471                         }
3472                     }
3473                     else { /* Here, not in a pattern.  Convert the name to a
3474                             * string. */
3475
3476                          /* If destination is not in utf8, unconditionally
3477                           * recode it to be so.  This is because \N{} implies
3478                           * Unicode semantics, and scalars have to be in utf8
3479                           * to guarantee those semantics */
3480                         if (! has_utf8) {
3481                             SvCUR_set(sv, d - SvPVX_const(sv));
3482                             SvPOK_on(sv);
3483                             *d = '\0';
3484                             /* See Note on sizing above.  */
3485                             sv_utf8_upgrade_flags_grow(sv,
3486                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3487                                                 len + (STRLEN)(send - s) + 1);
3488                             d = SvPVX(sv) + SvCUR(sv);
3489                             has_utf8 = TRUE;
3490                         } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3491
3492                             /* See Note on sizing above.  (NOTE: SvCUR() is not
3493                              * set correctly here). */
3494                             const STRLEN off = d - SvPVX_const(sv);
3495                             d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3496                         }
3497                         if (! SvUTF8(res)) {    /* Make sure \N{} return is UTF-8 */
3498                             sv_utf8_upgrade_flags(res, SV_UTF8_NO_ENCODING);
3499                             str = SvPV_const(res, len);
3500                         }
3501                         Copy(str, d, len, char);
3502                         d += len;
3503                     }
3504
3505                     SvREFCNT_dec(res);
3506
3507                 } /* End \N{NAME} */
3508 #ifdef EBCDIC
3509                 if (!dorange) 
3510                     native_range = FALSE; /* \N{} is defined to be Unicode */
3511 #endif
3512                 s = e + 1;  /* Point to just after the '}' */
3513                 continue;
3514
3515             /* \c is a control character */
3516             case 'c':
3517                 s++;
3518                 if (s < send) {
3519                     *d++ = grok_bslash_c(*s++, 1);
3520                 }
3521                 else {
3522                     yyerror("Missing control char name in \\c");
3523                 }
3524                 continue;
3525
3526             /* printf-style backslashes, formfeeds, newlines, etc */
3527             case 'b':
3528                 *d++ = '\b';
3529                 break;
3530             case 'n':
3531                 *d++ = '\n';
3532                 break;
3533             case 'r':
3534                 *d++ = '\r';
3535                 break;
3536             case 'f':
3537                 *d++ = '\f';
3538                 break;
3539             case 't':
3540                 *d++ = '\t';
3541                 break;
3542             case 'e':
3543                 *d++ = ESC_NATIVE;
3544                 break;
3545             case 'a':
3546                 *d++ = '\a';
3547                 break;
3548             } /* end switch */
3549
3550             s++;
3551             continue;
3552         } /* end if (backslash) */
3553 #ifdef EBCDIC
3554         else
3555             literal_endpoint++;
3556 #endif
3557
3558     default_action:
3559         /* If we started with encoded form, or already know we want it,
3560            then encode the next character */
3561         if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3562             STRLEN len  = 1;
3563
3564
3565             /* One might think that it is wasted effort in the case of the
3566              * source being utf8 (this_utf8 == TRUE) to take the next character
3567              * in the source, convert it to an unsigned value, and then convert
3568              * it back again.  But the source has not been validated here.  The
3569              * routine that does the conversion checks for errors like
3570              * malformed utf8 */
3571
3572             const UV nextuv   = (this_utf8)
3573                                 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3574                                 : (UV) ((U8) *s);
3575             const STRLEN need = UNISKIP(nextuv);
3576             if (!has_utf8) {
3577                 SvCUR_set(sv, d - SvPVX_const(sv));
3578                 SvPOK_on(sv);
3579                 *d = '\0';
3580                 /* See Note on sizing above.  */
3581                 sv_utf8_upgrade_flags_grow(sv,
3582                                         SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3583                                         need + (STRLEN)(send - s) + 1);
3584                 d = SvPVX(sv) + SvCUR(sv);
3585                 has_utf8 = TRUE;
3586             } else if (need > len) {
3587                 /* encoded value larger than old, may need extra space (NOTE:
3588                  * SvCUR() is not set correctly here).   See Note on sizing
3589                  * above.  */
3590                 const STRLEN off = d - SvPVX_const(sv);
3591                 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3592             }
3593             s += len;
3594
3595             d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3596 #ifdef EBCDIC
3597             if (uv > 255 && !dorange)
3598                 native_range = FALSE;
3599 #endif
3600         }
3601         else {
3602             *d++ = *s++;
3603         }
3604     } /* while loop to process each character */
3605
3606     /* terminate the string and set up the sv */
3607     *d = '\0';
3608     SvCUR_set(sv, d - SvPVX_const(sv));
3609     if (SvCUR(sv) >= SvLEN(sv))
3610         Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3611                    " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3612
3613     SvPOK_on(sv);
3614     if (IN_ENCODING && !has_utf8) {
3615         sv_recode_to_utf8(sv, _get_encoding());
3616         if (SvUTF8(sv))
3617             has_utf8 = TRUE;
3618     }
3619     if (has_utf8) {
3620         SvUTF8_on(sv);
3621         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3622             PL_sublex_info.sub_op->op_private |=
3623                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3624         }
3625     }
3626
3627     /* shrink the sv if we allocated more than we used */
3628     if (SvCUR(sv) + 5 < SvLEN(sv)) {
3629         SvPV_shrink_to_cur(sv);
3630     }
3631
3632     /* return the substring (via pl_yylval) only if we parsed anything */
3633     if (s > start) {
3634         char *s2 = start;
3635         for (; s2 < s; s2++) {
3636             if (*s2 == '\n')
3637                 COPLINE_INC_WITH_HERELINES;
3638         }
3639         SvREFCNT_inc_simple_void_NN(sv);
3640         if (   (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3641             && ! PL_parser->lex_re_reparsing)
3642         {
3643             const char *const key = PL_lex_inpat ? "qr" : "q";
3644             const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3645             const char *type;
3646             STRLEN typelen;
3647
3648             if (PL_lex_inwhat == OP_TRANS) {
3649                 type = "tr";
3650                 typelen = 2;
3651             } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3652                 type = "s";
3653                 typelen = 1;
3654             } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3655                 type = "q";
3656                 typelen = 1;
3657             } else  {
3658                 type = "qq";
3659                 typelen = 2;
3660             }
3661
3662             sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3663                                 type, typelen);
3664         }
3665         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3666     }
3667     LEAVE_with_name("scan_const");
3668     return s;
3669 }
3670
3671 /* S_intuit_more
3672  * Returns TRUE if there's more to the expression (e.g., a subscript),
3673  * FALSE otherwise.
3674  *
3675  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3676  *
3677  * ->[ and ->{ return TRUE
3678  * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
3679  * { and [ outside a pattern are always subscripts, so return TRUE
3680  * if we're outside a pattern and it's not { or [, then return FALSE
3681  * if we're in a pattern and the first char is a {
3682  *   {4,5} (any digits around the comma) returns FALSE
3683  * if we're in a pattern and the first char is a [
3684  *   [] returns FALSE
3685  *   [SOMETHING] has a funky algorithm to decide whether it's a
3686  *      character class or not.  It has to deal with things like
3687  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3688  * anything else returns TRUE
3689  */
3690
3691 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3692
3693 STATIC int
3694 S_intuit_more(pTHX_ char *s)
3695 {
3696     PERL_ARGS_ASSERT_INTUIT_MORE;
3697
3698     if (PL_lex_brackets)
3699         return TRUE;
3700     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3701         return TRUE;
3702     if (*s == '-' && s[1] == '>'
3703      && FEATURE_POSTDEREF_QQ_IS_ENABLED
3704      && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
3705         ||(s[2] == '@' && strchr("*[{",s[3])) ))
3706         return TRUE;
3707     if (*s != '{' && *s != '[')
3708         return FALSE;
3709     if (!PL_lex_inpat)
3710         return TRUE;
3711
3712     /* In a pattern, so maybe we have {n,m}. */
3713     if (*s == '{') {
3714         if (regcurly(s)) {
3715             return FALSE;
3716         }
3717         return TRUE;
3718     }
3719
3720     /* On the other hand, maybe we have a character class */
3721
3722     s++;
3723     if (*s == ']' || *s == '^')
3724         return FALSE;
3725     else {
3726         /* this is terrifying, and it works */
3727         int weight;
3728         char seen[256];
3729         const char * const send = strchr(s,']');
3730         unsigned char un_char, last_un_char;
3731         char tmpbuf[sizeof PL_tokenbuf * 4];
3732
3733         if (!send)              /* has to be an expression */
3734             return TRUE;
3735         weight = 2;             /* let's weigh the evidence */
3736
3737         if (*s == '$')
3738             weight -= 3;
3739         else if (isDIGIT(*s)) {
3740             if (s[1] != ']') {
3741                 if (isDIGIT(s[1]) && s[2] == ']')
3742                     weight -= 10;
3743             }
3744             else
3745                 weight -= 100;
3746         }
3747         Zero(seen,256,char);
3748         un_char = 255;
3749         for (; s < send; s++) {
3750             last_un_char = un_char;
3751             un_char = (unsigned char)*s;
3752             switch (*s) {
3753             case '@':
3754             case '&':
3755             case '$':
3756                 weight -= seen[un_char] * 10;
3757                 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3758                     int len;
3759                     char *tmp = PL_bufend;
3760                     PL_bufend = (char*)send;
3761                     scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
3762                     PL_bufend = tmp;
3763                     len = (int)strlen(tmpbuf);
3764                     if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3765                                                     UTF ? SVf_UTF8 : 0, SVt_PV))
3766                         weight -= 100;
3767                     else
3768                         weight -= 10;
3769                 }
3770                 else if (*s == '$' && s[1] &&
3771                   strchr("[#!%*<>()-=",s[1])) {
3772                     if (/*{*/ strchr("])} =",s[2]))
3773                         weight -= 10;
3774                     else
3775                         weight -= 1;
3776                 }
3777                 break;
3778             case '\\':
3779                 un_char = 254;
3780                 if (s[1]) {
3781                     if (strchr("wds]",s[1]))
3782                         weight += 100;
3783                     else if (seen[(U8)'\''] || seen[(U8)'"'])
3784                         weight += 1;
3785                     else if (strchr("rnftbxcav",s[1]))
3786                         weight += 40;
3787                     else if (isDIGIT(s[1])) {
3788                         weight += 40;
3789                         while (s[1] && isDIGIT(s[1]))
3790                             s++;
3791                     }
3792                 }
3793                 else
3794                     weight += 100;
3795                 break;
3796             case '-':
3797                 if (s[1] == '\\')
3798                     weight += 50;
3799                 if (strchr("aA01! ",last_un_char))
3800                     weight += 30;
3801                 if (strchr("zZ79~",s[1]))
3802                     weight += 30;
3803                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3804                     weight -= 5;        /* cope with negative subscript */
3805                 break;
3806             default:
3807                 if (!isWORDCHAR(last_un_char)
3808                     && !(last_un_char == '$' || last_un_char == '@'
3809                          || last_un_char == '&')
3810                     && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3811                     char *d = s;
3812                     while (isALPHA(*s))
3813                         s++;
3814                     if (keyword(d, s - d, 0))
3815                         weight -= 150;
3816                 }
3817                 if (un_char == last_un_char + 1)
3818                     weight += 5;
3819                 weight -= seen[un_char];
3820                 break;
3821             }
3822             seen[un_char]++;
3823         }
3824         if (weight >= 0)        /* probably a character class */
3825             return FALSE;
3826     }
3827
3828     return TRUE;
3829 }
3830
3831 /*
3832  * S_intuit_method
3833  *
3834  * Does all the checking to disambiguate
3835  *   foo bar
3836  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
3837  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3838  *
3839  * First argument is the stuff after the first token, e.g. "bar".
3840  *
3841  * Not a method if foo is a filehandle.
3842  * Not a method if foo is a subroutine prototyped to take a filehandle.
3843  * Not a method if it's really "Foo $bar"
3844  * Method if it's "foo $bar"
3845  * Not a method if it's really "print foo $bar"
3846  * Method if it's really "foo package::" (interpreted as package->foo)
3847  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3848  * Not a method if bar is a filehandle or package, but is quoted with
3849  *   =>
3850  */
3851
3852 STATIC int
3853 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
3854 {
3855     char *s = start + (*start == '$');
3856     char tmpbuf[sizeof PL_tokenbuf];
3857     STRLEN len;
3858     GV* indirgv;
3859         /* Mustn't actually add anything to a symbol table.
3860            But also don't want to "initialise" any placeholder
3861            constants that might already be there into full
3862            blown PVGVs with attached PVCV.  */
3863     GV * const gv =
3864         ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
3865
3866     PERL_ARGS_ASSERT_INTUIT_METHOD;
3867
3868     if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3869             return 0;
3870     if (cv && SvPOK(cv)) {
3871         const char *proto = CvPROTO(cv);
3872         if (proto) {
3873             while (*proto && (isSPACE(*proto) || *proto == ';'))
3874                 proto++;
3875             if (*proto == '*')
3876                 return 0;
3877         }
3878     }
3879
3880     if (*start == '$') {
3881         if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3882                 isUPPER(*PL_tokenbuf))
3883             return 0;
3884         s = skipspace(s);
3885         PL_bufptr = start;
3886         PL_expect = XREF;
3887         return *s == '(' ? FUNCMETH : METHOD;
3888     }
3889
3890     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3891     /* start is the beginning of the possible filehandle/object,
3892      * and s is the end of it
3893      * tmpbuf is a copy of it (but with single quotes as double colons)
3894      */
3895
3896     if (!keyword(tmpbuf, len, 0)) {
3897         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3898             len -= 2;
3899             tmpbuf[len] = '\0';
3900             goto bare_package;
3901         }
3902         indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
3903         if (indirgv && GvCVu(indirgv))
3904             return 0;
3905         /* filehandle or package name makes it a method */
3906         if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
3907             s = skipspace(s);
3908             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3909                 return 0;       /* no assumptions -- "=>" quotes bareword */
3910       bare_package:
3911             NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3912                                                   S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3913             NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3914             PL_expect = XTERM;
3915             force_next(WORD);
3916             PL_bufptr = s;
3917             return *s == '(' ? FUNCMETH : METHOD;
3918         }
3919     }
3920     return 0;
3921 }
3922
3923 /* Encoded script support. filter_add() effectively inserts a
3924  * 'pre-processing' function into the current source input stream.
3925  * Note that the filter function only applies to the current source file
3926  * (e.g., it will not affect files 'require'd or 'use'd by this one).
3927  *
3928  * The datasv parameter (which may be NULL) can be used to pass
3929  * private data to this instance of the filter. The filter function
3930  * can recover the SV using the FILTER_DATA macro and use it to
3931  * store private buffers and state information.
3932  *
3933  * The supplied datasv parameter is upgraded to a PVIO type
3934  * and the IoDIRP/IoANY field is used to store the function pointer,
3935  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3936  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3937  * private use must be set using malloc'd pointers.
3938  */
3939
3940 SV *
3941 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3942 {
3943     if (!funcp)
3944         return NULL;
3945
3946     if (!PL_parser)
3947         return NULL;
3948
3949     if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
3950         Perl_croak(aTHX_ "Source filters apply only to byte streams");
3951
3952     if (!PL_rsfp_filters)
3953         PL_rsfp_filters = newAV();
3954     if (!datasv)
3955         datasv = newSV(0);
3956     SvUPGRADE(datasv, SVt_PVIO);
3957     IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3958     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3959     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3960                           FPTR2DPTR(void *, IoANY(datasv)),
3961                           SvPV_nolen(datasv)));
3962     av_unshift(PL_rsfp_filters, 1);
3963     av_store(PL_rsfp_filters, 0, datasv) ;
3964     if (
3965         !PL_parser->filtered
3966      && PL_parser->lex_flags & LEX_EVALBYTES
3967      && PL_bufptr < PL_bufend
3968     ) {
3969         const char *s = PL_bufptr;
3970         while (s < PL_bufend) {
3971             if (*s == '\n') {
3972                 SV *linestr = PL_parser->linestr;
3973                 char *buf = SvPVX(linestr);
3974                 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
3975                 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
3976                 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
3977                 STRLEN const linestart_pos = PL_parser->linestart - buf;
3978                 STRLEN const last_uni_pos =
3979                     PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
3980                 STRLEN const last_lop_pos =
3981                     PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
3982                 av_push(PL_rsfp_filters, linestr);
3983                 PL_parser->linestr = 
3984                     newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
3985                 buf = SvPVX(PL_parser->linestr);
3986                 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
3987                 PL_parser->bufptr = buf + bufptr_pos;
3988                 PL_parser->oldbufptr = buf + oldbufptr_pos;
3989                 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
3990                 PL_parser->linestart = buf + linestart_pos;
3991                 if (PL_parser->last_uni)
3992                     PL_parser->last_uni = buf + last_uni_pos;
3993                 if (PL_parser->last_lop)
3994                     PL_parser->last_lop = buf + last_lop_pos;
3995                 SvLEN(linestr) = SvCUR(linestr);
3996                 SvCUR(linestr) = s-SvPVX(linestr);
3997                 PL_parser->filtered = 1;
3998                 break;
3999             }
4000             s++;
4001         }
4002     }
4003     return(datasv);
4004 }
4005
4006
4007 /* Delete most recently added instance of this filter function. */
4008 void
4009 Perl_filter_del(pTHX_ filter_t funcp)
4010 {
4011     SV *datasv;
4012
4013     PERL_ARGS_ASSERT_FILTER_DEL;
4014
4015 #ifdef DEBUGGING
4016     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4017                           FPTR2DPTR(void*, funcp)));
4018 #endif
4019     if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4020         return;
4021     /* if filter is on top of stack (usual case) just pop it off */
4022     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4023     if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4024         sv_free(av_pop(PL_rsfp_filters));
4025
4026         return;
4027     }
4028     /* we need to search for the correct entry and clear it     */
4029     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4030 }
4031
4032
4033 /* Invoke the idxth filter function for the current rsfp.        */
4034 /* maxlen 0 = read one text line */
4035 I32
4036 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4037 {
4038     filter_t funcp;
4039     SV *datasv = NULL;
4040     /* This API is bad. It should have been using unsigned int for maxlen.
4041        Not sure if we want to change the API, but if not we should sanity
4042        check the value here.  */
4043     unsigned int correct_length = maxlen < 0 ?  PERL_INT_MAX : maxlen;
4044
4045     PERL_ARGS_ASSERT_FILTER_READ;
4046
4047     if (!PL_parser || !PL_rsfp_filters)
4048         return -1;
4049     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
4050         /* Provide a default input filter to make life easy.    */
4051         /* Note that we append to the line. This is handy.      */
4052         DEBUG_P(PerlIO_printf(Perl_debug_log,
4053                               "filter_read %d: from rsfp\n", idx));
4054         if (correct_length) {
4055             /* Want a block */
4056             int len ;
4057             const int old_len = SvCUR(buf_sv);
4058
4059             /* ensure buf_sv is large enough */
4060             SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4061             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4062                                    correct_length)) <= 0) {
4063                 if (PerlIO_error(PL_rsfp))
4064                     return -1;          /* error */
4065                 else
4066                     return 0 ;          /* end of file */
4067             }
4068             SvCUR_set(buf_sv, old_len + len) ;
4069             SvPVX(buf_sv)[old_len + len] = '\0';
4070         } else {
4071             /* Want a line */
4072             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4073                 if (PerlIO_error(PL_rsfp))
4074                     return -1;          /* error */
4075                 else
4076                     return 0 ;          /* end of file */
4077             }
4078         }
4079         return SvCUR(buf_sv);
4080     }
4081     /* Skip this filter slot if filter has been deleted */
4082     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4083         DEBUG_P(PerlIO_printf(Perl_debug_log,
4084                               "filter_read %d: skipped (filter deleted)\n",
4085                               idx));
4086         return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4087     }
4088     if (SvTYPE(datasv) != SVt_PVIO) {
4089         if (correct_length) {
4090             /* Want a block */
4091             const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4092             if (!remainder) return 0; /* eof */
4093             if (correct_length > remainder) correct_length = remainder;
4094             sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4095             SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4096         } else {
4097             /* Want a line */
4098             const char *s = SvEND(datasv);
4099             const char *send = SvPVX(datasv) + SvLEN(datasv);
4100             while (s < send) {
4101                 if (*s == '\n') {
4102                     s++;
4103                     break;
4104                 }
4105                 s++;
4106             }
4107             if (s == send) return 0; /* eof */
4108             sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4109             SvCUR_set(datasv, s-SvPVX(datasv));
4110         }
4111         return SvCUR(buf_sv);
4112     }
4113     /* Get function pointer hidden within datasv        */
4114     funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4115     DEBUG_P(PerlIO_printf(Perl_debug_log,
4116                           "filter_read %d: via function %p (%s)\n",
4117                           idx, (void*)datasv, SvPV_nolen_const(datasv)));
4118     /* Call function. The function is expected to       */
4119     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
4120     /* Return: <0:error, =0:eof, >0:not eof             */
4121     return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4122 }
4123
4124 STATIC char *
4125 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4126 {
4127     PERL_ARGS_ASSERT_FILTER_GETS;
4128
4129 #ifdef PERL_CR_FILTER
4130     if (!PL_rsfp_filters) {
4131         filter_add(S_cr_textfilter,NULL);
4132     }
4133 #endif
4134     if (PL_rsfp_filters) {
4135         if (!append)
4136             SvCUR_set(sv, 0);   /* start with empty line        */
4137         if (FILTER_READ(0, sv, 0) > 0)
4138             return ( SvPVX(sv) ) ;
4139         else
4140             return NULL ;
4141     }
4142     else
4143         return (sv_gets(sv, PL_rsfp, append));
4144 }
4145
4146 STATIC HV *
4147 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4148 {
4149     GV *gv;
4150
4151     PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4152
4153     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4154         return PL_curstash;
4155
4156     if (len > 2 &&
4157         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4158         (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4159     {
4160         return GvHV(gv);                        /* Foo:: */
4161     }
4162
4163     /* use constant CLASS => 'MyClass' */
4164     gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4165     if (gv && GvCV(gv)) {
4166         SV * const sv = cv_const_sv(GvCV(gv));
4167         if (sv)
4168             return gv_stashsv(sv, 0);
4169     }
4170
4171     return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4172 }
4173
4174
4175 STATIC char *
4176 S_tokenize_use(pTHX_ int is_use, char *s) {
4177     PERL_ARGS_ASSERT_TOKENIZE_USE;
4178
4179     if (PL_expect != XSTATE)
4180         yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4181                     is_use ? "use" : "no"));
4182     PL_expect = XTERM;
4183     s = skipspace(s);
4184     if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4185         s = force_version(s, TRUE);
4186         if (*s == ';' || *s == '}'
4187                 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4188             NEXTVAL_NEXTTOKE.opval = NULL;
4189             force_next(WORD);
4190         }
4191         else if (*s == 'v') {
4192             s = force_word(s,WORD,FALSE,TRUE);
4193             s = force_version(s, FALSE);
4194         }
4195     }
4196     else {
4197         s = force_word(s,WORD,FALSE,TRUE);
4198         s = force_version(s, FALSE);
4199     }
4200     pl_yylval.ival = is_use;
4201     return s;
4202 }
4203 #ifdef DEBUGGING
4204     static const char* const exp_name[] =
4205         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4206           "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4207           "TERMORDORDOR"
4208         };
4209 #endif
4210
4211 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4212 STATIC bool
4213 S_word_takes_any_delimeter(char *p, STRLEN len)
4214 {
4215     return (len == 1 && strchr("msyq", p[0])) ||
4216            (len == 2 && (
4217             (p[0] == 't' && p[1] == 'r') ||
4218             (p[0] == 'q' && strchr("qwxr", p[1]))));
4219 }
4220
4221 static void
4222 S_check_scalar_slice(pTHX_ char *s)
4223 {
4224     s++;
4225     while (*s == ' ' || *s == '\t') s++;
4226     if (*s == 'q' && s[1] == 'w'
4227      && !isWORDCHAR_lazy_if(s+2,UTF))
4228         return;
4229     while (*s && (isWORDCHAR_lazy_if(s,UTF) || strchr(" \t$#+-'\"", *s)))
4230         s += UTF ? UTF8SKIP(s) : 1;
4231     if (*s == '}' || *s == ']')
4232         pl_yylval.ival = OPpSLICEWARNING;
4233 }
4234
4235 /*
4236   yylex
4237
4238   Works out what to call the token just pulled out of the input
4239   stream.  The yacc parser takes care of taking the ops we return and
4240   stitching them into a tree.
4241
4242   Returns:
4243     The type of the next token
4244
4245   Structure:
4246       Switch based on the current state:
4247           - if we already built the token before, use it
4248           - if we have a case modifier in a string, deal with that
4249           - handle other cases of interpolation inside a string
4250           - scan the next line if we are inside a format
4251       In the normal state switch on the next character:
4252           - default:
4253             if alphabetic, go to key lookup
4254             unrecoginized character - croak
4255           - 0/4/26: handle end-of-line or EOF
4256           - cases for whitespace
4257           - \n and #: handle comments and line numbers
4258           - various operators, brackets and sigils
4259           - numbers
4260           - quotes
4261           - 'v': vstrings (or go to key lookup)
4262           - 'x' repetition operator (or go to key lookup)
4263           - other ASCII alphanumerics (key lookup begins here):
4264               word before => ?
4265               keyword plugin
4266               scan built-in keyword (but do nothing with it yet)
4267               check for statement label
4268               check for lexical subs
4269                   goto just_a_word if there is one
4270               see whether built-in keyword is overridden
4271               switch on keyword number:
4272                   - default: just_a_word:
4273                       not a built-in keyword; handle bareword lookup
4274                       disambiguate between method and sub call
4275                       fall back to bareword
4276                   - cases for built-in keywords
4277 */
4278
4279
4280 int
4281 Perl_yylex(pTHX)
4282 {
4283     dVAR;
4284     char *s = PL_bufptr;
4285     char *d;
4286     STRLEN len;
4287     bool bof = FALSE;
4288     const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4289     U8 formbrack = 0;
4290     U32 fake_eof = 0;
4291
4292     /* orig_keyword, gvp, and gv are initialized here because
4293      * jump to the label just_a_word_zero can bypass their
4294      * initialization later. */
4295     I32 orig_keyword = 0;
4296     GV *gv = NULL;
4297     GV **gvp = NULL;
4298
4299     DEBUG_T( {
4300         SV* tmp = newSVpvs("");
4301         PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4302             (IV)CopLINE(PL_curcop),
4303             lex_state_names[PL_lex_state],
4304             exp_name[PL_expect],
4305             pv_display(tmp, s, strlen(s), 0, 60));
4306         SvREFCNT_dec(tmp);
4307     } );
4308
4309     switch (PL_lex_state) {
4310     case LEX_NORMAL:
4311     case LEX_INTERPNORMAL:
4312         break;
4313
4314     /* when we've already built the next token, just pull it out of the queue */
4315     case LEX_KNOWNEXT:
4316         PL_nexttoke--;
4317         pl_yylval = PL_nextval[PL_nexttoke];
4318         if (!PL_nexttoke) {
4319             PL_lex_state = PL_lex_defer;
4320             PL_lex_defer = LEX_NORMAL;
4321         }
4322         {
4323             I32 next_type;
4324             next_type = PL_nexttype[PL_nexttoke];
4325             if (next_type & (7<<24)) {
4326                 if (next_type & (1<<24)) {
4327                     if (PL_lex_brackets > 100)
4328                         Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4329                     PL_lex_brackstack[PL_lex_brackets++] =
4330                         (char) ((next_type >> 16) & 0xff);
4331                 }
4332                 if (next_type & (2<<24))
4333                     PL_lex_allbrackets++;
4334                 if (next_type & (4<<24))
4335                     PL_lex_allbrackets--;
4336                 next_type &= 0xffff;
4337             }
4338             return REPORT(next_type == 'p' ? pending_ident() : next_type);
4339         }
4340
4341     /* interpolated case modifiers like \L \U, including \Q and \E.
4342        when we get here, PL_bufptr is at the \
4343     */
4344     case LEX_INTERPCASEMOD:
4345 #ifdef DEBUGGING
4346         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4347             Perl_croak(aTHX_
4348                        "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4349                        PL_bufptr, PL_bufend, *PL_bufptr);
4350 #endif
4351         /* handle \E or end of string */
4352         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4353             /* if at a \E */
4354             if (PL_lex_casemods) {
4355                 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4356                 PL_lex_casestack[PL_lex_casemods] = '\0';
4357
4358                 if (PL_bufptr != PL_bufend
4359                     && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4360                         || oldmod == 'F')) {
4361                     PL_bufptr += 2;
4362                     PL_lex_state = LEX_INTERPCONCAT;
4363                 }
4364                 PL_lex_allbrackets--;
4365                 return REPORT(')');
4366             }
4367             else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4368                /* Got an unpaired \E */
4369                Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4370                         "Useless use of \\E");
4371             }
4372             if (PL_bufptr != PL_bufend)
4373                 PL_bufptr += 2;
4374             PL_lex_state = LEX_INTERPCONCAT;
4375             return yylex();
4376         }
4377         else {
4378             DEBUG_T({ PerlIO_printf(Perl_debug_log,
4379               "### Saw case modifier\n"); });
4380             s = PL_bufptr + 1;
4381             if (s[1] == '\\' && s[2] == 'E') {
4382                 PL_bufptr = s + 3;
4383                 PL_lex_state = LEX_INTERPCONCAT;
4384                 return yylex();
4385             }
4386             else {
4387                 I32 tmp;
4388                 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4389                     tmp = *s, *s = s[2], s[2] = (char)tmp;      /* misordered... */
4390                 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4391                     (strchr(PL_lex_casestack, 'L')
4392                         || strchr(PL_lex_casestack, 'U')
4393                         || strchr(PL_lex_casestack, 'F'))) {
4394                     PL_lex_casestack[--PL_