This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PATCH: [perl #130567] Assertion failure in scan_const
[perl5.git] / toke.c
CommitLineData
a0d0e21e 1/* toke.c
a687059c 2 *
1129b882
NC
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
a687059c 5 *
d48672a2
LW
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.
378cc40b 8 *
a0d0e21e
LW
9 */
10
11/*
4ac71550
TC
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"]
378cc40b
LW
15 */
16
9cbb5ea2
GS
17/*
18 * This file is the lexer for Perl. It's closely linked to the
4e553d73 19 * parser, perly.y.
ffb4593c
NT
20 *
21 * The main routine is yylex(), which returns the next token.
22 */
23
f0e67a1d
Z
24/*
25=head1 Lexer interface
f0e67a1d
Z
26This is the lower layer of the Perl parser, managing characters and tokens.
27
28=for apidoc AmU|yy_parser *|PL_parser
29
30Pointer to a structure encapsulating the state of the parsing operation
31currently in progress. The pointer can be locally changed to perform
32a nested parse without interfering with the state of an outer parse.
33Individual members of C<PL_parser> have their own documentation.
34
35=cut
36*/
37
378cc40b 38#include "EXTERN.h"
864dbfa3 39#define PERL_IN_TOKE_C
378cc40b 40#include "perl.h"
f7e03a10 41#include "dquote_inline.h"
378cc40b 42
eb0d8d16
NC
43#define new_constant(a,b,c,d,e,f,g) \
44 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
45
6154021b 46#define pl_yylval (PL_parser->yylval)
d3b6f988 47
199e78b7
DM
48/* XXX temporary backwards compatibility */
49#define PL_lex_brackets (PL_parser->lex_brackets)
78cdf107
Z
50#define PL_lex_allbrackets (PL_parser->lex_allbrackets)
51#define PL_lex_fakeeof (PL_parser->lex_fakeeof)
199e78b7
DM
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)
199e78b7 55#define PL_lex_dojoin (PL_parser->lex_dojoin)
199e78b7
DM
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)
199e78b7 66#define PL_preambled (PL_parser->preambled)
bdc0bf6f 67#define PL_linestr (PL_parser->linestr)
c2598295
DM
68#define PL_expect (PL_parser->expect)
69#define PL_copline (PL_parser->copline)
f06b5848
DM
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)
bc177e6b 78#define PL_lex_state (PL_parser->lex_state)
2f9285f8 79#define PL_rsfp (PL_parser->rsfp)
5486870f 80#define PL_rsfp_filters (PL_parser->rsfp_filters)
12bd6ede
DM
81#define PL_in_my (PL_parser->in_my)
82#define PL_in_my_stash (PL_parser->in_my_stash)
14047fc9 83#define PL_tokenbuf (PL_parser->tokenbuf)
670a9cb2 84#define PL_multi_end (PL_parser->multi_end)
13765c85 85#define PL_error_count (PL_parser->error_count)
199e78b7 86
fb205e7a
DM
87# define PL_nexttoke (PL_parser->nexttoke)
88# define PL_nexttype (PL_parser->nexttype)
89# define PL_nextval (PL_parser->nextval)
199e78b7 90
6432a58a
DM
91
92#define SvEVALED(sv) \
93 (SvTYPE(sv) >= SVt_PVNV \
94 && ((XPVIV*)SvANY(sv))->xiv_u.xivu_eval_seen)
95
a1894d81 96static const char* const ident_too_long = "Identifier too long";
8903cb82 97
9ded7720 98# define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
29595ff2 99
a7aaec61
Z
100#define XENUMMASK 0x3f
101#define XFAKEEOF 0x40
102#define XFAKEBRACK 0x80
9059aa12 103
39e02b42 104#ifdef USE_UTF8_SCRIPTS
b3041197 105# define UTF cBOOL(!IN_BYTES)
2b9d42f0 106#else
b3041197 107# define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
2b9d42f0 108#endif
a0ed51b3 109
b1fc3636
CJ
110/* The maximum number of characters preceding the unrecognized one to display */
111#define UNRECOGNIZED_PRECEDE_COUNT 10
112
61f0cdd9 113/* In variables named $^X, these are the legal values for X.
2b92dfce
GS
114 * 1999-02-27 mjd-perl-patch@plover.com */
115#define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
116
14bd96d0 117#define SPACE_OR_TAB(c) isBLANK_A(c)
bf4acbe4 118
9ff909cf
JH
119#define HEXFP_PEEK(s) \
120 (((s[0] == '.') && \
121 (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
122 isALPHA_FOLD_EQ(s[0], 'p'))
123
ffb4593c
NT
124/* LEX_* are values for PL_lex_state, the state of the lexer.
125 * They are arranged oddly so that the guard on the switch statement
79072805 126 * can get by with a single comparison (if the compiler is smart enough).
9da1dd8f
DM
127 *
128 * These values refer to the various states within a sublex parse,
129 * i.e. within a double quotish string
79072805
LW
130 */
131
fb73857a
PP
132/* #define LEX_NOTPARSING 11 is done in perl.h. */
133
b6007c36
DM
134#define LEX_NORMAL 10 /* normal code (ie not within "...") */
135#define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
136#define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
137#define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
138#define LEX_INTERPSTART 6 /* expecting the start of a $var */
139
140 /* at end of code, eg "$x" followed by: */
141#define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
142#define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
143
144#define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
145 string or after \E, $foo, etc */
146#define LEX_INTERPCONST 2 /* NOT USED */
147#define LEX_FORMLINE 1 /* expecting a format line */
b6007c36 148
79072805 149
bbf60fe6 150#ifdef DEBUGGING
27da23d5 151static const char* const lex_state_names[] = {
bbf60fe6
DM
152 "KNOWNEXT",
153 "FORMLINE",
154 "INTERPCONST",
155 "INTERPCONCAT",
156 "INTERPENDMAYBE",
157 "INTERPEND",
158 "INTERPSTART",
159 "INTERPPUSH",
160 "INTERPCASEMOD",
161 "INTERPNORMAL",
162 "NORMAL"
163};
164#endif
165
79072805 166#include "keywords.h"
fe14fcc3 167
ffb4593c
NT
168/* CLINE is a macro that ensures PL_copline has a sane value */
169
57843af0 170#define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
3280af22 171
ffb4593c
NT
172/*
173 * Convenience functions to return different tokens and prime the
9cbb5ea2 174 * lexer for the next token. They all take an argument.
ffb4593c
NT
175 *
176 * TOKEN : generic token (used for '(', DOLSHARP, etc)
177 * OPERATOR : generic operator
178 * AOPERATOR : assignment operator
179 * PREBLOCK : beginning the block after an if, while, foreach, ...
180 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
181 * PREREF : *EXPR where EXPR is not a simple identifier
182 * TERM : expression term
89f35911 183 * POSTDEREF : postfix dereference (->$* ->@[...] etc.)
ffb4593c
NT
184 * LOOPX : loop exiting command (goto, last, dump, etc)
185 * FTST : file test operator
186 * FUN0 : zero-argument function
7eb971ee 187 * FUN0OP : zero-argument function, with its op created in this file
2d2e263d 188 * FUN1 : not used, except for not, which isn't a UNIOP
ffb4593c
NT
189 * BOop : bitwise or or xor
190 * BAop : bitwise and
8823cb89 191 * BCop : bitwise complement
ffb4593c
NT
192 * SHop : shift operator
193 * PWop : power operator
9cbb5ea2 194 * PMop : pattern-matching operator
ffb4593c 195 * Aop : addition-level operator
e4916dd1 196 * AopNOASSIGN : addition-level operator that is never part of .=
ffb4593c
NT
197 * Mop : multiplication-level operator
198 * Eop : equality-testing operator
e5edeb50 199 * Rop : relational operator <= != gt
ffb4593c
NT
200 *
201 * Also see LOP and lop() below.
202 */
203
998054bd 204#ifdef DEBUGGING /* Serve -DT. */
704d4215 205# define REPORT(retval) tokereport((I32)retval, &pl_yylval)
998054bd 206#else
bbf60fe6 207# define REPORT(retval) (retval)
998054bd
SC
208#endif
209
bbf60fe6
DM
210#define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
211#define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
b1764551 212#define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, retval))
bbf60fe6
DM
213#define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
214#define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
215#define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
216#define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
89f35911 217#define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
185c2e96 218#define LOOPX(f) return (PL_bufptr = force_word(s,BAREWORD,TRUE,FALSE), \
7a61bf3c 219 pl_yylval.ival=f, \
a49203fd 220 PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
7a61bf3c 221 REPORT((int)LOOPEX))
6154021b
RGS
222#define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
223#define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
7eb971ee 224#define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
6154021b 225#define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
b1764551
FC
226#define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
227#define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
8823cb89
FC
228#define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \
229 REPORT('~')
b1764551
FC
230#define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
231#define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP))
6154021b 232#define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
b1764551 233#define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
e4916dd1 234#define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
b1764551 235#define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
6154021b
RGS
236#define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
237#define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
2f3197b3 238
a687059c
LW
239/* This bit of chicanery makes a unary function followed by
240 * a parenthesis into a function with one argument, highest precedence.
6f33ba73
RGS
241 * The UNIDOR macro is for unary functions that can be followed by the //
242 * operator (such as C<shift // 0>).
a687059c 243 */
d68ce4ac 244#define UNI3(f,x,have_x) { \
6154021b 245 pl_yylval.ival = f; \
d68ce4ac 246 if (have_x) PL_expect = x; \
376fcdbf
AL
247 PL_bufptr = s; \
248 PL_last_uni = PL_oldbufptr; \
0af40c75 249 PL_last_lop_op = (f) < 0 ? -(f) : (f); \
376fcdbf
AL
250 if (*s == '(') \
251 return REPORT( (int)FUNC1 ); \
294a536f 252 s = skipspace(s); \
376fcdbf
AL
253 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
254 }
d68ce4ac
FC
255#define UNI(f) UNI3(f,XTERM,1)
256#define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
b5fb7ce3
FC
257#define UNIPROTO(f,optional) { \
258 if (optional) PL_last_uni = PL_oldbufptr; \
22393538
MH
259 OPERATOR(f); \
260 }
a687059c 261
d68ce4ac 262#define UNIBRACK(f) UNI3(f,0,0)
79072805 263
9f68db38 264/* grandfather return to old style */
78cdf107
Z
265#define OLDLOP(f) \
266 do { \
267 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
268 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
269 pl_yylval.ival = (f); \
270 PL_expect = XTERM; \
271 PL_bufptr = s; \
272 return (int)LSTOP; \
273 } while(0)
79072805 274
83944c01
FC
275#define COPLINE_INC_WITH_HERELINES \
276 STMT_START { \
277 CopLINE_inc(PL_curcop); \
851b527a
FC
278 if (PL_parser->herelines) \
279 CopLINE(PL_curcop) += PL_parser->herelines, \
280 PL_parser->herelines = 0; \
83944c01 281 } STMT_END
ffdb8b16
FC
282/* Called after scan_str to update CopLINE(PL_curcop), but only when there
283 * is no sublex_push to follow. */
284#define COPLINE_SET_FROM_MULTI_END \
285 STMT_START { \
286 CopLINE_set(PL_curcop, PL_multi_end); \
287 if (PL_multi_end != PL_multi_start) \
851b527a 288 PL_parser->herelines = 0; \
ffdb8b16 289 } STMT_END
83944c01
FC
290
291
8fa7f367
JH
292#ifdef DEBUGGING
293
6154021b 294/* how to interpret the pl_yylval associated with the token */
bbf60fe6
DM
295enum token_type {
296 TOKENTYPE_NONE,
297 TOKENTYPE_IVAL,
6154021b 298 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
bbf60fe6 299 TOKENTYPE_PVAL,
aeaef349 300 TOKENTYPE_OPVAL
bbf60fe6
DM
301};
302
6d4a66ac
NC
303static struct debug_tokens {
304 const int token;
305 enum token_type type;
306 const char *name;
307} const debug_tokens[] =
9041c2e3 308{
bbf60fe6
DM
309 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
310 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
311 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
312 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
313 { ARROW, TOKENTYPE_NONE, "ARROW" },
314 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
315 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
316 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
317 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
318 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
0d863452 319 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
bbf60fe6
DM
320 { DO, TOKENTYPE_NONE, "DO" },
321 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
322 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
323 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
324 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
325 { ELSE, TOKENTYPE_NONE, "ELSE" },
326 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
327 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
328 { FOR, TOKENTYPE_IVAL, "FOR" },
329 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
705fe0e5
FC
330 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
331 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
bbf60fe6
DM
332 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
333 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
7eb971ee 334 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
bbf60fe6
DM
335 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
336 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
337 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
0d863452 338 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
bbf60fe6
DM
339 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
340 { IF, TOKENTYPE_IVAL, "IF" },
5504e6cf 341 { LABEL, TOKENTYPE_PVAL, "LABEL" },
bbf60fe6
DM
342 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
343 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
344 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
345 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
346 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
347 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
348 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
349 { MY, TOKENTYPE_IVAL, "MY" },
bbf60fe6
DM
350 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
351 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
352 { OROP, TOKENTYPE_IVAL, "OROP" },
353 { OROR, TOKENTYPE_NONE, "OROR" },
354 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
88e1f1a2
JV
355 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
356 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
bbf60fe6 357 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
cc624add 358 { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" },
bbf60fe6
DM
359 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
360 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
361 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
362 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
363 { PREINC, TOKENTYPE_NONE, "PREINC" },
364 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
f3f204dc 365 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
bbf60fe6
DM
366 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
367 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
f3f204dc 368 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
bbf60fe6
DM
369 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
370 { SUB, TOKENTYPE_NONE, "SUB" },
371 { THING, TOKENTYPE_OPVAL, "THING" },
372 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
373 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
374 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
375 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
376 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
377 { USE, TOKENTYPE_IVAL, "USE" },
0d863452 378 { WHEN, TOKENTYPE_IVAL, "WHEN" },
bbf60fe6 379 { WHILE, TOKENTYPE_IVAL, "WHILE" },
185c2e96 380 { BAREWORD, TOKENTYPE_OPVAL, "BAREWORD" },
be25f609 381 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
c35e046a 382 { 0, TOKENTYPE_NONE, NULL }
bbf60fe6
DM
383};
384
6154021b 385/* dump the returned token in rv, plus any optional arg in pl_yylval */
998054bd 386
bbf60fe6 387STATIC int
704d4215 388S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
bbf60fe6 389{
7918f24d
NC
390 PERL_ARGS_ASSERT_TOKEREPORT;
391
bbf60fe6 392 if (DEBUG_T_TEST) {
bd61b366 393 const char *name = NULL;
bbf60fe6 394 enum token_type type = TOKENTYPE_NONE;
f54cb97a 395 const struct debug_tokens *p;
396482e1 396 SV* const report = newSVpvs("<== ");
bbf60fe6 397
f54cb97a 398 for (p = debug_tokens; p->token; p++) {
bbf60fe6
DM
399 if (p->token == (int)rv) {
400 name = p->name;
401 type = p->type;
402 break;
403 }
404 }
405 if (name)
54667de8 406 Perl_sv_catpv(aTHX_ report, name);
239f83d5 407 else if (isGRAPH(rv))
4ebc7986 408 {
bbf60fe6 409 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
4ebc7986
FC
410 if ((char)rv == 'p')
411 sv_catpvs(report, " (pending identifier)");
412 }
bbf60fe6 413 else if (!rv)
396482e1 414 sv_catpvs(report, "EOF");
bbf60fe6 415 else
147e3846 416 Perl_sv_catpvf(aTHX_ report, "?? %" IVdf, (IV)rv);
bbf60fe6
DM
417 switch (type) {
418 case TOKENTYPE_NONE:
bbf60fe6
DM
419 break;
420 case TOKENTYPE_IVAL:
147e3846 421 Perl_sv_catpvf(aTHX_ report, "(ival=%" IVdf ")", (IV)lvalp->ival);
bbf60fe6
DM
422 break;
423 case TOKENTYPE_OPNUM:
424 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
704d4215 425 PL_op_name[lvalp->ival]);
bbf60fe6
DM
426 break;
427 case TOKENTYPE_PVAL:
704d4215 428 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
bbf60fe6
DM
429 break;
430 case TOKENTYPE_OPVAL:
704d4215 431 if (lvalp->opval) {
401441c0 432 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
704d4215
GG
433 PL_op_name[lvalp->opval->op_type]);
434 if (lvalp->opval->op_type == OP_CONST) {
b6007c36 435 Perl_sv_catpvf(aTHX_ report, " %s",
704d4215 436 SvPEEK(cSVOPx_sv(lvalp->opval)));
b6007c36
DM
437 }
438
439 }
401441c0 440 else
396482e1 441 sv_catpvs(report, "(opval=null)");
bbf60fe6
DM
442 break;
443 }
b6007c36 444 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
bbf60fe6
DM
445 };
446 return (int)rv;
998054bd
SC
447}
448
b6007c36
DM
449
450/* print the buffer with suitable escapes */
451
452STATIC void
15f169a1 453S_printbuf(pTHX_ const char *const fmt, const char *const s)
b6007c36 454{
396482e1 455 SV* const tmp = newSVpvs("");
7918f24d
NC
456
457 PERL_ARGS_ASSERT_PRINTBUF;
458
5d37acd6 459 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
b6007c36 460 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
5d37acd6 461 GCC_DIAG_RESTORE;
b6007c36
DM
462 SvREFCNT_dec(tmp);
463}
464
8fa7f367
JH
465#endif
466
8290c323
NC
467static int
468S_deprecate_commaless_var_list(pTHX) {
469 PL_expect = XTERM;
6ef4f8b7 470 deprecate_fatal_in("5.28", "Use of comma-less variable list is deprecated");
8290c323
NC
471 return REPORT(','); /* grandfather non-comma-format format */
472}
473
ffb4593c
NT
474/*
475 * S_ao
476 *
f393a21a
FC
477 * This subroutine looks for an '=' next to the operator that has just been
478 * parsed and turns it into an ASSIGNOP if it finds one.
ffb4593c
NT
479 */
480
76e3520e 481STATIC int
cea2e8a9 482S_ao(pTHX_ int toketype)
a0d0e21e 483{
3280af22
NIS
484 if (*PL_bufptr == '=') {
485 PL_bufptr++;
a0d0e21e 486 if (toketype == ANDAND)
6154021b 487 pl_yylval.ival = OP_ANDASSIGN;
a0d0e21e 488 else if (toketype == OROR)
6154021b 489 pl_yylval.ival = OP_ORASSIGN;
c963b151 490 else if (toketype == DORDOR)
6154021b 491 pl_yylval.ival = OP_DORASSIGN;
a0d0e21e
LW
492 toketype = ASSIGNOP;
493 }
b1764551 494 return REPORT(toketype);
a0d0e21e
LW
495}
496
ffb4593c
NT
497/*
498 * S_no_op
499 * When Perl expects an operator and finds something else, no_op
500 * prints the warning. It always prints "<something> found where
501 * operator expected. It prints "Missing semicolon on previous line?"
502 * if the surprise occurs at the start of the line. "do you need to
503 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
504 * where the compiler doesn't know if foo is a method call or a function.
505 * It prints "Missing operator before end of line" if there's nothing
506 * after the missing operator, or "... before <...>" if there is something
507 * after the missing operator.
488bc579
FC
508 *
509 * PL_bufptr is expected to point to the start of the thing that was found,
510 * and s after the next token or partial token.
ffb4593c
NT
511 */
512
76e3520e 513STATIC void
15f169a1 514S_no_op(pTHX_ const char *const what, char *s)
463ee0b2 515{
9d4ba2ae
AL
516 char * const oldbp = PL_bufptr;
517 const bool is_first = (PL_oldbufptr == PL_linestart);
68dc0745 518
7918f24d
NC
519 PERL_ARGS_ASSERT_NO_OP;
520
1189a94a
GS
521 if (!s)
522 s = oldbp;
07c798fb 523 else
1189a94a 524 PL_bufptr = s;
734ab321 525 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
56da5a46
RGS
526 if (ckWARN_d(WARN_SYNTAX)) {
527 if (is_first)
528 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
529 "\t(Missing semicolon on previous line?)\n");
fac0f7a3
KW
530 else if (PL_oldoldbufptr && isIDFIRST_lazy_if_safe(PL_oldoldbufptr,
531 PL_bufend,
532 UTF))
533 {
f54cb97a 534 const char *t;
fac0f7a3
KW
535 for (t = PL_oldoldbufptr;
536 (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF) || *t == ':');
537 t += UTF ? UTF8SKIP(t) : 1)
538 {
c35e046a 539 NOOP;
fac0f7a3 540 }
56da5a46
RGS
541 if (t < PL_bufptr && isSPACE(*t))
542 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
147e3846 543 "\t(Do you need to predeclare %" UTF8f "?)\n",
b17a0679 544 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
56da5a46
RGS
545 }
546 else {
547 assert(s >= oldbp);
548 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
147e3846 549 "\t(Missing operator before %" UTF8f "?)\n",
b17a0679 550 UTF8fARG(UTF, s - oldbp, oldbp));
56da5a46 551 }
07c798fb 552 }
3280af22 553 PL_bufptr = oldbp;
8990e307
LW
554}
555
ffb4593c
NT
556/*
557 * S_missingterm
558 * Complain about missing quote/regexp/heredoc terminator.
d4c19fe8 559 * If it's called with NULL then it cauterizes the line buffer.
ffb4593c
NT
560 * If we're in a delimited string and the delimiter is a control
561 * character, it's reformatted into a two-char sequence like ^C.
562 * This is fatal.
563 */
564
76e3520e 565STATIC void
cea2e8a9 566S_missingterm(pTHX_ char *s)
8990e307 567{
e487ff5e 568 char tmpbuf[UTF8_MAXBYTES + 1];
8990e307 569 char q;
cb650135
FC
570 bool uni = FALSE;
571 SV *sv;
8990e307 572 if (s) {
9d4ba2ae 573 char * const nl = strrchr(s,'\n');
d2719217 574 if (nl)
8990e307 575 *nl = '\0';
7f7f7d08 576 uni = UTF;
8990e307 577 }
cb650135 578 else if (PL_multi_close < 32) {
8990e307 579 *tmpbuf = '^';
585ec06d 580 tmpbuf[1] = (char)toCTRL(PL_multi_close);
8990e307
LW
581 tmpbuf[2] = '\0';
582 s = tmpbuf;
583 }
584 else {
cb650135
FC
585 if (LIKELY(PL_multi_close < 256)) {
586 *tmpbuf = (char)PL_multi_close;
587 tmpbuf[1] = '\0';
588 }
589 else {
590 uni = TRUE;
591 *uvchr_to_utf8((U8 *)tmpbuf, PL_multi_close) = 0;
592 }
8990e307
LW
593 s = tmpbuf;
594 }
595 q = strchr(s,'"') ? '\'' : '"';
cb650135
FC
596 sv = sv_2mortal(newSVpv(s,0));
597 if (uni)
598 SvUTF8_on(sv);
147e3846 599 Perl_croak(aTHX_ "Can't find string terminator %c%" SVf
cb650135 600 "%c anywhere before EOF",q,SVfARG(sv),q);
463ee0b2 601}
79072805 602
dd0ac2b9
FC
603#include "feature.h"
604
0d863452 605/*
0d863452
RH
606 * Check whether the named feature is enabled.
607 */
26ea9e12 608bool
3fff3427 609Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
0d863452 610{
4a731d7b 611 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
7918f24d
NC
612
613 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
ca4d40c4
FC
614
615 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
7918f24d 616
26ea9e12
NC
617 if (namelen > MAX_FEATURE_LEN)
618 return FALSE;
3fff3427 619 memcpy(&he_name[8], name, namelen);
7d69d4a6 620
c8ca97b0
NC
621 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
622 REFCOUNTED_HE_EXISTS));
0d863452
RH
623}
624
ffb4593c 625/*
9cbb5ea2
GS
626 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
627 * utf16-to-utf8-reversed.
ffb4593c
NT
628 */
629
c39cd008
GS
630#ifdef PERL_CR_FILTER
631static void
632strip_return(SV *sv)
633{
eb578fdb
KW
634 const char *s = SvPVX_const(sv);
635 const char * const e = s + SvCUR(sv);
7918f24d
NC
636
637 PERL_ARGS_ASSERT_STRIP_RETURN;
638
c39cd008
GS
639 /* outer loop optimized to do nothing if there are no CR-LFs */
640 while (s < e) {
641 if (*s++ == '\r' && *s == '\n') {
642 /* hit a CR-LF, need to copy the rest */
eb578fdb 643 char *d = s - 1;
c39cd008
GS
644 *d++ = *s++;
645 while (s < e) {
646 if (*s == '\r' && s[1] == '\n')
647 s++;
648 *d++ = *s++;
649 }
650 SvCUR(sv) -= s - d;
651 return;
652 }
653 }
654}
a868473f 655
76e3520e 656STATIC I32
c39cd008 657S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
a868473f 658{
f54cb97a 659 const I32 count = FILTER_READ(idx+1, sv, maxlen);
c39cd008
GS
660 if (count > 0 && !maxlen)
661 strip_return(sv);
662 return count;
a868473f
NIS
663}
664#endif
665
ffb4593c 666/*
8eaa0acf
Z
667=for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
668
669Creates and initialises a new lexer/parser state object, supplying
670a context in which to lex and parse from a new source of Perl code.
671A pointer to the new state object is placed in L</PL_parser>. An entry
672is made on the save stack so that upon unwinding the new state object
673will be destroyed and the former value of L</PL_parser> will be restored.
674Nothing else need be done to clean up the parsing context.
675
2d7f6611 676The code to be parsed comes from C<line> and C<rsfp>. C<line>, if
8eaa0acf 677non-null, provides a string (in SV form) containing code to be parsed.
2d7f6611
KW
678A copy of the string is made, so subsequent modification of C<line>
679does not affect parsing. C<rsfp>, if non-null, provides an input stream
8eaa0acf 680from which code will be read to be parsed. If both are non-null, the
2d7f6611
KW
681code in C<line> comes first and must consist of complete lines of input,
682and C<rsfp> supplies the remainder of the source.
8eaa0acf 683
2d7f6611 684The C<flags> parameter is reserved for future use. Currently it is only
e368b3bd 685used by perl internally, so extensions should always pass zero.
8eaa0acf
Z
686
687=cut
688*/
ffb4593c 689
27fcb6ee 690/* LEX_START_SAME_FILTER indicates that this is not a new file, so it
87606032
NC
691 can share filters with the current parser.
692 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
693 caller, hence isn't owned by the parser, so shouldn't be closed on parser
694 destruction. This is used to handle the case of defaulting to reading the
695 script from the standard input because no filename was given on the command
696 line (without getting confused by situation where STDIN has been closed, so
697 the script handle is opened on fd 0) */
27fcb6ee 698
a0d0e21e 699void
8eaa0acf 700Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
79072805 701{
6ef55633 702 const char *s = NULL;
5486870f 703 yy_parser *parser, *oparser;
90b58c70
KW
704 const U8* first_bad_char_loc;
705
60d63348 706 if (flags && flags & ~LEX_START_FLAGS)
8eaa0acf 707 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
acdf0a21
DM
708
709 /* create and initialise a parser */
710
199e78b7 711 Newxz(parser, 1, yy_parser);
5486870f 712 parser->old_parser = oparser = PL_parser;
acdf0a21
DM
713 PL_parser = parser;
714
28ac2b49 715 parser->stack = NULL;
df13534a 716 parser->stack_max1 = NULL;
28ac2b49 717 parser->ps = NULL;
acdf0a21 718
e3abe207
DM
719 /* on scope exit, free this parser and restore any outer one */
720 SAVEPARSER(parser);
7c4baf47 721 parser->saved_curcop = PL_curcop;
e3abe207 722
acdf0a21 723 /* initialise lexer state */
8990e307 724
fb205e7a 725 parser->nexttoke = 0;
ca4cfd28 726 parser->error_count = oparser ? oparser->error_count : 0;
7f1c3e8c 727 parser->copline = parser->preambling = NOLINE;
5afb0a62 728 parser->lex_state = LEX_NORMAL;
c2598295 729 parser->expect = XSTATE;
2f9285f8 730 parser->rsfp = rsfp;
27fcb6ee
FC
731 parser->rsfp_filters =
732 !(flags & LEX_START_SAME_FILTER) || !oparser
d3cd8e11
FC
733 ? NULL
734 : MUTABLE_AV(SvREFCNT_inc(
735 oparser->rsfp_filters
736 ? oparser->rsfp_filters
737 : (oparser->rsfp_filters = newAV())
738 ));
2f9285f8 739
199e78b7
DM
740 Newx(parser->lex_brackstack, 120, char);
741 Newx(parser->lex_casestack, 12, char);
742 *parser->lex_casestack = '\0';
d794b522 743 Newxz(parser->lex_shared, 1, LEXSHARED);
02b34bbe 744
10efb74f 745 if (line) {
0528fd32 746 STRLEN len;
10efb74f 747 s = SvPV_const(line, len);
90b58c70
KW
748
749 if (SvUTF8(line) && ! is_utf8_string_loc((U8 *) s,
750 SvCUR(line),
751 &first_bad_char_loc))
752 {
753 _force_out_malformed_utf8_message(first_bad_char_loc,
754 (U8 *) s + SvCUR(line),
755 0,
756 1 /* 1 means die */ );
757 NOT_REACHED; /* NOTREACHED */
758 }
759
0abcdfa4
FC
760 parser->linestr = flags & LEX_START_COPIED
761 ? SvREFCNT_inc_simple_NN(line)
762 : newSVpvn_flags(s, len, SvUTF8(line));
b3dd0aba
FC
763 if (!rsfp)
764 sv_catpvs(parser->linestr, "\n;");
0abcdfa4 765 } else {
bf1b738b 766 parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
8990e307 767 }
f06b5848
DM
768 parser->oldoldbufptr =
769 parser->oldbufptr =
770 parser->bufptr =
771 parser->linestart = SvPVX(parser->linestr);
772 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
773 parser->last_lop = parser->last_uni = NULL;
b54f893d 774
6d59e610 775 STATIC_ASSERT_STMT(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
b54f893d
KW
776 |LEX_DONT_CLOSE_RSFP));
777 parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
778 |LEX_DONT_CLOSE_RSFP));
737c24fc 779
60d63348 780 parser->in_pod = parser->filtered = 0;
79072805 781}
a687059c 782
e3abe207
DM
783
784/* delete a parser object */
785
786void
787Perl_parser_free(pTHX_ const yy_parser *parser)
788{
7918f24d
NC
789 PERL_ARGS_ASSERT_PARSER_FREE;
790
7c4baf47 791 PL_curcop = parser->saved_curcop;
bdc0bf6f
DM
792 SvREFCNT_dec(parser->linestr);
793
87606032 794 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
2f9285f8 795 PerlIO_clearerr(parser->rsfp);
407f8cf2
KW
796 else if (parser->rsfp && (!parser->old_parser
797 || (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
2f9285f8 798 PerlIO_close(parser->rsfp);
5486870f 799 SvREFCNT_dec(parser->rsfp_filters);
10002bc1 800 SvREFCNT_dec(parser->lex_stuff);
7ef70b3d 801 SvREFCNT_dec(parser->lex_sub_repl);
3ac7ff8f
FC
802
803 Safefree(parser->lex_brackstack);
804 Safefree(parser->lex_casestack);
805 Safefree(parser->lex_shared);
806 PL_parser = parser->old_parser;
807 Safefree(parser);
808}
809
810void
811Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
812{
3ac7ff8f 813 I32 nexttoke = parser->nexttoke;
3ac7ff8f 814 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
3ce3dcd9 815 while (nexttoke--) {
3ac7ff8f
FC
816 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
817 && parser->nextval[nexttoke].opval
818 && parser->nextval[nexttoke].opval->op_slabbed
819 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
3ce3dcd9 820 op_free(parser->nextval[nexttoke].opval);
3ac7ff8f
FC
821 parser->nextval[nexttoke].opval = NULL;
822 }
3ce3dcd9 823 }
e3abe207
DM
824}
825
826
ffb4593c 827/*
f0e67a1d
Z
828=for apidoc AmxU|SV *|PL_parser-E<gt>linestr
829
830Buffer scalar containing the chunk currently under consideration of the
831text currently being lexed. This is always a plain string scalar (for
832which C<SvPOK> is true). It is not intended to be used as a scalar by
833normal scalar means; instead refer to the buffer directly by the pointer
834variables described below.
835
836The lexer maintains various C<char*> pointers to things in the
837C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
838reallocated, all of these pointers must be updated. Don't attempt to
839do this manually, but rather use L</lex_grow_linestr> if you need to
840reallocate the buffer.
841
842The content of the text chunk in the buffer is commonly exactly one
843complete line of input, up to and including a newline terminator,
844but there are situations where it is otherwise. The octets of the
845buffer may be intended to be interpreted as either UTF-8 or Latin-1.
846The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
847flag on this scalar, which may disagree with it.
848
849For direct examination of the buffer, the variable
850L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
851lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
852of these pointers is usually preferable to examination of the scalar
853through normal scalar means.
854
855=for apidoc AmxU|char *|PL_parser-E<gt>bufend
856
857Direct pointer to the end of the chunk of text currently being lexed, the
858end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
6602b933 859+ SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
f0e67a1d
Z
860always located at the end of the buffer, and does not count as part of
861the buffer's contents.
862
863=for apidoc AmxU|char *|PL_parser-E<gt>bufptr
864
865Points to the current position of lexing inside the lexer buffer.
866Characters around this point may be freely examined, within
867the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
868L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
869interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
870
871Lexing code (whether in the Perl core or not) moves this pointer past
872the characters that it consumes. It is also expected to perform some
873bookkeeping whenever a newline character is consumed. This movement
874can be more conveniently performed by the function L</lex_read_to>,
875which handles newlines appropriately.
876
877Interpretation of the buffer's octets can be abstracted out by
878using the slightly higher-level functions L</lex_peek_unichar> and
879L</lex_read_unichar>.
880
881=for apidoc AmxU|char *|PL_parser-E<gt>linestart
882
883Points to the start of the current line inside the lexer buffer.
884This is useful for indicating at which column an error occurred, and
885not much else. This must be updated by any lexing code that consumes
886a newline; the function L</lex_read_to> handles this detail.
887
888=cut
889*/
890
891/*
892=for apidoc Amx|bool|lex_bufutf8
893
894Indicates whether the octets in the lexer buffer
895(L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
896of Unicode characters. If not, they should be interpreted as Latin-1
897characters. This is analogous to the C<SvUTF8> flag for scalars.
898
899In UTF-8 mode, it is not guaranteed that the lexer buffer actually
900contains valid UTF-8. Lexing code must be robust in the face of invalid
901encoding.
902
903The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
904is significant, but not the whole story regarding the input character
905encoding. Normally, when a file is being read, the scalar contains octets
906and its C<SvUTF8> flag is off, but the octets should be interpreted as
907UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
908however, the scalar may have the C<SvUTF8> flag on, and in this case its
909octets should be interpreted as UTF-8 unless the C<use bytes> pragma
910is in effect. This logic may change in the future; use this function
911instead of implementing the logic yourself.
912
913=cut
914*/
915
916bool
917Perl_lex_bufutf8(pTHX)
918{
919 return UTF;
920}
921
922/*
923=for apidoc Amx|char *|lex_grow_linestr|STRLEN len
924
925Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
2d7f6611 926at least C<len> octets (including terminating C<NUL>). Returns a
f0e67a1d
Z
927pointer to the reallocated buffer. This is necessary before making
928any direct modification of the buffer that would increase its length.
929L</lex_stuff_pvn> provides a more convenient way to insert text into
930the buffer.
931
932Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
933this function updates all of the lexer's variables that point directly
934into the buffer.
935
936=cut
937*/
938
939char *
940Perl_lex_grow_linestr(pTHX_ STRLEN len)
941{
942 SV *linestr;
943 char *buf;
944 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
c7641931 945 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
98d5e3ef
DM
946 bool current;
947
f0e67a1d
Z
948 linestr = PL_parser->linestr;
949 buf = SvPVX(linestr);
950 if (len <= SvLEN(linestr))
951 return buf;
98d5e3ef
DM
952
953 /* Is the lex_shared linestr SV the same as the current linestr SV?
954 * Only in this case does re_eval_start need adjusting, since it
955 * points within lex_shared->ls_linestr's buffer */
b1b8fb6a
DM
956 current = ( !PL_parser->lex_shared->ls_linestr
957 || linestr == PL_parser->lex_shared->ls_linestr);
98d5e3ef 958
f0e67a1d
Z
959 bufend_pos = PL_parser->bufend - buf;
960 bufptr_pos = PL_parser->bufptr - buf;
961 oldbufptr_pos = PL_parser->oldbufptr - buf;
962 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
963 linestart_pos = PL_parser->linestart - buf;
964 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
965 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
98d5e3ef 966 re_eval_start_pos = (current && PL_parser->lex_shared->re_eval_start) ?
3328ab5a 967 PL_parser->lex_shared->re_eval_start - buf : 0;
c7641931 968
f0e67a1d 969 buf = sv_grow(linestr, len);
c7641931 970
f0e67a1d
Z
971 PL_parser->bufend = buf + bufend_pos;
972 PL_parser->bufptr = buf + bufptr_pos;
973 PL_parser->oldbufptr = buf + oldbufptr_pos;
974 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
975 PL_parser->linestart = buf + linestart_pos;
976 if (PL_parser->last_uni)
977 PL_parser->last_uni = buf + last_uni_pos;
978 if (PL_parser->last_lop)
979 PL_parser->last_lop = buf + last_lop_pos;
98d5e3ef 980 if (current && PL_parser->lex_shared->re_eval_start)
3328ab5a 981 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
f0e67a1d
Z
982 return buf;
983}
984
985/*
83aa740e 986=for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
f0e67a1d
Z
987
988Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
989immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
990reallocating the buffer if necessary. This means that lexing code that
991runs later will see the characters as if they had appeared in the input.
992It is not recommended to do this as part of normal parsing, and most
993uses of this facility run the risk of the inserted characters being
994interpreted in an unintended manner.
995
2d7f6611
KW
996The string to be inserted is represented by C<len> octets starting
997at C<pv>. These octets are interpreted as either UTF-8 or Latin-1,
998according to whether the C<LEX_STUFF_UTF8> flag is set in C<flags>.
f0e67a1d
Z
999The characters are recoded for the lexer buffer, according to how the
1000buffer is currently being interpreted (L</lex_bufutf8>). If a string
9dcc53ea 1001to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
f0e67a1d
Z
1002function is more convenient.
1003
1004=cut
1005*/
1006
1007void
83aa740e 1008Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
f0e67a1d 1009{
749123ff 1010 dVAR;
f0e67a1d
Z
1011 char *bufptr;
1012 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
1013 if (flags & ~(LEX_STUFF_UTF8))
1014 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
1015 if (UTF) {
1016 if (flags & LEX_STUFF_UTF8) {
1017 goto plain_copy;
1018 } else {
54d004e8 1019 STRLEN highhalf = 0; /* Count of variants */
83aa740e 1020 const char *p, *e = pv+len;
54d004e8
KW
1021 for (p = pv; p != e; p++) {
1022 if (! UTF8_IS_INVARIANT(*p)) {
1023 highhalf++;
1024 }
1025 }
f0e67a1d
Z
1026 if (!highhalf)
1027 goto plain_copy;
1028 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1029 bufptr = PL_parser->bufptr;
1030 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
255fdf19
Z
1031 SvCUR_set(PL_parser->linestr,
1032 SvCUR(PL_parser->linestr) + len+highhalf);
f0e67a1d
Z
1033 PL_parser->bufend += len+highhalf;
1034 for (p = pv; p != e; p++) {
1035 U8 c = (U8)*p;
54d004e8
KW
1036 if (! UTF8_IS_INVARIANT(c)) {
1037 *bufptr++ = UTF8_TWO_BYTE_HI(c);
1038 *bufptr++ = UTF8_TWO_BYTE_LO(c);
f0e67a1d
Z
1039 } else {
1040 *bufptr++ = (char)c;
1041 }
1042 }
1043 }
1044 } else {
1045 if (flags & LEX_STUFF_UTF8) {
1046 STRLEN highhalf = 0;
83aa740e 1047 const char *p, *e = pv+len;
f0e67a1d
Z
1048 for (p = pv; p != e; p++) {
1049 U8 c = (U8)*p;
54d004e8 1050 if (UTF8_IS_ABOVE_LATIN1(c)) {
f0e67a1d
Z
1051 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1052 "non-Latin-1 character into Latin-1 input");
54d004e8 1053 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
f0e67a1d
Z
1054 p++;
1055 highhalf++;
75219bac
KW
1056 } else if (! UTF8_IS_INVARIANT(c)) {
1057 _force_out_malformed_utf8_message((U8 *) p, (U8 *) e,
1058 0,
1059 1 /* 1 means die */ );
1060 NOT_REACHED; /* NOTREACHED */
f0e67a1d
Z
1061 }
1062 }
1063 if (!highhalf)
1064 goto plain_copy;
1065 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1066 bufptr = PL_parser->bufptr;
1067 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
255fdf19
Z
1068 SvCUR_set(PL_parser->linestr,
1069 SvCUR(PL_parser->linestr) + len-highhalf);
f0e67a1d 1070 PL_parser->bufend += len-highhalf;
54d004e8
KW
1071 p = pv;
1072 while (p < e) {
1073 if (UTF8_IS_INVARIANT(*p)) {
1074 *bufptr++ = *p;
1075 p++;
f0e67a1d 1076 }
54d004e8
KW
1077 else {
1078 assert(p < e -1 );
a62b247b 1079 *bufptr++ = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
54d004e8
KW
1080 p += 2;
1081 }
f0e67a1d
Z
1082 }
1083 } else {
54d004e8 1084 plain_copy:
f0e67a1d
Z
1085 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1086 bufptr = PL_parser->bufptr;
1087 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
255fdf19 1088 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
f0e67a1d
Z
1089 PL_parser->bufend += len;
1090 Copy(pv, bufptr, len, char);
1091 }
1092 }
1093}
1094
1095/*
9dcc53ea
Z
1096=for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1097
1098Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1099immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1100reallocating the buffer if necessary. This means that lexing code that
1101runs later will see the characters as if they had appeared in the input.
1102It is not recommended to do this as part of normal parsing, and most
1103uses of this facility run the risk of the inserted characters being
1104interpreted in an unintended manner.
1105
2d7f6611 1106The string to be inserted is represented by octets starting at C<pv>
9dcc53ea
Z
1107and continuing to the first nul. These octets are interpreted as either
1108UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
2d7f6611 1109in C<flags>. The characters are recoded for the lexer buffer, according
9dcc53ea
Z
1110to how the buffer is currently being interpreted (L</lex_bufutf8>).
1111If it is not convenient to nul-terminate a string to be inserted, the
1112L</lex_stuff_pvn> function is more appropriate.
1113
1114=cut
1115*/
1116
1117void
1118Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1119{
1120 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1121 lex_stuff_pvn(pv, strlen(pv), flags);
1122}
1123
1124/*
f0e67a1d
Z
1125=for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1126
1127Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1128immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1129reallocating the buffer if necessary. This means that lexing code that
1130runs later will see the characters as if they had appeared in the input.
1131It is not recommended to do this as part of normal parsing, and most
1132uses of this facility run the risk of the inserted characters being
1133interpreted in an unintended manner.
1134
2d7f6611 1135The string to be inserted is the string value of C<sv>. The characters
f0e67a1d 1136are recoded for the lexer buffer, according to how the buffer is currently
9dcc53ea 1137being interpreted (L</lex_bufutf8>). If a string to be inserted is
f0e67a1d
Z
1138not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1139need to construct a scalar.
1140
1141=cut
1142*/
1143
1144void
1145Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1146{
1147 char *pv;
1148 STRLEN len;
1149 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1150 if (flags)
1151 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1152 pv = SvPV(sv, len);
1153 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1154}
1155
1156/*
1157=for apidoc Amx|void|lex_unstuff|char *ptr
1158
1159Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
2d7f6611 1160C<ptr>. Text following C<ptr> will be moved, and the buffer shortened.
f0e67a1d
Z
1161This hides the discarded text from any lexing code that runs later,
1162as if the text had never appeared.
1163
1164This is not the normal way to consume lexed text. For that, use
1165L</lex_read_to>.
1166
1167=cut
1168*/
1169
1170void
1171Perl_lex_unstuff(pTHX_ char *ptr)
1172{
1173 char *buf, *bufend;
1174 STRLEN unstuff_len;
1175 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1176 buf = PL_parser->bufptr;
1177 if (ptr < buf)
1178 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1179 if (ptr == buf)
1180 return;
1181 bufend = PL_parser->bufend;
1182 if (ptr > bufend)
1183 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1184 unstuff_len = ptr - buf;
1185 Move(ptr, buf, bufend+1-ptr, char);
1186 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1187 PL_parser->bufend = bufend - unstuff_len;
1188}
1189
1190/*
1191=for apidoc Amx|void|lex_read_to|char *ptr
1192
1193Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
2d7f6611 1194to C<ptr>. This advances L</PL_parser-E<gt>bufptr> to match C<ptr>,
f0e67a1d
Z
1195performing the correct bookkeeping whenever a newline character is passed.
1196This is the normal way to consume lexed text.
1197
1198Interpretation of the buffer's octets can be abstracted out by
1199using the slightly higher-level functions L</lex_peek_unichar> and
1200L</lex_read_unichar>.
1201
1202=cut
1203*/
1204
1205void
1206Perl_lex_read_to(pTHX_ char *ptr)
1207{
1208 char *s;
1209 PERL_ARGS_ASSERT_LEX_READ_TO;
1210 s = PL_parser->bufptr;
1211 if (ptr < s || ptr > PL_parser->bufend)
1212 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1213 for (; s != ptr; s++)
1214 if (*s == '\n') {
83944c01 1215 COPLINE_INC_WITH_HERELINES;
f0e67a1d
Z
1216 PL_parser->linestart = s+1;
1217 }
1218 PL_parser->bufptr = ptr;
1219}
1220
1221/*
1222=for apidoc Amx|void|lex_discard_to|char *ptr
1223
1224Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
2d7f6611
KW
1225up to C<ptr>. The remaining content of the buffer will be moved, and
1226all pointers into the buffer updated appropriately. C<ptr> must not
f0e67a1d
Z
1227be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1228it is not permitted to discard text that has yet to be lexed.
1229
1230Normally it is not necessarily to do this directly, because it suffices to
1231use the implicit discarding behaviour of L</lex_next_chunk> and things
1232based on it. However, if a token stretches across multiple lines,
1f317c95 1233and the lexing code has kept multiple lines of text in the buffer for
f0e67a1d
Z
1234that purpose, then after completion of the token it would be wise to
1235explicitly discard the now-unneeded earlier lines, to avoid future
1236multi-line tokens growing the buffer without bound.
1237
1238=cut
1239*/
1240
1241void
1242Perl_lex_discard_to(pTHX_ char *ptr)
1243{
1244 char *buf;
1245 STRLEN discard_len;
1246 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1247 buf = SvPVX(PL_parser->linestr);
1248 if (ptr < buf)
1249 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1250 if (ptr == buf)
1251 return;
1252 if (ptr > PL_parser->bufptr)
1253 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1254 discard_len = ptr - buf;
1255 if (PL_parser->oldbufptr < ptr)
1256 PL_parser->oldbufptr = ptr;
1257 if (PL_parser->oldoldbufptr < ptr)
1258 PL_parser->oldoldbufptr = ptr;
1259 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1260 PL_parser->last_uni = NULL;
1261 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1262 PL_parser->last_lop = NULL;
1263 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1264 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1265 PL_parser->bufend -= discard_len;
1266 PL_parser->bufptr -= discard_len;
1267 PL_parser->oldbufptr -= discard_len;
1268 PL_parser->oldoldbufptr -= discard_len;
1269 if (PL_parser->last_uni)
1270 PL_parser->last_uni -= discard_len;
1271 if (PL_parser->last_lop)
1272 PL_parser->last_lop -= discard_len;
1273}
1274
1275/*
1276=for apidoc Amx|bool|lex_next_chunk|U32 flags
1277
1278Reads in the next chunk of text to be lexed, appending it to
1279L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1280looked to the end of the current chunk and wants to know more. It is
1281usual, but not necessary, for lexing to have consumed the entirety of
1282the current chunk at this time.
1283
1284If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1285chunk (i.e., the current chunk has been entirely consumed), normally the
1286current chunk will be discarded at the same time that the new chunk is
c5608a1f 1287read in. If C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, the current chunk
f0e67a1d
Z
1288will not be discarded. If the current chunk has not been entirely
1289consumed, then it will not be discarded regardless of the flag.
1290
1291Returns true if some new text was added to the buffer, or false if the
1292buffer has reached the end of the input text.
1293
1294=cut
1295*/
1296
1297#define LEX_FAKE_EOF 0x80000000
e47d32dc 1298#define LEX_NO_TERM 0x40000000 /* here-doc */
f0e67a1d
Z
1299
1300bool
1301Perl_lex_next_chunk(pTHX_ U32 flags)
1302{
1303 SV *linestr;
1304 char *buf;
1305 STRLEN old_bufend_pos, new_bufend_pos;
1306 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1307 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
17cc9359 1308 bool got_some_for_debugger = 0;
f0e67a1d 1309 bool got_some;
6cdc5cd8
KW
1310 const U8* first_bad_char_loc;
1311
112d1284 1312 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
f0e67a1d 1313 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
d27f4b91 1314 if (!(flags & LEX_NO_TERM) && PL_lex_inwhat)
e47d32dc 1315 return FALSE;
f0e67a1d
Z
1316 linestr = PL_parser->linestr;
1317 buf = SvPVX(linestr);
407f8cf2
KW
1318 if (!(flags & LEX_KEEP_PREVIOUS)
1319 && PL_parser->bufptr == PL_parser->bufend)
1320 {
f0e67a1d
Z
1321 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1322 linestart_pos = 0;
1323 if (PL_parser->last_uni != PL_parser->bufend)
1324 PL_parser->last_uni = NULL;
1325 if (PL_parser->last_lop != PL_parser->bufend)
1326 PL_parser->last_lop = NULL;
1327 last_uni_pos = last_lop_pos = 0;
1328 *buf = 0;
1329 SvCUR(linestr) = 0;
1330 } else {
1331 old_bufend_pos = PL_parser->bufend - buf;
1332 bufptr_pos = PL_parser->bufptr - buf;
1333 oldbufptr_pos = PL_parser->oldbufptr - buf;
1334 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1335 linestart_pos = PL_parser->linestart - buf;
1336 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1337 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1338 }
1339 if (flags & LEX_FAKE_EOF) {
1340 goto eof;
60d63348 1341 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
f0e67a1d
Z
1342 got_some = 0;
1343 } else if (filter_gets(linestr, old_bufend_pos)) {
1344 got_some = 1;
17cc9359 1345 got_some_for_debugger = 1;
112d1284
FC
1346 } else if (flags & LEX_NO_TERM) {
1347 got_some = 0;
f0e67a1d 1348 } else {
580561a3 1349 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
847cc851 1350 SvPVCLEAR(linestr);
f0e67a1d
Z
1351 eof:
1352 /* End of real input. Close filehandle (unless it was STDIN),
1353 * then add implicit termination.
1354 */
87606032 1355 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
f0e67a1d
Z
1356 PerlIO_clearerr(PL_parser->rsfp);
1357 else if (PL_parser->rsfp)
1358 (void)PerlIO_close(PL_parser->rsfp);
1359 PL_parser->rsfp = NULL;
60d63348 1360 PL_parser->in_pod = PL_parser->filtered = 0;
f0e67a1d
Z
1361 if (!PL_in_eval && PL_minus_p) {
1362 sv_catpvs(linestr,
1363 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1364 PL_minus_n = PL_minus_p = 0;
1365 } else if (!PL_in_eval && PL_minus_n) {
1366 sv_catpvs(linestr, /*{*/";}");
1367 PL_minus_n = 0;
1368 } else
1369 sv_catpvs(linestr, ";");
1370 got_some = 1;
1371 }
1372 buf = SvPVX(linestr);
1373 new_bufend_pos = SvCUR(linestr);
1374 PL_parser->bufend = buf + new_bufend_pos;
1375 PL_parser->bufptr = buf + bufptr_pos;
6cdc5cd8
KW
1376
1377 if (UTF && ! is_utf8_string_loc((U8 *) PL_parser->bufptr,
1378 PL_parser->bufend - PL_parser->bufptr,
1379 &first_bad_char_loc))
1380 {
6cdc5cd8
KW
1381 _force_out_malformed_utf8_message(first_bad_char_loc,
1382 (U8 *) PL_parser->bufend,
1383 0,
1384 1 /* 1 means die */ );
1385 NOT_REACHED; /* NOTREACHED */
1386 }
1387
f0e67a1d
Z
1388 PL_parser->oldbufptr = buf + oldbufptr_pos;
1389 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1390 PL_parser->linestart = buf + linestart_pos;
1391 if (PL_parser->last_uni)
1392 PL_parser->last_uni = buf + last_uni_pos;
1393 if (PL_parser->last_lop)
1394 PL_parser->last_lop = buf + last_lop_pos;
7f1c3e8c
FC
1395 if (PL_parser->preambling != NOLINE) {
1396 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1397 PL_parser->preambling = NOLINE;
1398 }
407f8cf2
KW
1399 if ( got_some_for_debugger
1400 && PERLDB_LINE_OR_SAVESRC
1401 && PL_curstash != PL_debstash)
1402 {
f0e67a1d
Z
1403 /* debugger active and we're not compiling the debugger code,
1404 * so store the line into the debugger's array of lines
1405 */
1406 update_debugger_info(NULL, buf+old_bufend_pos,
1407 new_bufend_pos-old_bufend_pos);
1408 }
1409 return got_some;
1410}
1411
1412/*
1413=for apidoc Amx|I32|lex_peek_unichar|U32 flags
1414
1415Looks ahead one (Unicode) character in the text currently being lexed.
1416Returns the codepoint (unsigned integer value) of the next character,
1417or -1 if lexing has reached the end of the input text. To consume the
1418peeked character, use L</lex_read_unichar>.
1419
1420If the next character is in (or extends into) the next chunk of input
1421text, the next chunk will be read in. Normally the current chunk will be
c5608a1f
KW
1422discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1423bit set, then the current chunk will not be discarded.
f0e67a1d
Z
1424
1425If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1426is encountered, an exception is generated.
1427
1428=cut
1429*/
1430
1431I32
1432Perl_lex_peek_unichar(pTHX_ U32 flags)
1433{
749123ff 1434 dVAR;
f0e67a1d
Z
1435 char *s, *bufend;
1436 if (flags & ~(LEX_KEEP_PREVIOUS))
1437 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1438 s = PL_parser->bufptr;
1439 bufend = PL_parser->bufend;
1440 if (UTF) {
1441 U8 head;
1442 I32 unichar;
1443 STRLEN len, retlen;
1444 if (s == bufend) {
1445 if (!lex_next_chunk(flags))
1446 return -1;
1447 s = PL_parser->bufptr;
1448 bufend = PL_parser->bufend;
1449 }
1450 head = (U8)*s;
54d004e8 1451 if (UTF8_IS_INVARIANT(head))
f0e67a1d 1452 return head;
54d004e8
KW
1453 if (UTF8_IS_START(head)) {
1454 len = UTF8SKIP(&head);
f0e67a1d
Z
1455 while ((STRLEN)(bufend-s) < len) {
1456 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1457 break;
1458 s = PL_parser->bufptr;
1459 bufend = PL_parser->bufend;
1460 }
1461 }
c80e42f3 1462 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
f0e67a1d 1463 if (retlen == (STRLEN)-1) {
75219bac
KW
1464 _force_out_malformed_utf8_message((U8 *) s,
1465 (U8 *) bufend,
1466 0,
1467 1 /* 1 means die */ );
1468 NOT_REACHED; /* NOTREACHED */
f0e67a1d
Z
1469 }
1470 return unichar;
1471 } else {
1472 if (s == bufend) {
1473 if (!lex_next_chunk(flags))
1474 return -1;
1475 s = PL_parser->bufptr;
1476 }
1477 return (U8)*s;
1478 }
1479}
1480
1481/*
1482=for apidoc Amx|I32|lex_read_unichar|U32 flags
1483
1484Reads the next (Unicode) character in the text currently being lexed.
1485Returns the codepoint (unsigned integer value) of the character read,
1486and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1487if lexing has reached the end of the input text. To non-destructively
1488examine the next character, use L</lex_peek_unichar> instead.
1489
1490If the next character is in (or extends into) the next chunk of input
1491text, the next chunk will be read in. Normally the current chunk will be
c5608a1f
KW
1492discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1493bit set, then the current chunk will not be discarded.
f0e67a1d
Z
1494
1495If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1496is encountered, an exception is generated.
1497
1498=cut
1499*/
1500
1501I32
1502Perl_lex_read_unichar(pTHX_ U32 flags)
1503{
1504 I32 c;
1505 if (flags & ~(LEX_KEEP_PREVIOUS))
1506 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1507 c = lex_peek_unichar(flags);
1508 if (c != -1) {
1509 if (c == '\n')
83944c01 1510 COPLINE_INC_WITH_HERELINES;
d9018cbe
EB
1511 if (UTF)
1512 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1513 else
1514 ++(PL_parser->bufptr);
f0e67a1d
Z
1515 }
1516 return c;
1517}
1518
1519/*
1520=for apidoc Amx|void|lex_read_space|U32 flags
1521
1522Reads optional spaces, in Perl style, in the text currently being
1523lexed. The spaces may include ordinary whitespace characters and
1524Perl-style comments. C<#line> directives are processed if encountered.
1525L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1526at a non-space character (or the end of the input text).
1527
1528If spaces extend into the next chunk of input text, the next chunk will
1529be read in. Normally the current chunk will be discarded at the same
c5608a1f 1530time, but if C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, then the current
f0e67a1d
Z
1531chunk will not be discarded.
1532
1533=cut
1534*/
1535
21791330 1536#define LEX_NO_INCLINE 0x40000000
f0998909
Z
1537#define LEX_NO_NEXT_CHUNK 0x80000000
1538
f0e67a1d
Z
1539void
1540Perl_lex_read_space(pTHX_ U32 flags)
1541{
1542 char *s, *bufend;
21791330 1543 const bool can_incline = !(flags & LEX_NO_INCLINE);
f0e67a1d 1544 bool need_incline = 0;
21791330 1545 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
f0e67a1d 1546 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
f0e67a1d
Z
1547 s = PL_parser->bufptr;
1548 bufend = PL_parser->bufend;
1549 while (1) {
1550 char c = *s;
1551 if (c == '#') {
1552 do {
1553 c = *++s;
1554 } while (!(c == '\n' || (c == 0 && s == bufend)));
1555 } else if (c == '\n') {
1556 s++;
21791330
FC
1557 if (can_incline) {
1558 PL_parser->linestart = s;
1559 if (s == bufend)
1560 need_incline = 1;
1561 else
1562 incline(s);
1563 }
f0e67a1d
Z
1564 } else if (isSPACE(c)) {
1565 s++;
1566 } else if (c == 0 && s == bufend) {
1567 bool got_more;
65c68e17 1568 line_t l;
f0998909
Z
1569 if (flags & LEX_NO_NEXT_CHUNK)
1570 break;
f0e67a1d 1571 PL_parser->bufptr = s;
65c68e17 1572 l = CopLINE(PL_curcop);
851b527a 1573 CopLINE(PL_curcop) += PL_parser->herelines + 1;
f0e67a1d 1574 got_more = lex_next_chunk(flags);
65c68e17 1575 CopLINE_set(PL_curcop, l);
f0e67a1d
Z
1576 s = PL_parser->bufptr;
1577 bufend = PL_parser->bufend;
1578 if (!got_more)
1579 break;
21791330 1580 if (can_incline && need_incline && PL_parser->rsfp) {
f0e67a1d
Z
1581 incline(s);
1582 need_incline = 0;
1583 }
3c47da3c
FC
1584 } else if (!c) {
1585 s++;
f0e67a1d
Z
1586 } else {
1587 break;
1588 }
1589 }
f0e67a1d
Z
1590 PL_parser->bufptr = s;
1591}
1592
1593/*
fe788d6b
PM
1594
1595=for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1596
1597This function performs syntax checking on a prototype, C<proto>.
1598If C<warn> is true, any illegal characters or mismatched brackets
1599will trigger illegalproto warnings, declaring that they were
1600detected in the prototype for C<name>.
1601
1602The return value is C<true> if this is a valid prototype, and
1603C<false> if it is not, regardless of whether C<warn> was C<true> or
1604C<false>.
1605
1606Note that C<NULL> is a valid C<proto> and will always return C<true>.
1607
1608=cut
1609
1610 */
1611
1612bool
1613Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1614{
1615 STRLEN len, origlen;
11327fa1 1616 char *p;
fe788d6b
PM
1617 bool bad_proto = FALSE;
1618 bool in_brackets = FALSE;
1619 bool after_slash = FALSE;
1620 char greedy_proto = ' ';
1621 bool proto_after_greedy_proto = FALSE;
1622 bool must_be_last = FALSE;
1623 bool underscore = FALSE;
f791a21a 1624 bool bad_proto_after_underscore = FALSE;
fe788d6b
PM
1625
1626 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1627
1628 if (!proto)
1629 return TRUE;
1630
11327fa1 1631 p = SvPV(proto, len);
fe788d6b
PM
1632 origlen = len;
1633 for (; len--; p++) {
1634 if (!isSPACE(*p)) {
1635 if (must_be_last)
1636 proto_after_greedy_proto = TRUE;
f791a21a
PM
1637 if (underscore) {
1638 if (!strchr(";@%", *p))
1639 bad_proto_after_underscore = TRUE;
1640 underscore = FALSE;
1641 }
fe788d6b
PM
1642 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1643 bad_proto = TRUE;
1644 }
1645 else {
fe788d6b
PM
1646 if (*p == '[')
1647 in_brackets = TRUE;
1648 else if (*p == ']')
1649 in_brackets = FALSE;
407f8cf2
KW
1650 else if ((*p == '@' || *p == '%')
1651 && !after_slash
1652 && !in_brackets )
1653 {
fe788d6b
PM
1654 must_be_last = TRUE;
1655 greedy_proto = *p;
1656 }
1657 else if (*p == '_')
f791a21a 1658 underscore = TRUE;
fe788d6b
PM
1659 }
1660 if (*p == '\\')
1661 after_slash = TRUE;
1662 else
1663 after_slash = FALSE;
1664 }
1665 }
1666
1667 if (warn) {
b54d603d 1668 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
fe788d6b 1669 p -= origlen;
b54d603d
PM
1670 p = SvUTF8(proto)
1671 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1672 origlen, UNI_DISPLAY_ISPRINT)
1673 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1674
fe788d6b
PM
1675 if (proto_after_greedy_proto)
1676 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
147e3846 1677 "Prototype after '%c' for %" SVf " : %s",
fe788d6b 1678 greedy_proto, SVfARG(name), p);
50278ed0
PM
1679 if (in_brackets)
1680 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
147e3846 1681 "Missing ']' in prototype for %" SVf " : %s",
50278ed0 1682 SVfARG(name), p);
b54d603d 1683 if (bad_proto)
fe788d6b 1684 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
147e3846 1685 "Illegal character in prototype for %" SVf " : %s",
f791a21a
PM
1686 SVfARG(name), p);
1687 if (bad_proto_after_underscore)
1688 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
147e3846 1689 "Illegal character after '_' in prototype for %" SVf " : %s",
f791a21a 1690 SVfARG(name), p);
fe788d6b
PM
1691 }
1692
1693 return (! (proto_after_greedy_proto || bad_proto) );
1694}
1695
1696/*
ffb4593c
NT
1697 * S_incline
1698 * This subroutine has nothing to do with tilting, whether at windmills
1699 * or pinball tables. Its name is short for "increment line". It
57843af0 1700 * increments the current line number in CopLINE(PL_curcop) and checks
ffb4593c 1701 * to see whether the line starts with a comment of the form
9cbb5ea2
GS
1702 * # line 500 "foo.pm"
1703 * If so, it sets the current line number and file to the values in the comment.
ffb4593c
NT
1704 */
1705
76e3520e 1706STATIC void
d9095cec 1707S_incline(pTHX_ const char *s)
463ee0b2 1708{
d9095cec
NC
1709 const char *t;
1710 const char *n;
1711 const char *e;
8818d409 1712 line_t line_num;
22ff3130 1713 UV uv;
463ee0b2 1714
7918f24d
NC
1715 PERL_ARGS_ASSERT_INCLINE;
1716
83944c01 1717 COPLINE_INC_WITH_HERELINES;
451f421f
FC
1718 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1719 && s+1 == PL_bufend && *s == ';') {
1720 /* fake newline in string eval */
1721 CopLINE_dec(PL_curcop);
1722 return;
1723 }
463ee0b2
LW
1724 if (*s++ != '#')
1725 return;
d4c19fe8
AL
1726 while (SPACE_OR_TAB(*s))
1727 s++;
847cc851 1728 if (strEQs(s, "line"))
73659bf1
GS
1729 s += 4;
1730 else
1731 return;
084592ab 1732 if (SPACE_OR_TAB(*s))
73659bf1 1733 s++;
4e553d73 1734 else
73659bf1 1735 return;
d4c19fe8
AL
1736 while (SPACE_OR_TAB(*s))
1737 s++;
463ee0b2
LW
1738 if (!isDIGIT(*s))
1739 return;
d4c19fe8 1740
463ee0b2
LW
1741 n = s;
1742 while (isDIGIT(*s))
1743 s++;
07714eb4 1744 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
26b6dc3f 1745 return;
bf4acbe4 1746 while (SPACE_OR_TAB(*s))
463ee0b2 1747 s++;
73659bf1 1748 if (*s == '"' && (t = strchr(s+1, '"'))) {
463ee0b2 1749 s++;
73659bf1
GS
1750 e = t + 1;
1751 }
463ee0b2 1752 else {
c35e046a 1753 t = s;
1bb1a3d6 1754 while (*t && !isSPACE(*t))
c35e046a 1755 t++;
73659bf1 1756 e = t;
463ee0b2 1757 }
bf4acbe4 1758 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
73659bf1
GS
1759 e++;
1760 if (*e != '\n' && *e != '\0')
1761 return; /* false alarm */
1762
22ff3130
HS
1763 if (!grok_atoUV(n, &uv, &e))
1764 return;
1765 line_num = ((line_t)uv) - 1;
8818d409 1766
f4dd75d9 1767 if (t - s > 0) {
d9095cec 1768 const STRLEN len = t - s;
3df32bda 1769
d36ee5be 1770 if (!PL_rsfp && !PL_parser->filtered) {
e66cf94c
RGS
1771 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1772 * to *{"::_<newfilename"} */
44867030
NC
1773 /* However, the long form of evals is only turned on by the
1774 debugger - usually they're "(eval %lu)" */
d36ee5be
FC
1775 GV * const cfgv = CopFILEGV(PL_curcop);
1776 if (cfgv) {
38bd7ad8
FC
1777 char smallbuf[128];
1778 STRLEN tmplen2 = len;
44867030 1779 char *tmpbuf2;
449dd039 1780 GV *gv2;
44867030
NC
1781
1782 if (tmplen2 + 2 <= sizeof smallbuf)
1783 tmpbuf2 = smallbuf;
1784 else
1785 Newx(tmpbuf2, tmplen2 + 2, char);
1786
38bd7ad8
FC
1787 tmpbuf2[0] = '_';
1788 tmpbuf2[1] = '<';
44867030
NC
1789
1790 memcpy(tmpbuf2 + 2, s, tmplen2);
1791 tmplen2 += 2;
1792
8a5ee598 1793 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
e5527e4b 1794 if (!isGV(gv2)) {
8a5ee598 1795 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
e5527e4b
RGS
1796 /* adjust ${"::_<newfilename"} to store the new file name */
1797 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
8818d409
FC
1798 /* The line number may differ. If that is the case,
1799 alias the saved lines that are in the array.
1800 Otherwise alias the whole array. */
1801 if (CopLINE(PL_curcop) == line_num) {
38bd7ad8
FC
1802 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1803 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
8818d409 1804 }
38bd7ad8
FC
1805 else if (GvAV(cfgv)) {
1806 AV * const av = GvAV(cfgv);
8818d409
FC
1807 const I32 start = CopLINE(PL_curcop)+1;
1808 I32 items = AvFILLp(av) - start;
1809 if (items > 0) {
1810 AV * const av2 = GvAVn(gv2);
1811 SV **svp = AvARRAY(av) + start;
1812 I32 l = (I32)line_num+1;
1813 while (items--)
1814 av_store(av2, l++, SvREFCNT_inc(*svp++));
1815 }
1816 }
e5527e4b 1817 }
44867030
NC
1818
1819 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
d36ee5be 1820 }
e66cf94c 1821 }
05ec9bb3 1822 CopFILE_free(PL_curcop);
449dd039 1823 CopFILE_setn(PL_curcop, s, len);
f4dd75d9 1824 }
8818d409 1825 CopLINE_set(PL_curcop, line_num);
463ee0b2
LW
1826}
1827
80a702cd 1828STATIC void
15f169a1 1829S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
80a702cd
RGS
1830{
1831 AV *av = CopFILEAVx(PL_curcop);
1832 if (av) {
7f1c3e8c
FC
1833 SV * sv;
1834 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1835 else {
1836 sv = *av_fetch(av, 0, 1);
1837 SvUPGRADE(sv, SVt_PVMG);
1838 }
847cc851 1839 if (!SvPOK(sv)) SvPVCLEAR(sv);
5fa550fb 1840 if (orig_sv)
7f1c3e8c 1841 sv_catsv(sv, orig_sv);
5fa550fb 1842 else
7f1c3e8c
FC
1843 sv_catpvn(sv, buf, len);
1844 if (!SvIOK(sv)) {
1845 (void)SvIOK_on(sv);
1846 SvIV_set(sv, 0);
1847 }
1848 if (PL_parser->preambling == NOLINE)
1849 av_store(av, CopLINE(PL_curcop), sv);
80a702cd
RGS
1850 }
1851}
1852
ffb4593c 1853/*
8c6b0c7d 1854 * skipspace
ffb4593c
NT
1855 * Called to gobble the appropriate amount and type of whitespace.
1856 * Skips comments as well.
71fff7cb 1857 * Returns the next character after the whitespace that is skipped.
8c6b0c7d
FC
1858 *
1859 * peekspace
1860 * Same thing, but look ahead without incrementing line numbers or
1861 * adjusting PL_linestart.
ffb4593c
NT
1862 */
1863
3218e223 1864#define skipspace(s) skipspace_flags(s, 0)
8c6b0c7d 1865#define peekspace(s) skipspace_flags(s, LEX_NO_INCLINE)
3218e223 1866
76e3520e 1867STATIC char *
21791330 1868S_skipspace_flags(pTHX_ char *s, U32 flags)
a687059c 1869{
21791330 1870 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
3280af22 1871 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3c47da3c 1872 while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s))
463ee0b2 1873 s++;
f0e67a1d
Z
1874 } else {
1875 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1876 PL_bufptr = s;
21791330 1877 lex_read_space(flags | LEX_KEEP_PREVIOUS |
d27f4b91 1878 (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ?
f0998909 1879 LEX_NO_NEXT_CHUNK : 0));
3280af22 1880 s = PL_bufptr;
f0e67a1d
Z
1881 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1882 if (PL_linestart > PL_bufptr)
1883 PL_bufptr = PL_linestart;
1884 return s;
463ee0b2 1885 }
5db06880 1886 return s;
a687059c 1887}
378cc40b 1888
ffb4593c
NT
1889/*
1890 * S_check_uni
1891 * Check the unary operators to ensure there's no ambiguity in how they're
1892 * used. An ambiguous piece of code would be:
1893 * rand + 5
1894 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1895 * the +5 is its argument.
1896 */
1897
76e3520e 1898STATIC void
cea2e8a9 1899S_check_uni(pTHX)
ba106d47 1900{
d4c19fe8
AL
1901 const char *s;
1902 const char *t;
2f3197b3 1903
3280af22 1904 if (PL_oldoldbufptr != PL_last_uni)
2f3197b3 1905 return;
3280af22
NIS
1906 while (isSPACE(*PL_last_uni))
1907 PL_last_uni++;
c35e046a 1908 s = PL_last_uni;
fac0f7a3 1909 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF) || *s == '-')
8ce2ba82 1910 s += UTF ? UTF8SKIP(s) : 1;
3280af22 1911 if ((t = strchr(s, '(')) && t < PL_bufptr)
a0d0e21e 1912 return;
6136c704 1913
9b387841 1914 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
147e3846 1915 "Warning: Use of \"%" UTF8f "\" without parentheses is ambiguous",
b59c097b 1916 UTF8fARG(UTF, (int)(s - PL_last_uni), PL_last_uni));
2f3197b3
LW
1917}
1918
ffb4593c
NT
1919/*
1920 * LOP : macro to build a list operator. Its behaviour has been replaced
1921 * with a subroutine, S_lop() for which LOP is just another name.
1922 */
1923
a0d0e21e
LW
1924#define LOP(f,x) return lop(f,x,s)
1925
ffb4593c
NT
1926/*
1927 * S_lop
1928 * Build a list operator (or something that might be one). The rules:
41e8cbf4
FC
1929 * - if we have a next token, then it's a list operator (no parens) for
1930 * which the next token has already been parsed; e.g.,
1931 * sort foo @args
1932 * sort foo (@args)
ffb4593c
NT
1933 * - if the next thing is an opening paren, then it's a function
1934 * - else it's a list operator
1935 */
1936
76e3520e 1937STATIC I32
11288bb3 1938S_lop(pTHX_ I32 f, U8 x, char *s)
ffed7fef 1939{
7918f24d
NC
1940 PERL_ARGS_ASSERT_LOP;
1941
6154021b 1942 pl_yylval.ival = f;
35c8bce7 1943 CLINE;
3280af22
NIS
1944 PL_bufptr = s;
1945 PL_last_lop = PL_oldbufptr;
eb160463 1946 PL_last_lop_op = (OPCODE)f;
3280af22 1947 if (PL_nexttoke)
78cdf107 1948 goto lstop;
19f1898a 1949 PL_expect = x;
79072805 1950 if (*s == '(')
bbf60fe6 1951 return REPORT(FUNC);
294a536f 1952 s = skipspace(s);
79072805 1953 if (*s == '(')
bbf60fe6 1954 return REPORT(FUNC);
78cdf107
Z
1955 else {
1956 lstop:
1957 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1958 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
bbf60fe6 1959 return REPORT(LSTOP);
78cdf107 1960 }
79072805
LW
1961}
1962
ffb4593c
NT
1963/*
1964 * S_force_next
9cbb5ea2 1965 * When the lexer realizes it knows the next token (for instance,
ffb4593c 1966 * it is reordering tokens for the parser) then it can call S_force_next
9cbb5ea2 1967 * to know what token to return the next time the lexer is called. Caller
b5bbe64a
JH
1968 * will need to set PL_nextval[] and possibly PL_expect to ensure
1969 * the lexer handles the token correctly.
ffb4593c
NT
1970 */
1971
4e553d73 1972STATIC void
cea2e8a9 1973S_force_next(pTHX_ I32 type)
79072805 1974{
704d4215
GG
1975#ifdef DEBUGGING
1976 if (DEBUG_T_TEST) {
1977 PerlIO_printf(Perl_debug_log, "### forced token:\n");
f05d7009 1978 tokereport(type, &NEXTVAL_NEXTTOKE);
704d4215
GG
1979 }
1980#endif
1f7c3e7c 1981 assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype));
3280af22
NIS
1982 PL_nexttype[PL_nexttoke] = type;
1983 PL_nexttoke++;
79072805
LW
1984}
1985
89f35911
FC
1986/*
1987 * S_postderef
1988 *
1989 * This subroutine handles postfix deref syntax after the arrow has already
1990 * been emitted. @* $* etc. are emitted as two separate token right here.
1991 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
1992 * only the first, leaving yylex to find the next.
89f35911
FC
1993 */
1994
1995static int
ff25e5db 1996S_postderef(pTHX_ int const funny, char const next)
89f35911 1997{
ff25e5db 1998 assert(funny == DOLSHARP || strchr("$@%&*", funny));
89f35911
FC
1999 if (next == '*') {
2000 PL_expect = XOPERATOR;
cc624add 2001 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
ff25e5db 2002 assert('@' == funny || '$' == funny || DOLSHARP == funny);
cc624add 2003 PL_lex_state = LEX_INTERPEND;
c3492809
FC
2004 if ('@' == funny)
2005 force_next(POSTJOIN);
cc624add 2006 }
89f35911
FC
2007 force_next(next);
2008 PL_bufptr+=2;
2009 }
2010 else {
760ca746
FC
2011 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
2012 && !PL_lex_brackets)
2013 PL_lex_dojoin = 2;
89f35911
FC
2014 PL_expect = XOPERATOR;
2015 PL_bufptr++;
2016 }
2017 return funny;
2018}
2019
28ac2b49
Z
2020void
2021Perl_yyunlex(pTHX)
2022{
a7aaec61
Z
2023 int yyc = PL_parser->yychar;
2024 if (yyc != YYEMPTY) {
2025 if (yyc) {
a7aaec61
Z
2026 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2027 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
78cdf107 2028 PL_lex_allbrackets--;
a7aaec61 2029 PL_lex_brackets--;
78cdf107
Z
2030 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2031 } else if (yyc == '('/*)*/) {
2032 PL_lex_allbrackets--;
2033 yyc |= (2<<24);
a7aaec61
Z
2034 }
2035 force_next(yyc);
2036 }
28ac2b49
Z
2037 PL_parser->yychar = YYEMPTY;
2038 }
2039}
2040
d0a148a6 2041STATIC SV *
15f169a1 2042S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
d0a148a6 2043{
740cce10 2044 SV * const sv = newSVpvn_utf8(start, len,
c5f058df
KW
2045 !IN_BYTES
2046 && UTF
2047 && !is_utf8_invariant_string((const U8*)start, len)
2048 && is_utf8_string((const U8*)start, len));
d0a148a6
NC
2049 return sv;
2050}
2051
ffb4593c
NT
2052/*
2053 * S_force_word
2054 * When the lexer knows the next thing is a word (for instance, it has
2055 * just seen -> and it knows that the next char is a word char, then
02b34bbe
DM
2056 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2057 * lookahead.
ffb4593c
NT
2058 *
2059 * Arguments:
b1b65b59 2060 * char *start : buffer position (must be within PL_linestr)
185c2e96
DM
2061 * int token : PL_next* will be this type of bare word
2062 * (e.g., METHOD,BAREWORD)
ffb4593c
NT
2063 * int check_keyword : if true, Perl checks to make sure the word isn't
2064 * a keyword (do this if the word is a label, e.g. goto FOO)
2065 * int allow_pack : if true, : characters will also be allowed (require,
2066 * use, etc. do this)
ffb4593c
NT
2067 */
2068
76e3520e 2069STATIC char *
345b3785 2070S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
79072805 2071{
eb578fdb 2072 char *s;
463ee0b2 2073 STRLEN len;
4e553d73 2074
7918f24d
NC
2075 PERL_ARGS_ASSERT_FORCE_WORD;
2076
294a536f 2077 start = skipspace(start);
463ee0b2 2078 s = start;
fac0f7a3 2079 if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
e7127e21 2080 || (allow_pack && *s == ':' && s[1] == ':') )
a0d0e21e 2081 {
3280af22 2082 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
01b5ef50
FC
2083 if (check_keyword) {
2084 char *s2 = PL_tokenbuf;
487e470d 2085 STRLEN len2 = len;
847cc851 2086 if (allow_pack && len > 6 && strEQs(s2, "CORE::"))
487e470d
FC
2087 s2 += 6, len2 -= 6;
2088 if (keyword(s2, len2, 0))
463ee0b2 2089 return start;
01b5ef50 2090 }
463ee0b2 2091 if (token == METHOD) {
294a536f 2092 s = skipspace(s);
463ee0b2 2093 if (*s == '(')
3280af22 2094 PL_expect = XTERM;
463ee0b2 2095 else {
3280af22 2096 PL_expect = XOPERATOR;
463ee0b2 2097 }
79072805 2098 }
9ded7720 2099 NEXTVAL_NEXTTOKE.opval
275103cd 2100 = newSVOP(OP_CONST,0,
d0a148a6 2101 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
9ded7720 2102 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
79072805
LW
2103 force_next(token);
2104 }
2105 return s;
2106}
2107
ffb4593c
NT
2108/*
2109 * S_force_ident
9cbb5ea2 2110 * Called when the lexer wants $foo *foo &foo etc, but the program
ffb4593c
NT
2111 * text only contains the "foo" portion. The first argument is a pointer
2112 * to the "foo", and the second argument is the type symbol to prefix.
185c2e96 2113 * Forces the next token to be a "BAREWORD".
9cbb5ea2 2114 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
ffb4593c
NT
2115 */
2116
76e3520e 2117STATIC void
5aaab254 2118S_force_ident(pTHX_ const char *s, int kind)
79072805 2119{
7918f24d
NC
2120 PERL_ARGS_ASSERT_FORCE_IDENT;
2121
c9b48522
DD
2122 if (s[0]) {
2123 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
275103cd 2124 OP* const o = newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
728847b1 2125 UTF ? SVf_UTF8 : 0));
9ded7720 2126 NEXTVAL_NEXTTOKE.opval = o;
185c2e96 2127 force_next(BAREWORD);
748a9306 2128 if (kind) {
11343788 2129 o->op_private = OPpCONST_ENTERED;
55497cff
PP
2130 /* XXX see note in pp_entereval() for why we forgo typo
2131 warnings if the symbol must be introduced in an eval.
2132 GSAR 96-10-12 */
90e5519e 2133 gv_fetchpvn_flags(s, len,
4bff32c5 2134 (PL_in_eval ? GV_ADDMULTI
728847b1 2135 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
90e5519e
NC
2136 kind == '$' ? SVt_PV :
2137 kind == '@' ? SVt_PVAV :
2138 kind == '%' ? SVt_PVHV :
a0d0e21e 2139 SVt_PVGV
90e5519e 2140 );
748a9306 2141 }
79072805
LW
2142 }
2143}
2144
3f33d153
FC
2145static void
2146S_force_ident_maybe_lex(pTHX_ char pit)
2147{
3f33d153
FC
2148 NEXTVAL_NEXTTOKE.ival = pit;
2149 force_next('p');
2150}
2151
1571675a
GS
2152NV
2153Perl_str_to_version(pTHX_ SV *sv)
2154{
2155 NV retval = 0.0;
2156 NV nshift = 1.0;
2157 STRLEN len;
cfd0369c 2158 const char *start = SvPV_const(sv,len);
9d4ba2ae 2159 const char * const end = start + len;
8298454c 2160 const bool utf = cBOOL(SvUTF8(sv));
7918f24d
NC
2161
2162 PERL_ARGS_ASSERT_STR_TO_VERSION;
2163
1571675a 2164 while (start < end) {
ba210ebe 2165 STRLEN skip;
1571675a
GS
2166 UV n;
2167 if (utf)
9041c2e3 2168 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1571675a
GS
2169 else {
2170 n = *(U8*)start;
2171 skip = 1;
2172 }
2173 retval += ((NV)n)/nshift;
2174 start += skip;
2175 nshift *= 1000;
2176 }
2177 return retval;
2178}
2179
4e553d73 2180/*
ffb4593c
NT
2181 * S_force_version
2182 * Forces the next token to be a version number.
e759cc13
RGS
2183 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2184 * and if "guessing" is TRUE, then no new token is created (and the caller
2185 * must use an alternative parsing method).
ffb4593c
NT
2186 */
2187
76e3520e 2188STATIC char *
e759cc13 2189S_force_version(pTHX_ char *s, int guessing)
89bfa8cd 2190{
5f66b61c 2191 OP *version = NULL;
44dcb63b 2192 char *d;
89bfa8cd 2193
7918f24d
NC
2194 PERL_ARGS_ASSERT_FORCE_VERSION;
2195
294a536f 2196 s = skipspace(s);
89bfa8cd 2197
44dcb63b 2198 d = s;
dd629d5b 2199 if (*d == 'v')
44dcb63b 2200 d++;
44dcb63b 2201 if (isDIGIT(*d)) {
e759cc13
RGS
2202 while (isDIGIT(*d) || *d == '_' || *d == '.')
2203 d++;
4e4da3ac 2204 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
dd629d5b 2205 SV *ver;
6154021b
RGS
2206 s = scan_num(s, &pl_yylval);
2207 version = pl_yylval.opval;
dd629d5b
GS
2208 ver = cSVOPx(version)->op_sv;
2209 if (SvPOK(ver) && !SvNIOK(ver)) {
862a34c6 2210 SvUPGRADE(ver, SVt_PVNV);
9d6ce603 2211 SvNV_set(ver, str_to_version(ver));
1571675a 2212 SvNOK_on(ver); /* hint that it is a version */
44dcb63b 2213 }
89bfa8cd 2214 }
5db06880 2215 else if (guessing) {
e759cc13 2216 return s;
5db06880 2217 }
89bfa8cd
PP
2218 }
2219
2220 /* NOTE: The parser sees the package name and the VERSION swapped */
9ded7720 2221 NEXTVAL_NEXTTOKE.opval = version;
185c2e96 2222 force_next(BAREWORD);
89bfa8cd 2223
e759cc13 2224 return s;
89bfa8cd
PP
2225}
2226
ffb4593c 2227/*
91152fc1
DG
2228 * S_force_strict_version
2229 * Forces the next token to be a version number using strict syntax rules.
2230 */
2231
2232STATIC char *
2233S_force_strict_version(pTHX_ char *s)
2234{
91152fc1 2235 OP *version = NULL;
91152fc1
DG
2236 const char *errstr = NULL;
2237
2238 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2239
2240 while (isSPACE(*s)) /* leading whitespace */
2241 s++;
2242
2243 if (is_STRICT_VERSION(s,&errstr)) {
2244 SV *ver = newSV(0);
2245 s = (char *)scan_version(s, ver, 0);
2246 version = newSVOP(OP_CONST, 0, ver);
2247 }
407f8cf2
KW
2248 else if ((*s != ';' && *s != '{' && *s != '}' )
2249 && (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
4e4da3ac 2250 {
91152fc1
DG
2251 PL_bufptr = s;
2252 if (errstr)
2253 yyerror(errstr); /* version required */
2254 return s;
2255 }
2256
91152fc1 2257 /* NOTE: The parser sees the package name and the VERSION swapped */
91152fc1 2258 NEXTVAL_NEXTTOKE.opval = version;
185c2e96 2259 force_next(BAREWORD);
91152fc1
DG
2260
2261 return s;
2262}
2263
2264/*
ffb4593c
NT
2265 * S_tokeq
2266 * Tokenize a quoted string passed in as an SV. It finds the next
2267 * chunk, up to end of string or a backslash. It may make a new
2268 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2269 * turns \\ into \.
2270 */
2271
76e3520e 2272STATIC SV *
cea2e8a9 2273S_tokeq(pTHX_ SV *sv)
79072805 2274{
eb578fdb
KW
2275 char *s;
2276 char *send;
2277 char *d;
b3ac6de7 2278 SV *pv = sv;
79072805 2279
7918f24d
NC
2280 PERL_ARGS_ASSERT_TOKEQ;
2281
279b35ad
FC
2282 assert (SvPOK(sv));
2283 assert (SvLEN(sv));
2284 assert (!SvIsCOW(sv));
307ed071 2285 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
b3ac6de7 2286 goto finish;
279b35ad
FC
2287 s = SvPVX(sv);
2288 send = SvEND(sv);
dcb21ed6
NC
2289 /* This is relying on the SV being "well formed" with a trailing '\0' */
2290 while (s < send && !(*s == '\\' && s[1] == '\\'))
79072805
LW
2291 s++;
2292 if (s == send)
b3ac6de7 2293 goto finish;
79072805 2294 d = s;
be4731d2 2295 if ( PL_hints & HINT_NEW_STRING ) {
279b35ad
FC
2296 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2297 SVs_TEMP | SvUTF8(sv));
be4731d2 2298 }
79072805
LW
2299 while (s < send) {
2300 if (*s == '\\') {
a0d0e21e 2301 if (s + 1 < send && (s[1] == '\\'))
79072805
LW
2302 s++; /* all that, just for this */
2303 }
2304 *d++ = *s++;
2305 }
2306 *d = '\0';
95a20fc0 2307 SvCUR_set(sv, d - SvPVX_const(sv));
b3ac6de7 2308 finish:
3280af22 2309 if ( PL_hints & HINT_NEW_STRING )
eb0d8d16 2310 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
79072805
LW
2311 return sv;
2312}
2313
ffb4593c
NT
2314/*
2315 * Now come three functions related to double-quote context,
2316 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2317 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2318 * interact with PL_lex_state, and create fake ( ... ) argument lists
2319 * to handle functions and concatenation.
ecd24171
DM
2320 * For example,
2321 * "foo\lbar"
2322 * is tokenised as
2323 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
ffb4593c
NT
2324 */
2325
2326/*
2327 * S_sublex_start
6154021b 2328 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
ffb4593c
NT
2329 *
2330 * Pattern matching will set PL_lex_op to the pattern-matching op to
6154021b 2331 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
ffb4593c 2332 *
16d1d8bd 2333 * OP_CONST is easy--just make the new op and return.
ffb4593c
NT
2334 *
2335 * Everything else becomes a FUNC.
2336 *
16d1d8bd
LM
2337 * Sets PL_lex_state to LEX_INTERPPUSH unless ival was OP_NULL or we
2338 * had an OP_CONST. This just sets us up for a
ffb4593c
NT
2339 * call to S_sublex_push().
2340 */
2341
76e3520e 2342STATIC I32
cea2e8a9 2343S_sublex_start(pTHX)
79072805 2344{
eb578fdb 2345 const I32 op_type = pl_yylval.ival;
79072805
LW
2346
2347 if (op_type == OP_NULL) {
6154021b 2348 pl_yylval.opval = PL_lex_op;
5f66b61c 2349 PL_lex_op = NULL;
79072805
LW
2350 return THING;
2351 }
466112bb 2352 if (op_type == OP_CONST) {
67c71cbb
FC
2353 SV *sv = PL_lex_stuff;
2354 PL_lex_stuff = NULL;
2355 sv = tokeq(sv);
b3ac6de7
IZ
2356
2357 if (SvTYPE(sv) == SVt_PVIV) {
2358 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2359 STRLEN len;
96a5add6 2360 const char * const p = SvPV_const(sv, len);
740cce10 2361 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
b3ac6de7
IZ
2362 SvREFCNT_dec(sv);
2363 sv = nsv;
4e553d73 2364 }
275103cd 2365 pl_yylval.opval = newSVOP(op_type, 0, sv);
79072805
LW
2366 return THING;
2367 }
2368
7ef70b3d
FC
2369 PL_parser->lex_super_state = PL_lex_state;
2370 PL_parser->lex_sub_inwhat = (U16)op_type;
2371 PL_parser->lex_sub_op = PL_lex_op;
3280af22 2372 PL_lex_state = LEX_INTERPPUSH;
55497cff 2373
3280af22
NIS
2374 PL_expect = XTERM;
2375 if (PL_lex_op) {
6154021b 2376 pl_yylval.opval = PL_lex_op;
5f66b61c 2377 PL_lex_op = NULL;
55497cff
PP
2378 return PMFUNC;
2379 }
2380 else
2381 return FUNC;
2382}
2383
ffb4593c
NT
2384/*
2385 * S_sublex_push
2386 * Create a new scope to save the lexing state. The scope will be
2387 * ended in S_sublex_done. Returns a '(', starting the function arguments
2388 * to the uc, lc, etc. found before.
2389 * Sets PL_lex_state to LEX_INTERPCONCAT.
2390 */
2391
76e3520e 2392STATIC I32
cea2e8a9 2393S_sublex_push(pTHX)
55497cff 2394{
78a635de 2395 LEXSHARED *shared;
801d32ac 2396 const bool is_heredoc = PL_multi_close == '<';
f46d017c 2397 ENTER;
55497cff 2398
7ef70b3d 2399 PL_lex_state = PL_parser->lex_super_state;
cc624add 2400 SAVEI8(PL_lex_dojoin);
3280af22 2401 SAVEI32(PL_lex_brackets);
78cdf107 2402 SAVEI32(PL_lex_allbrackets);
b27dce25 2403 SAVEI32(PL_lex_formbrack);
78cdf107 2404 SAVEI8(PL_lex_fakeeof);
3280af22
NIS
2405 SAVEI32(PL_lex_casemods);
2406 SAVEI32(PL_lex_starts);
651b5b28 2407 SAVEI8(PL_lex_state);
7cc34111 2408 SAVESPTR(PL_lex_repl);
7766f137 2409 SAVEVPTR(PL_lex_inpat);
98246f1e 2410 SAVEI16(PL_lex_inwhat);
ffdb8b16 2411 if (is_heredoc)
b42366d4 2412 {
ffdb8b16 2413 SAVECOPLINE(PL_curcop);
b42366d4 2414 SAVEI32(PL_multi_end);
851b527a
FC
2415 SAVEI32(PL_parser->herelines);
2416 PL_parser->herelines = 0;
b42366d4 2417 }
2ca4363d 2418 SAVEIV(PL_multi_close);
3280af22 2419 SAVEPPTR(PL_bufptr);
8452ff4b 2420 SAVEPPTR(PL_bufend);
3280af22
NIS
2421 SAVEPPTR(PL_oldbufptr);
2422 SAVEPPTR(PL_oldoldbufptr);
207e3d1a
JH
2423 SAVEPPTR(PL_last_lop);
2424 SAVEPPTR(PL_last_uni);
3280af22
NIS
2425 SAVEPPTR(PL_linestart);
2426 SAVESPTR(PL_linestr);
8edd5f42
RGS
2427 SAVEGENERICPV(PL_lex_brackstack);
2428 SAVEGENERICPV(PL_lex_casestack);
78a635de 2429 SAVEGENERICPV(PL_parser->lex_shared);
3a54fd60 2430 SAVEBOOL(PL_parser->lex_re_reparsing);
ffdb8b16 2431 SAVEI32(PL_copline);
3280af22 2432
99bd9d90 2433 /* The here-doc parser needs to be able to peek into outer lexing
60f40a38
FC
2434 scopes to find the body of the here-doc. So we put PL_linestr and
2435 PL_bufptr into lex_shared, to ‘share’ those values.
99bd9d90 2436 */
60f40a38
FC
2437 PL_parser->lex_shared->ls_linestr = PL_linestr;
2438 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
99bd9d90 2439
3280af22 2440 PL_linestr = PL_lex_stuff;
7ef70b3d 2441 PL_lex_repl = PL_parser->lex_sub_repl;
a0714e2c 2442 PL_lex_stuff = NULL;
7ef70b3d 2443 PL_parser->lex_sub_repl = NULL;
3280af22 2444
eabab8bc
FC
2445 /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2446 set for an inner quote-like operator and then an error causes scope-
2447 popping. We must not have a PL_lex_stuff value left dangling, as
2448 that breaks assumptions elsewhere. See bug #123617. */
2449 SAVEGENERICSV(PL_lex_stuff);
7ef70b3d 2450 SAVEGENERICSV(PL_parser->lex_sub_repl);
eabab8bc 2451
9cbb5ea2
GS
2452 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2453 = SvPVX(PL_linestr);
3280af22 2454 PL_bufend += SvCUR(PL_linestr);
bd61b366 2455 PL_last_lop = PL_last_uni = NULL;
3280af22 2456 SAVEFREESV(PL_linestr);
4dc843bc 2457 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
3280af22
NIS
2458
2459 PL_lex_dojoin = FALSE;
b27dce25 2460 PL_lex_brackets = PL_lex_formbrack = 0;
78cdf107
Z
2461 PL_lex_allbrackets = 0;
2462 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
a02a5408
JC
2463 Newx(PL_lex_brackstack, 120, char);
2464 Newx(PL_lex_casestack, 12, char);
3280af22
NIS
2465 PL_lex_casemods = 0;
2466 *PL_lex_casestack = '\0';
2467 PL_lex_starts = 0;
2468 PL_lex_state = LEX_INTERPCONCAT;
ffdb8b16 2469 if (is_heredoc)
6ddcf93b 2470 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
ffdb8b16 2471 PL_copline = NOLINE;
caae0700 2472
78a635de
FC
2473 Newxz(shared, 1, LEXSHARED);
2474 shared->ls_prev = PL_parser->lex_shared;
2475 PL_parser->lex_shared = shared;
3280af22 2476
7ef70b3d 2477 PL_lex_inwhat = PL_parser->lex_sub_inwhat;
bb16bae8 2478 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
3280af22 2479 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
7ef70b3d 2480 PL_lex_inpat = PL_parser->lex_sub_op;
79072805 2481 else
5f66b61c 2482 PL_lex_inpat = NULL;
79072805 2483
3a54fd60
DM
2484 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2485 PL_in_eval &= ~EVAL_RE_REPARSING;
2486
55497cff 2487 return '(';
79072805
LW
2488}
2489
ffb4593c
NT
2490/*
2491 * S_sublex_done
2492 * Restores lexer state after a S_sublex_push.
2493 */
2494
76e3520e 2495STATIC I32
cea2e8a9 2496S_sublex_done(pTHX)
79072805 2497{
3280af22 2498 if (!PL_lex_starts++) {
396482e1 2499 SV * const sv = newSVpvs("");
9aa983d2
JH
2500 if (SvUTF8(PL_linestr))
2501 SvUTF8_on(sv);
3280af22 2502 PL_expect = XOPERATOR;
275103cd 2503 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
79072805
LW
2504 return THING;
2505 }
2506
3280af22
NIS
2507 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2508 PL_lex_state = LEX_INTERPCASEMOD;
cea2e8a9 2509 return yylex();
79072805
LW
2510 }
2511
ffb4593c 2512 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
bb16bae8 2513 assert(PL_lex_inwhat != OP_TRANSR);
5aa91856
FC
2514 if (PL_lex_repl) {
2515 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
3280af22
NIS
2516 PL_linestr = PL_lex_repl;
2517 PL_lex_inpat = 0;
2518 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2519 PL_bufend += SvCUR(PL_linestr);
bd61b366 2520 PL_last_lop = PL_last_uni = NULL;
3280af22
NIS
2521 PL_lex_dojoin = FALSE;
2522 PL_lex_brackets = 0;
78cdf107
Z
2523 PL_lex_allbrackets = 0;
2524 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
3280af22
NIS
2525 PL_lex_casemods = 0;
2526 *PL_lex_casestack = '\0';
2527 PL_lex_starts = 0;
25da4f38 2528 if (SvEVALED(PL_lex_repl)) {
3280af22
NIS
2529 PL_lex_state = LEX_INTERPNORMAL;
2530 PL_lex_starts++;
e9fa98b2
HS
2531 /* we don't clear PL_lex_repl here, so that we can check later
2532 whether this is an evalled subst; that means we rely on the
2533 logic to ensure sublex_done() is called again only via the
2534 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
79072805 2535 }
e9fa98b2 2536 else {
3280af22 2537 PL_lex_state = LEX_INTERPCONCAT;
a0714e2c 2538 PL_lex_repl = NULL;
e9fa98b2 2539 }
ffdb8b16
FC
2540 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2541 CopLINE(PL_curcop) +=
9420b268 2542 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xnv_lines
851b527a
FC
2543 + PL_parser->herelines;
2544 PL_parser->herelines = 0;
ffdb8b16 2545 }
9b6b7be8 2546 return '/';
ffed7fef
LW
2547 }
2548 else {
b42366d4 2549 const line_t l = CopLINE(PL_curcop);
f46d017c 2550 LEAVE;
b42366d4 2551 if (PL_multi_close == '<')
851b527a 2552 PL_parser->herelines += l - PL_multi_end;
3280af22
NIS
2553 PL_bufend = SvPVX(PL_linestr);
2554 PL_bufend += SvCUR(PL_linestr);
2555 PL_expect = XOPERATOR;
79072805 2556 return ')';
ffed7fef
LW
2557 }
2558}
2559
7a7d14f3 2560STATIC SV*
6f613c73
KW
2561S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2562{
140b12ad
KW
2563 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2564 * interior, hence to the "}". Finds what the name resolves to, returning
2565 * an SV* containing it; NULL if no valid one found */
2566
dd2b1b72 2567 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
6f613c73 2568
0c415a79
KW
2569 HV * table;
2570 SV **cvp;
2571 SV *cv;
2572 SV *rv;
2573 HV *stash;
2574 const U8* first_bad_char_loc;
2575 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2576
6f613c73
KW
2577 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2578
d8d26cac 2579 if (!SvCUR(res)) {
db99d38d 2580 deprecate_fatal_in("5.28", "Unknown charname '' is deprecated");
b7e6151c 2581 return res;
d8d26cac 2582 }
b7e6151c 2583
107160e2
KW
2584 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2585 e - backslash_ptr,
2586 &first_bad_char_loc))
2587 {
75219bac
KW
2588 _force_out_malformed_utf8_message(first_bad_char_loc,
2589 (U8 *) PL_parser->bufend,
2590 0,
2591 0 /* 0 means don't die */ );
b59c097b 2592 yyerror_pv(Perl_form(aTHX_
107160e2 2593 "Malformed UTF-8 character immediately after '%.*s'",
b59c097b
AV
2594 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr),
2595 SVf_UTF8);
107160e2
KW
2596 return NULL;
2597 }
2598
2599 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2600 /* include the <}> */
2601 e - backslash_ptr + 1);
6f613c73 2602 if (! SvPOK(res)) {
b6407c49 2603 SvREFCNT_dec_NN(res);
6f613c73
KW
2604 return NULL;
2605 }
2606
0c415a79
KW
2607 /* See if the charnames handler is the Perl core's, and if so, we can skip
2608 * the validation needed for a user-supplied one, as Perl's does its own
2609 * validation. */
2610 table = GvHV(PL_hintgv); /* ^H */
2611 cvp = hv_fetchs(table, "charnames", FALSE);
5882ddb3
FC
2612 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2613 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
0c415a79
KW
2614 {
2615 const char * const name = HvNAME(stash);
6a642c21
FC
2616 if (HvNAMELEN(stash) == sizeof("_charnames")-1
2617 && strEQ(name, "_charnames")) {
0c415a79
KW
2618 return res;
2619 }
2620 }
2621
bde9e88d
KW
2622 /* Here, it isn't Perl's charname handler. We can't rely on a
2623 * user-supplied handler to validate the input name. For non-ut8 input,
2624 * look to see that the first character is legal. Then loop through the
2625 * rest checking that each is a continuation */
6f613c73 2626
36897d64
KW
2627 /* This code makes the reasonable assumption that the only Latin1-range
2628 * characters that begin a character name alias are alphabetic, otherwise
2629 * would have to create a isCHARNAME_BEGIN macro */
b6ba1137 2630
b6ba1137 2631 if (! UTF) {
bde9e88d 2632 if (! isALPHAU(*s)) {
b6ba1137
KW
2633 goto bad_charname;
2634 }
bde9e88d
KW
2635 s++;
2636 while (s < e) {
2637 if (! isCHARNAME_CONT(*s)) {
b6ba1137
KW
2638 goto bad_charname;
2639 }
2d8eb851
KW
2640 if (*s == ' ' && *(s-1) == ' ') {
2641 goto multi_spaces;
bd299e29 2642 }
bde9e88d 2643 s++;
b6ba1137
KW
2644 }
2645 }
2646 else {
bde9e88d
KW
2647 /* Similarly for utf8. For invariants can check directly; for other
2648 * Latin1, can calculate their code point and check; otherwise use a
2649 * swash */
2650 if (UTF8_IS_INVARIANT(*s)) {
2651 if (! isALPHAU(*s)) {
140b12ad
KW
2652 goto bad_charname;
2653 }
bde9e88d
KW
2654 s++;
2655 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
a62b247b 2656 if (! isALPHAU(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1)))) {
b6ba1137 2657 goto bad_charname;
6f613c73 2658 }
bde9e88d 2659 s += 2;
6f613c73 2660 }
bde9e88d
KW
2661 else {
2662 if (! PL_utf8_charname_begin) {
2663 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2664 PL_utf8_charname_begin = _core_swash_init("utf8",
2665 "_Perl_Charname_Begin",
2666 &PL_sv_undef,
2667 1, 0, NULL, &flags);
2668 }
2669 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2670 goto bad_charname;
2671 }
2672 s += UTF8SKIP(s);
2673 }
2674
2675 while (s < e) {
2676 if (UTF8_IS_INVARIANT(*s)) {
2677 if (! isCHARNAME_CONT(*s)) {
2678 goto bad_charname;
2679 }
2d8eb851
KW
2680 if (*s == ' ' && *(s-1) == ' ') {
2681 goto multi_spaces;
bd299e29 2682 }
bde9e88d
KW
2683 s++;
2684 }
2685 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
a62b247b 2686 if (! isCHARNAME_CONT(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1))))
bde9e88d
KW
2687 {
2688 goto bad_charname;
2689 }
2690 s += 2;
2691 }
2692 else {
2693 if (! PL_utf8_charname_continue) {
2694 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2695 PL_utf8_charname_continue = _core_swash_init("utf8",
2696 "_Perl_Charname_Continue",
2697 &PL_sv_undef,
2698 1, 0, NULL, &flags);
2699 }
2700 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2701 goto bad_charname;
2702 }
2703 s += UTF8SKIP(s);
6f613c73
KW
2704 }
2705 }
2d8eb851
KW
2706 }
2707 if (*(s-1) == ' ') {
2708 yyerror_pv(
2709 Perl_form(aTHX_
2710 "charnames alias definitions may not contain trailing "
2711 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2712 (int)(s - backslash_ptr + 1), backslash_ptr,
2713 (int)(e - s + 1), s + 1
2714 ),
2715 UTF ? SVf_UTF8 : 0);
2716 return NULL;
6f613c73
KW
2717 }
2718
94ca1619 2719 if (SvUTF8(res)) { /* Don't accept malformed input */
bde9e88d
KW
2720 const U8* first_bad_char_loc;
2721 STRLEN len;
2722 const char* const str = SvPV_const(res, len);
2723 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
75219bac
KW
2724 _force_out_malformed_utf8_message(first_bad_char_loc,
2725 (U8 *) PL_parser->bufend,
2726 0,
2727 0 /* 0 means don't die */ );
bde9e88d
KW
2728 yyerror_pv(
2729 Perl_form(aTHX_
2730 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2731 (int) (e - backslash_ptr + 1), backslash_ptr,
2732 (int) ((char *) first_bad_char_loc - str), str
2733 ),
2734 SVf_UTF8);
2735 return NULL;
2736 }
2737 }
140b12ad 2738
bde9e88d 2739 return res;
140b12ad 2740
bde9e88d 2741 bad_charname: {
bde9e88d
KW
2742
2743 /* The final %.*s makes sure that should the trailing NUL be missing
2744 * that this print won't run off the end of the string */
2745 yyerror_pv(
2746 Perl_form(aTHX_
2747 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2d8eb851
KW
2748 (int)(s - backslash_ptr + 1), backslash_ptr,
2749 (int)(e - s + 1), s + 1
bde9e88d
KW
2750 ),
2751 UTF ? SVf_UTF8 : 0);
2752 return NULL;
2753 }
2d8eb851
KW
2754
2755 multi_spaces:
2756 yyerror_pv(
2757 Perl_form(aTHX_
2758 "charnames alias definitions may not contain a sequence of "
2759 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2760 (int)(s - backslash_ptr + 1), backslash_ptr,
2761 (int)(e - s + 1), s + 1
2762 ),
2763 UTF ? SVf_UTF8 : 0);
2764 return NULL;
6f613c73
KW
2765}
2766
02aa26ce
NT
2767/*
2768 scan_const
2769
9da1dd8f
DM
2770 Extracts the next constant part of a pattern, double-quoted string,
2771 or transliteration. This is terrifying code.
2772
2773 For example, in parsing the double-quoted string "ab\x63$d", it would
2774 stop at the '$' and return an OP_CONST containing 'abc'.
02aa26ce 2775
94def140 2776 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
3280af22 2777 processing a pattern (PL_lex_inpat is true), a transliteration
94def140 2778 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
02aa26ce 2779
94def140
ST
2780 Returns a pointer to the character scanned up to. If this is
2781 advanced from the start pointer supplied (i.e. if anything was
9da1dd8f 2782 successfully parsed), will leave an OP_CONST for the substring scanned
6154021b 2783 in pl_yylval. Caller must intuit reason for not parsing further
9b599b2a
GS
2784 by looking at the next characters herself.
2785
02aa26ce 2786 In patterns:
9da1dd8f 2787 expand:
537124e4
KW
2788 \N{FOO} => \N{U+hex_for_character_FOO}
2789 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
9da1dd8f
DM
2790
2791 pass through:
2792 all other \-char, including \N and \N{ apart from \N{ABC}
2793
2794 stops on:
2795 @ and $ where it appears to be a var, but not for $ as tail anchor
2796 \l \L \u \U \Q \E
2797 (?{ or (??{
2798
02aa26ce
NT
2799 In transliterations:
2800 characters are VERY literal, except for - not at the start or end
66b09263
KW
2801 of the string, which indicates a range. However some backslash sequences
2802 are recognized: \r, \n, and the like
2803 \007 \o{}, \x{}, \N{}
2804 If all elements in the transliteration are below 256,
94def140
ST
2805 scan_const expands the range to the full set of intermediate
2806 characters. If the range is in utf8, the hyphen is replaced with
2807 a certain range mark which will be handled by pmtrans() in op.c.
02aa26ce
NT
2808
2809 In double-quoted strings:
2810 backslashes:
66b09263 2811 all those recognized in transliterations
94def140 2812 deprecated backrefs: \1 (in substitution replacements)
02aa26ce
NT
2813 case and quoting: \U \Q \E
2814 stops on @ and $
2815
2816 scan_const does *not* construct ops to handle interpolated strings.
2817 It stops processing as soon as it finds an embedded $ or @ variable
2818 and leaves it to the caller to work out what's going on.
2819
94def140
ST
2820 embedded arrays (whether in pattern or not) could be:
2821 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2822
2823 $ in double-quoted strings must be the symbol of an embedded scalar.
02aa26ce
NT
2824
2825 $ in pattern could be $foo or could be tail anchor. Assumption:
2826 it's a tail anchor if $ is the last thing in the string, or if it's
94def140 2827 followed by one of "()| \r\n\t"
02aa26ce 2828
9da1dd8f 2829 \1 (backreferences) are turned into $1 in substitutions
02aa26ce
NT
2830
2831 The structure of the code is
2832 while (there's a character to process) {
94def140
ST
2833 handle transliteration ranges
2834 skip regexp comments /(?#comment)/ and codes /(?{code})/
2835 skip #-initiated comments in //x patterns
2836 check for embedded arrays
02aa26ce
NT
2837 check for embedded scalars
2838 if (backslash) {
94def140 2839 deprecate \1 in substitution replacements
02aa26ce
NT
2840 handle string-changing backslashes \l \U \Q \E, etc.
2841 switch (what was escaped) {
94def140 2842 handle \- in a transliteration (becomes a literal -)
ff3f963a 2843 if a pattern and not \N{, go treat as regular character
94def140
ST
2844 handle \132 (octal characters)
2845 handle \x15 and \x{1234} (hex characters)
ff3f963a 2846 handle \N{name} (named characters, also \N{3,5} in a pattern)
94def140
ST
2847 handle \cV (control characters)
2848 handle printf-style backslashes (\f, \r, \n, etc)
02aa26ce 2849 } (end switch)
77a135fe 2850 continue
02aa26ce 2851 } (end if backslash)
77a135fe 2852 handle regular character
02aa26ce 2853 } (end while character to read)
02cd137d 2854
02aa26ce
NT
2855*/
2856
76e3520e 2857STATIC char *
cea2e8a9 2858S_scan_const(pTHX_ char *start)
79072805 2859{
eb578fdb 2860 char *send = PL_bufend; /* end of the constant */
dc023dbb
KW
2861 SV *sv = newSV(send - start); /* sv for the constant. See note below
2862 on sizing. */
eb578fdb
KW
2863 char *s = start; /* start of the constant */
2864 char *d = SvPVX(sv); /* destination for copies */
dc023dbb
KW
2865 bool dorange = FALSE; /* are we in a translit range? */
2866 bool didrange = FALSE; /* did we just finish a range? */
2867 bool in_charclass = FALSE; /* within /[...]/ */
2868 bool has_utf8 = FALSE; /* Output constant is UTF8 */
188d22cf
KW
2869 bool has_above_latin1 = FALSE; /* does something require special
2870 handling in tr/// ? */
dc023dbb
KW
2871 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2872 UTF8? But, this can show as true
2873 when the source isn't utf8, as for
2874 example when it is entirely composed
2875 of hex constants */
af9be36c
KW
2876 STRLEN utf8_variant_count = 0; /* When not in UTF-8, this counts the
2877 number of characters found so far
2878 that will expand (into 2 bytes)
2879 should we have to convert to
2880 UTF-8) */
6f613c73 2881 SV *res; /* result from charnames */
f4240379
KW
2882 STRLEN offset_to_max; /* The offset in the output to where the range
2883 high-end character is temporarily placed */
77a135fe
KW
2884
2885 /* Note on sizing: The scanned constant is placed into sv, which is
2886 * initialized by newSV() assuming one byte of output for every byte of
2887 * input. This routine expects newSV() to allocate an extra byte for a
2888 * trailing NUL, which this routine will append if it gets to the end of
2889 * the input. There may be more bytes of input than output (eg., \N{LATIN
2890 * CAPITAL LETTER A}), or more output than input if the constant ends up
2891 * recoded to utf8, but each time a construct is found that might increase
2892 * the needed size, SvGROW() is called. Its size parameter each time is
2893 * based on the best guess estimate at the time, namely the length used so
2894 * far, plus the length the current construct will occupy, plus room for
caae0700 2895 * the trailing NUL, plus one byte for every input byte still unscanned */
77a135fe 2896
c3320c2a
KW
2897 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2898 before set */
4c3a8340 2899#ifdef EBCDIC
f4240379
KW
2900 int backslash_N = 0; /* ? was the character from \N{} */
2901 int non_portable_endpoint = 0; /* ? In a range is an endpoint
2902 platform-specific like \x65 */
4c3a8340 2903#endif
012bcf8d 2904
7918f24d
NC
2905 PERL_ARGS_ASSERT_SCAN_CONST;
2906
bb16bae8 2907 assert(PL_lex_inwhat != OP_TRANSR);
7ef70b3d 2908 if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
2b9d42f0 2909 /* If we are doing a trans and we know we want UTF8 set expectation */
7ef70b3d
FC
2910 has_utf8 = PL_parser->lex_sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2911 this_utf8 = PL_parser->lex_sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2b9d42f0
NIS
2912 }
2913
b899e89d
FC
2914 /* Protect sv from errors and fatal warnings. */
2915 ENTER_with_name("scan_const");
2916 SAVEFREESV(sv);
2b9d42f0 2917
f4240379
KW
2918 while (s < send
2919 || dorange /* Handle tr/// range at right edge of input */
2920 ) {
ff3f963a 2921
02aa26ce 2922 /* get transliterations out of the way (they're most literal) */
3280af22 2923 if (PL_lex_inwhat == OP_TRANS) {
02aa26ce 2924
f4240379
KW
2925 /* But there isn't any special handling necessary unless there is a
2926 * range, so for most cases we just drop down and handle the value
2927 * as any other. There are two exceptions.
2928 *
02cd137d
KW
2929 * 1. A hyphen indicates that we are actually going to have a
2930 * range. In this case, skip the '-', set a flag, then drop
f4240379
KW
2931 * down to handle what should be the end range value.
2932 * 2. After we've handled that value, the next time through, that
2933 * flag is set and we fix up the range.
2934 *
2935 * Ranges entirely within Latin1 are expanded out entirely, in
188d22cf
KW
2936 * order to make the transliteration a simple table look-up.
2937 * Ranges that extend above Latin1 have to be done differently, so
2938 * there is no advantage to expanding them here, so they are
2939 * stored here as Min, ILLEGAL_UTF8_BYTE, Max. The illegal byte
2940 * signifies a hyphen without any possible ambiguity. On EBCDIC
2941 * machines, if the range is expressed as Unicode, the Latin1
2942 * portion is expanded out even if the range extends above
2943 * Latin1. This is because each code point in it has to be
2944 * processed here individually to get its native translation */
f4240379
KW
2945
2946 if (! dorange) {
2947
02cd137d
KW
2948 /* Here, we don't think we're in a range. If the new character
2949 * is not a hyphen; or if it is a hyphen, but it's too close to
2950 * either edge to indicate a range, then it's a regular
2951 * character. */
f4240379
KW
2952 if (*s != '-' || s >= send - 1 || s == start) {
2953
2954 /* A regular character. Process like any other, but first
2955 * clear any flags */
2956 didrange = FALSE;
2957 dorange = FALSE;
e294cc5d 2958#ifdef EBCDIC
f4240379
KW
2959 non_portable_endpoint = 0;
2960 backslash_N = 0;
e294cc5d 2961#endif
02cd137d
KW
2962 /* The tests here for being above Latin1 and similar ones
2963 * in the following 'else' suffice to find all such
2964 * occurences in the constant, except those added by a
2965 * backslash escape sequence, like \x{100}. And all those
2966 * set 'has_above_latin1' as appropriate */
188d22cf
KW
2967 if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
2968 has_above_latin1 = TRUE;
2969 }
2970
f4240379
KW
2971 /* Drops down to generic code to process current byte */
2972 }
02cd137d 2973 else { /* Is a '-' in the context where it means a range */
f4240379 2974 if (didrange) { /* Something like y/A-C-Z// */
02cd137d
KW
2975 Perl_croak(aTHX_ "Ambiguous range in transliteration"
2976 " operator");
f4240379 2977 }
e294cc5d 2978
f4240379 2979 dorange = TRUE;
2b9d42f0 2980
02cd137d 2981 s++; /* Skip past the hyphen */
f4240379
KW
2982
2983 /* d now points to where the end-range character will be
2984 * placed. Save it so won't have to go finding it later,
2985 * and drop down to get that character. (Actually we
2986 * instead save the offset, to handle the case where a
2987 * realloc in the meantime could change the actual
2988 * pointer). We'll finish processing the range the next
2989 * time through the loop */
2990 offset_to_max = d - SvPVX_const(sv);
188d22cf
KW
2991
2992 if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
2993 has_above_latin1 = TRUE;
2994 }
02cd137d
KW
2995
2996 /* Drops down to generic code to process current byte */
f4240379
KW
2997 }
2998 } /* End of not a range */
2999 else {
3000 /* Here we have parsed a range. Now must handle it. At this
3001 * point:
3002 * 'sv' is a SV* that contains the output string we are
3003 * constructing. The final two characters in that string
3004 * are the range start and range end, in order.
3005 * 'd' points to just beyond the range end in the 'sv' string,
3006 * where we would next place something
3007 * 'offset_to_max' is the offset in 'sv' at which the character
02cd137d 3008 * (the range's maximum end point) before 'd' begins.
f4240379 3009 */
8efef67c 3010 char * max_ptr = SvPVX(sv) + offset_to_max;
5ca37d54 3011 char * min_ptr;
f4240379
KW
3012 IV range_min;
3013 IV range_max; /* last character in range */
f4240379 3014 STRLEN grow;
5ca37d54
KW
3015 Size_t offset_to_min = 0;
3016 Size_t extras = 0;
11327fa1 3017#ifdef EBCDIC
f4240379
KW
3018 bool convert_unicode;
3019 IV real_range_max = 0;
e294cc5d 3020#endif
f4240379 3021
02cd137d 3022 /* Get the code point values of the range ends. */
e294cc5d 3023 if (has_utf8) {
f4240379
KW
3024 /* We know the utf8 is valid, because we just constructed
3025 * it ourselves in previous loop iterations */
3026 min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1);
3027 range_min = valid_utf8_to_uvchr( (U8*) min_ptr, NULL);
3028 range_max = valid_utf8_to_uvchr( (U8*) max_ptr, NULL);
e294cc5d 3029 }
f4240379
KW
3030 else {
3031 min_ptr = max_ptr - 1;
3032 range_min = * (U8*) min_ptr;
3033 range_max = * (U8*) max_ptr;
3034 }
3035
8efef67c
KW
3036 /* If the range is just a single code point, like tr/a-a/.../,
3037 * that code point is already in the output, twice. We can
3038 * just back up over the second instance and avoid all the rest
3039 * of the work. But if it is a variant character, it's been
3040 * counted twice, so decrement */
3041 if (UNLIKELY(range_max == range_min)) {
3042 d = max_ptr;
3043 if (! has_utf8 && ! UVCHR_IS_INVARIANT(range_max)) {
3044 utf8_variant_count--;
3045 }
3046 goto range_done;
3047 }
3048
e294cc5d 3049#ifdef EBCDIC
f4240379
KW
3050 /* On EBCDIC platforms, we may have to deal with portable
3051 * ranges. These happen if at least one range endpoint is a
3052 * Unicode value (\N{...}), or if the range is a subset of
3053 * [A-Z] or [a-z], and both ends are literal characters,
3054 * like 'A', and not like \x{C1} */
87dd6ea7 3055 convert_unicode =
02cd137d
KW
3056 cBOOL(backslash_N) /* \N{} forces Unicode,
3057 hence portable range */
3058 || ( ! non_portable_endpoint
3059 && (( isLOWER_A(range_min) && isLOWER_A(range_max))
3060 || (isUPPER_A(range_min) && isUPPER_A(range_max))));
87dd6ea7 3061 if (convert_unicode) {
f4240379
KW
3062
3063 /* Special handling is needed for these portable ranges.
02cd137d
KW
3064 * They are defined to be in Unicode terms, which includes
3065 * all the Unicode code points between the end points.
f4240379
KW
3066 * Convert to Unicode to get the Unicode range. Later we
3067 * will convert each code point in the range back to
3068 * native. */
3069 range_min = NATIVE_TO_UNI(range_min);
3070 range_max = NATIVE_TO_UNI(range_max);
3071 }
e294cc5d 3072#endif
8ada0baa 3073
f4240379 3074 if (range_min > range_max) {
11327fa1 3075#ifdef EBCDIC
f4240379
KW
3076 if (convert_unicode) {
3077 /* Need to convert back to native for meaningful
3078 * messages for this platform */
3079 range_min = UNI_TO_NATIVE(range_min);
3080 range_max = UNI_TO_NATIVE(range_max);
3081 }
11327fa1 3082#endif
f4240379
KW
3083 /* Use the characters themselves for the error message if
3084 * ASCII printables; otherwise some visible representation
3085 * of them */
3086 if (isPRINT_A(range_min) && isPRINT_A(range_max)) {
3087 Perl_croak(aTHX_
3088 "Invalid range \"%c-%c\" in transliteration operator",
3089 (char)range_min, (char)range_max);
3090 }
11327fa1 3091#ifdef EBCDIC
f4240379 3092 else if (convert_unicode) {
02cd137d 3093 /* diag_listed_as: Invalid range "%s" in transliteration operator */
f4240379 3094 Perl_croak(aTHX_
02cd137d
KW
3095 "Invalid range \"\\N{U+%04" UVXf "}-\\N{U+%04"
3096 UVXf "}\" in transliteration operator",
3097 range_min, range_max);
f4240379 3098 }
11327fa1 3099#endif
f4240379 3100 else {
02cd137d 3101 /* diag_listed_as: Invalid range "%s" in transliteration operator */
f4240379 3102 Perl_croak(aTHX_
02cd137d
KW
3103 "Invalid range \"\\x{%04" UVXf "}-\\x{%04" UVXf "}\""
3104 " in transliteration operator",
3105 range_min, range_max);
f4240379 3106 }
c2e66d9e
GS
3107 }
3108
aca41667
KW
3109 /* If the range is exactly two code points long, they are
3110 * already both in the output */
3111 if (UNLIKELY(range_min + 1 == range_max)) {
3112 goto range_done;
3113 }
3114
3115 /* Here the range contains at least 3 code points */
3116
f4240379
KW
3117 if (has_utf8) {
3118
188d22cf
KW
3119 /* If everything in the transliteration is below 256, we
3120 * can avoid special handling later. A translation table
02cd137d
KW
3121 * for each of those bytes is created by op.c. So we
3122 * expand out all ranges to their constituent code points.
3123 * But if we've encountered something above 255, the
3124 * expanding won't help, so skip doing that. But if it's
3125 * EBCDIC, we may have to look at each character below 256
3126 * if we have to convert to/from Unicode values */
188d22cf 3127 if ( has_above_latin1
c7f1f016 3128#ifdef EBCDIC
f4240379 3129 && (range_min > 255 || ! convert_unicode)
8ada0baa 3130#endif
f4240379
KW
3131 ) {
3132 /* Move the high character one byte to the right; then
3133 * insert between it and the range begin, an illegal
3134 * byte which serves to indicate this is a range (using
02cd137d 3135 * a '-' would be ambiguous). */
f4240379
KW
3136 char *e = d++;
3137 while (e-- > max_ptr) {
3138 *(e + 1) = *e;
e294cc5d 3139 }
f4240379
KW
3140 *(e + 1) = (char) ILLEGAL_UTF8_BYTE;
3141 goto range_done;
3142 }
3143
3144 /* Here, we're going to expand out the range. For EBCDIC
3145 * the range can extend above 255 (not so in ASCII), so
3146 * for EBCDIC, split it into the parts above and below
3147 * 255/256 */
e294cc5d 3148#ifdef EBCDIC
f4240379
KW
3149 if (range_max > 255) {
3150 real_range_max = range_max;
3151 range_max = 255;
3152 }
e294cc5d 3153#endif
f4240379 3154 }
02aa26ce 3155
f4240379 3156 /* Here we need to expand out the string to contain each
5ca37d54
KW
3157 * character in the range. Grow the output to handle this.
3158 * For non-UTF8, we need a byte for each code point in the
3159 * range, minus the three that we've already allocated for: the
3160 * hyphen, the min, and the max. For UTF-8, we need this
3161 * plus an extra byte for each code point that occupies two
3162 * bytes (is variant) when in UTF-8 (except we've already
3163 * allocated for the end points, including if they are
3164 * variants). For ASCII platforms and Unicode ranges on EBCDIC
3165 * platforms, it's easy to calculate a precise number. To
3166 * start, we count the variants in the range, which we need
3167 * elsewhere in this function anyway. (For the case where it
3168 * isn't easy to calculate, 'extras' has been initialized to 0,
3169 * and the calculation is done in a loop further down.) */
3170#ifdef EBCDIC
3171 if (convert_unicode)
3172#endif
3173 {
3174 /* This is executed unconditionally on ASCII, and for
3175 * Unicode ranges on EBCDIC. Under these conditions, all
3176 * code points above a certain value are variant; and none
3177 * under that value are. We just need to find out how much
3178 * of the range is above that value. We don't count the
3179 * end points here, as they will already have been counted
3180 * as they were parsed. */
3181 if (range_min >= UTF_CONTINUATION_MARK) {
3182
3183 /* The whole range is made up of variants */
3184 extras = (range_max - 1) - (range_min + 1) + 1;
3185 }
3186 else if (range_max >= UTF_CONTINUATION_MARK) {
f4240379 3187
5ca37d54
KW
3188 /* Only the higher portion of the range is variants */
3189 extras = (range_max - 1) - UTF_CONTINUATION_MARK + 1;
3190 }
f4240379 3191
5ca37d54
KW
3192 utf8_variant_count += extras;
3193 }
3194
3195 /* The base growth is the number of code points in the range,
3196 * not including the endpoints, which have already been sized
3197 * for (and output). We don't subtract for the hyphen, as it
3198 * has been parsed but not output, and the SvGROW below is
3199 * based only on what's been output plus what's left to parse.
3200 * */
3201 grow = (range_max - 1) - (range_min + 1) + 1;
f4240379 3202
5ca37d54 3203 if (has_utf8) {
4c3a8340 3204#ifdef EBCDIC
5ca37d54
KW
3205 /* In some cases in EBCDIC, we haven't yet calculated a
3206 * precise amount needed for the UTF-8 variants. Just
3207 * assume the worst case, that everything will expand by a
3208 * byte */
3209 if (! convert_unicode) {
f4240379
KW
3210 grow *= 2;
3211 }
5ca37d54 3212 else
4c3a8340 3213#endif
5ca37d54
KW
3214 {
3215 /* Otherwise we know exactly how many variants there
3216 * are in the range. */
3217 grow += extras;
3218 }
f4240379
KW
3219 }
3220
5ca37d54
KW
3221 /* Grow, but position the output to overwrite the range min end
3222 * point, because in some cases we overwrite that */
3223 SvCUR_set(sv, d - SvPVX_const(sv));
3224 offset_to_min = min_ptr - SvPVX_const(sv);
3225
3226 /* See Note on sizing above. */
3227 d = offset_to_min + SvGROW(sv, SvCUR(sv)
3228 + (send - s)
3229 + grow
3230 + 1 /* Trailing NUL */ );
f4240379 3231
5ca37d54 3232 /* Now, we can expand out the range. */
11327fa1 3233#ifdef EBCDIC
f4240379 3234 if (convert_unicode) {
5ca37d54 3235 SSize_t i;
02aa26ce 3236
f4240379
KW
3237 /* Recall that the min and max are now in Unicode terms, so
3238 * we have to convert each character to its native
3239 * equivalent */
3240 if (has_utf8) {
3241 for (i = range_min; i <= range_max; i++) {
02cd137d
KW
3242 append_utf8_from_native_byte(
3243 LATIN1_TO_NATIVE((U8) i),
3244 (U8 **) &d);
f4240379
KW
3245 }
3246 }
3247 else {
3248 for (i = range_min; i <= range_max; i++) {
81324705 3249 *d++ = (char)LATIN1_TO_NATIVE((U8) i);
f4240379
KW
3250 }
3251 }
01ec43d0 3252 }
11327fa1
AL
3253 else
3254#endif
3255 /* Always gets run for ASCII, and sometimes for EBCDIC. */
3256 {
5ca37d54 3257 SSize_t i;
f4240379
KW
3258
3259 /* Here, no conversions are necessary, which means that the
3260 * first character in the range is already in 'd' and
3261 * valid, so we can skip overwriting it */
3262 if (has_utf8) {
3263 d += UTF8SKIP(d);
3264 for (i = range_min + 1; i <= range_max; i++) {
81324705 3265 append_utf8_from_native_byte((U8) i, (U8 **) &d);
f4240379
KW
3266 }
3267 }
3268 else {
3269 d++;
5ca37d54
KW
3270 assert(range_min + 1 <= range_max);
3271 for (i = range_min + 1; i < range_max; i++) {
3272#ifdef EBCDIC
3273 /* In this case on EBCDIC, we haven't calculated
3274 * the variants. Do it here, as we go along */
3275 if (! UVCHR_IS_INVARIANT(i)) {
3276 utf8_variant_count++;
3277 }
3278#endif
f4240379
KW
3279 *d++ = (char)i;
3280 }
5ca37d54
KW
3281
3282 /* The range_max is done outside the loop so as to
3283 * avoid having to special case not incrementing
3284 * 'utf8_variant_count' on EBCDIC (it's already been
3285 * counted when originally parsed) */
3286 *d++ = (char) range_max;
f4240379 3287 }
a0ed51b3 3288 }
02aa26ce 3289
11327fa1 3290#ifdef EBCDIC
02cd137d
KW
3291 /* If the original range extended above 255, add in that
3292 * portion. */
f4240379
KW
3293 if (real_range_max) {
3294 *d++ = (char) UTF8_TWO_BYTE_HI(0x100);
3295 *d++ = (char) UTF8_TWO_BYTE_LO(0x100);
043af6f6
KW
3296 if (real_range_max > 0x100) {
3297 if (real_range_max > 0x101) {
3298 *d++ = (char) ILLEGAL_UTF8_BYTE;
3299 }
f4240379 3300 d = (char*)uvchr_to_utf8((U8*)d, real_range_max);
043af6f6 3301 }
f4240379 3302 }
11327fa1 3303#endif
02aa26ce 3304
f4240379
KW
3305 range_done:
3306 /* mark the range as done, and continue */
3307 didrange = TRUE;
3308 dorange = FALSE;
3309#ifdef EBCDIC
3310 non_portable_endpoint = 0;
3311 backslash_N = 0;
3312#endif
3313 continue;
3314 } /* End of is a range */
3315 } /* End of transliteration. Joins main code after these else's */
e4a2df84
DM
3316 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3317 char *s1 = s-1;
3318 int esc = 0;
3319 while (s1 >= start && *s1-- == '\\')
3320 esc = !esc;
3321 if (!esc)
3322 in_charclass = TRUE;
3323 }
1e02a175 3324 else if (*s == ']' && PL_lex_inpat && in_charclass) {
e4a2df84
DM
3325 char *s1 = s-1;
3326 int esc = 0;
3327 while (s1 >= start && *s1-- == '\\')
3328 esc = !esc;
3329 if (!esc)
3330 in_charclass = FALSE;
3331 }
02cd137d
KW
3332 /* skip for regexp comments /(?#comment)/, except for the last
3333 * char, which will be done separately. Stop on (?{..}) and
3334 * friends */
c30fc27b 3335 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
cc6b7395 3336 if (s[2] == '#') {
e994fd66 3337 while (s+1 < send && *s != ')')
5ff03569 3338 *d++ = *s++;
155aba94 3339 }
407f8cf2
KW
3340 else if (!PL_lex_casemods
3341 && ( s[2] == '{' /* This should match regcomp.c */
3342 || (s[2] == '?' && s[3] == '{')))
155aba94 3343 {
9da1dd8f 3344 break;
cc6b7395 3345 }
748a9306 3346 }
02cd137d 3347 /* likewise skip #-initiated comments in //x patterns */
407f8cf2
KW
3348 else if (*s == '#'
3349 && PL_lex_inpat
3350 && !in_charclass
3351 && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED)
3352 {
8faf4f30 3353 while (s < send && *s != '\n')
5ff03569 3354 *d++ = *s++;
748a9306 3355 }
02cd137d 3356 /* no further processing of single-quoted regex */
9da1dd8f
DM
3357 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3358 goto default_action;
3359
02cd137d
KW
3360 /* check for embedded arrays
3361 * (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3362 */
1749ea0d 3363 else if (*s == '@' && s[1]) {
fac0f7a3
KW
3364 if (UTF
3365 ? isIDFIRST_utf8_safe(s+1, send)
3366 : isWORDCHAR_A(s[1]))
3367 {
1749ea0d 3368 break;
fac0f7a3 3369 }
1749ea0d
ST
3370 if (strchr(":'{$", s[1]))
3371 break;
3372 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3373 break; /* in regexp, neither @+ nor @- are interpolated */
3374 }
02cd137d
KW
3375 /* check for embedded scalars. only stop if we're sure it's a
3376 * variable. */
79072805 3377 else if (*s == '$') {
3280af22 3378 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
79072805 3379 break;
77772344 3380 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
a2a5de95
NC
3381 if (s[1] == '\\') {
3382 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3383 "Possible unintended interpolation of $\\ in regex");
77772344 3384 }
79072805 3385 break; /* in regexp, $ might be tail anchor */
77772344 3386 }
79072805 3387 }
02aa26ce 3388
2b9d42f0
NIS
3389 /* End of else if chain - OP_TRANS rejoin rest */
3390
8faf4f30
HS
3391 if (UNLIKELY(s >= send)) {
3392 assert(s == send);
3393 break;
3394 }
3395
02aa26ce 3396 /* backslashes */
79072805 3397 if (*s == '\\' && s+1 < send) {
ff3f963a
KW
3398 char* e; /* Can be used for ending '}', etc. */
3399
79072805 3400 s++;
02aa26ce 3401
7d0fc23c
KW
3402 /* warn on \1 - \9 in substitution replacements, but note that \11
3403 * is an octal; and \19 is \1 followed by '9' */
407f8cf2
KW
3404 if (PL_lex_inwhat == OP_SUBST
3405 && !PL_lex_inpat
3406 && isDIGIT(*s)
3407 && *s != '0'
3408 && !isDIGIT(s[1]))
79072805 3409 {
c782d7ee 3410 /* diag_listed_as: \%d better written as $%d */
a2a5de95 3411 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
79072805
LW
3412 *--s = '$';
3413 break;
3414 }
02aa26ce
NT
3415
3416 /* string-change backslash escapes */
838f2281 3417 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
79072805
LW
3418 --s;
3419 break;
3420 }
ff3f963a
KW
3421 /* In a pattern, process \N, but skip any other backslash escapes.
3422 * This is because we don't want to translate an escape sequence
3423 * into a meta symbol and have the regex compiler use the meta
3424 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3425 * in spite of this, we do have to process \N here while the proper
3426 * charnames handler is in scope. See bugs #56444 and #62056.
85fba779 3427 *
ff3f963a
KW
3428 * There is a complication because \N in a pattern may also stand
3429 * for 'match a non-nl', and not mean a charname, in which case its
3430 * processing should be deferred to the regex compiler. To be a
3431 * charname it must be followed immediately by a '{', and not look
3432 * like \N followed by a curly quantifier, i.e., not something like
3433 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3434 * quantifier */
3435 else if (PL_lex_inpat
3436 && (*s != 'N'
3437 || s[1] != '{'
412f55bb 3438 || regcurly(s + 1)))
ff3f963a 3439 {
4d73d076 3440 *d++ = '\\';
cc74c5bd
ST
3441 goto default_action;
3442 }
02aa26ce 3443
79072805 3444 switch (*s) {
79072805 3445 default:
11b8faa4 3446 {
15861f94 3447 if ((isALPHANUMERIC(*s)))
a2a5de95
NC
3448 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3449 "Unrecognized escape \\%c passed through",
3450 *s);
11b8faa4 3451 /* default action is to copy the quoted character */
f9a63242 3452 goto default_action;
11b8faa4 3453 }
02aa26ce 3454
632403cc 3455 /* eg. \132 indicates the octal constant 0132 */
79072805
LW
3456 case '0': case '1': case '2': case '3':
3457 case '4': case '5': case '6': case '7':
ba210ebe 3458 {
5e0a247b 3459 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
53305cf1 3460 STRLEN len = 3;
06972766 3461 uv = grok_oct(s, &len, &flags, NULL);
ba210ebe 3462 s += len;
5e0a247b
KW
3463 if (len < 3 && s < send && isDIGIT(*s)
3464 && ckWARN(WARN_MISC))
3465 {
3466 Perl_warner(aTHX_ packWARN(WARN_MISC),
3467 "%s", form_short_octal_warning(s, len));
3468 }
ba210ebe 3469 }
012bcf8d 3470 goto NUM_ESCAPE_INSERT;
02aa26ce 3471
f0a2b745
KW
3472 /* eg. \o{24} indicates the octal constant \024 */
3473 case 'o':
3474 {
454155d9 3475 const char* error;
f0a2b745 3476
00ce5563 3477 bool valid = grok_bslash_o(&s, &uv, &error,
80f4111b
KW
3478 TRUE, /* Output warning */
3479 FALSE, /* Not strict */
17896a85
KW
3480 TRUE, /* Output warnings for
3481 non-portables */
80f4111b 3482 UTF);
454155d9 3483 if (! valid) {
f0a2b745 3484 yyerror(error);
3dd4eaeb 3485 uv = 0; /* drop through to ensure range ends are set */
f0a2b745
KW
3486 }
3487 goto NUM_ESCAPE_INSERT;
3488 }
3489
77a135fe 3490 /* eg. \x24 indicates the hex constant 0x24 */
79072805 3491 case 'x':
a0481293 3492 {
a0481293 3493 const char* error;
355860ce 3494
00ce5563 3495 bool valid = grok_bslash_x(&s, &uv, &error,
80f4111b
KW
3496 TRUE, /* Output warning */
3497 FALSE, /* Not strict */
17896a85
KW
3498 TRUE, /* Output warnings for
3499 non-portables */
80f4111b 3500 UTF);
a0481293
KW
3501 if (! valid) {
3502 yyerror(error);
3dd4eaeb 3503 uv = 0; /* drop through to ensure range ends are set */
ba210ebe 3504 }
012bcf8d
GS
3505 }
3506
3507 NUM_ESCAPE_INSERT:
b67fd2c5 3508 /* Insert oct or hex escaped character. */
02cd137d 3509
06972766 3510 /* Here uv is the ordinal of the next character being added */
f4240379
KW
3511 if (UVCHR_IS_INVARIANT(uv)) {
3512 *d++ = (char) uv;
3513 }
3514 else {
9aa983d2 3515 if (!has_utf8 && uv > 255) {
caae0700 3516
af9be36c
KW
3517 /* Here, 'uv' won't fit unless we convert to UTF-8.
3518 * If we've only seen invariants so far, all we have to
3519 * do is turn on the flag */
3520 if (utf8_variant_count == 0) {
3521 SvUTF8_on(sv);
3522 }
3523 else {
1e02a175
KW
3524 SvCUR_set(sv, d - SvPVX_const(sv));
3525 SvPOK_on(sv);
3526 *d = '\0';
3527
3528 sv_utf8_upgrade_flags_grow(
3529 sv,
5dfbfbd5 3530 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
1e02a175 3531
2916094f
KW
3532 /* Since we're having to grow here,
3533 * make sure we have enough room for
3534 * this escape and a NUL, so the
3535 * code immediately below won't have
3536 * to actually grow again */
1e02a175
KW
3537 UVCHR_SKIP(uv)
3538 + (STRLEN)(send - s) + 1);
3539 d = SvPVX(sv) + SvCUR(sv);
af9be36c
KW
3540 }
3541
188d22cf 3542 has_above_latin1 = TRUE;
1e02a175 3543 has_utf8 = TRUE;
012bcf8d
GS
3544 }
3545
8d0042a8
KW
3546 if (! has_utf8) {
3547 *d++ = (char)uv;
af9be36c 3548 utf8_variant_count++;
8d0042a8
KW
3549 }
3550 else {
b67fd2c5
KW
3551 /* Usually, there will already be enough room in 'sv'
3552 * since such escapes are likely longer than any UTF-8
3553 * sequence they can end up as. This isn't the case on
3554 * EBCDIC where \x{40000000} contains 12 bytes, and the
3555 * UTF-8 for it contains 14. And, we have to allow for
3556 * a trailing NUL. It probably can't happen on ASCII
2916094f
KW
3557 * platforms, but be safe. See Note on sizing above. */
3558 const STRLEN needed = d - SvPVX(sv)
3559 + UVCHR_SKIP(uv)
3560 + (send - s)
b67fd2c5
KW
3561 + 1;
3562 if (UNLIKELY(needed > SvLEN(sv))) {
3563 SvCUR_set(sv, d - SvPVX_const(sv));
94beb101 3564 d = SvCUR(sv) + SvGROW(sv, needed);
b67fd2c5
KW
3565