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