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