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