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