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