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