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