This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
toke.c: Skip some work for UTF-8 invariant
[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;
df13534a 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;
98d5e3ef
DM
926 bool current;
927
f0e67a1d
Z
928 linestr = PL_parser->linestr;
929 buf = SvPVX(linestr);
930 if (len <= SvLEN(linestr))
931 return buf;
98d5e3ef
DM
932
933 /* Is the lex_shared linestr SV the same as the current linestr SV?
934 * Only in this case does re_eval_start need adjusting, since it
935 * points within lex_shared->ls_linestr's buffer */
936 current = (linestr == PL_parser->lex_shared->ls_linestr);
937
f0e67a1d
Z
938 bufend_pos = PL_parser->bufend - buf;
939 bufptr_pos = PL_parser->bufptr - buf;
940 oldbufptr_pos = PL_parser->oldbufptr - buf;
941 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
942 linestart_pos = PL_parser->linestart - buf;
943 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
944 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
98d5e3ef 945 re_eval_start_pos = (current && PL_parser->lex_shared->re_eval_start) ?
3328ab5a 946 PL_parser->lex_shared->re_eval_start - buf : 0;
c7641931 947
f0e67a1d 948 buf = sv_grow(linestr, len);
c7641931 949
f0e67a1d
Z
950 PL_parser->bufend = buf + bufend_pos;
951 PL_parser->bufptr = buf + bufptr_pos;
952 PL_parser->oldbufptr = buf + oldbufptr_pos;
953 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
954 PL_parser->linestart = buf + linestart_pos;
955 if (PL_parser->last_uni)
956 PL_parser->last_uni = buf + last_uni_pos;
957 if (PL_parser->last_lop)
958 PL_parser->last_lop = buf + last_lop_pos;
98d5e3ef 959 if (current && PL_parser->lex_shared->re_eval_start)
3328ab5a 960 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
f0e67a1d
Z
961 return buf;
962}
963
964/*
83aa740e 965=for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
f0e67a1d
Z
966
967Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
968immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
969reallocating the buffer if necessary. This means that lexing code that
970runs later will see the characters as if they had appeared in the input.
971It is not recommended to do this as part of normal parsing, and most
972uses of this facility run the risk of the inserted characters being
973interpreted in an unintended manner.
974
2d7f6611
KW
975The string to be inserted is represented by C<len> octets starting
976at C<pv>. These octets are interpreted as either UTF-8 or Latin-1,
977according to whether the C<LEX_STUFF_UTF8> flag is set in C<flags>.
f0e67a1d
Z
978The characters are recoded for the lexer buffer, according to how the
979buffer is currently being interpreted (L</lex_bufutf8>). If a string
9dcc53ea 980to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
f0e67a1d
Z
981function is more convenient.
982
983=cut
984*/
985
986void
83aa740e 987Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
f0e67a1d 988{
749123ff 989 dVAR;
f0e67a1d
Z
990 char *bufptr;
991 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
992 if (flags & ~(LEX_STUFF_UTF8))
993 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
994 if (UTF) {
995 if (flags & LEX_STUFF_UTF8) {
996 goto plain_copy;
997 } else {
54d004e8 998 STRLEN highhalf = 0; /* Count of variants */
83aa740e 999 const char *p, *e = pv+len;
54d004e8
KW
1000 for (p = pv; p != e; p++) {
1001 if (! UTF8_IS_INVARIANT(*p)) {
1002 highhalf++;
1003 }
1004 }
f0e67a1d
Z
1005 if (!highhalf)
1006 goto plain_copy;
1007 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1008 bufptr = PL_parser->bufptr;
1009 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
255fdf19
Z
1010 SvCUR_set(PL_parser->linestr,
1011 SvCUR(PL_parser->linestr) + len+highhalf);
f0e67a1d
Z
1012 PL_parser->bufend += len+highhalf;
1013 for (p = pv; p != e; p++) {
1014 U8 c = (U8)*p;
54d004e8
KW
1015 if (! UTF8_IS_INVARIANT(c)) {
1016 *bufptr++ = UTF8_TWO_BYTE_HI(c);
1017 *bufptr++ = UTF8_TWO_BYTE_LO(c);
f0e67a1d
Z
1018 } else {
1019 *bufptr++ = (char)c;
1020 }
1021 }
1022 }
1023 } else {
1024 if (flags & LEX_STUFF_UTF8) {
1025 STRLEN highhalf = 0;
83aa740e 1026 const char *p, *e = pv+len;
f0e67a1d
Z
1027 for (p = pv; p != e; p++) {
1028 U8 c = (U8)*p;
54d004e8 1029 if (UTF8_IS_ABOVE_LATIN1(c)) {
f0e67a1d
Z
1030 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1031 "non-Latin-1 character into Latin-1 input");
54d004e8 1032 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
f0e67a1d
Z
1033 p++;
1034 highhalf++;
54d004e8 1035 } else if (! UTF8_IS_INVARIANT(c)) {
f0e67a1d
Z
1036 /* malformed UTF-8 */
1037 ENTER;
1038 SAVESPTR(PL_warnhook);
1039 PL_warnhook = PERL_WARNHOOK_FATAL;
c80e42f3 1040 utf8n_to_uvchr((U8*)p, e-p, NULL, 0);
f0e67a1d
Z
1041 LEAVE;
1042 }
1043 }
1044 if (!highhalf)
1045 goto plain_copy;
1046 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1047 bufptr = PL_parser->bufptr;
1048 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
255fdf19
Z
1049 SvCUR_set(PL_parser->linestr,
1050 SvCUR(PL_parser->linestr) + len-highhalf);
f0e67a1d 1051 PL_parser->bufend += len-highhalf;
54d004e8
KW
1052 p = pv;
1053 while (p < e) {
1054 if (UTF8_IS_INVARIANT(*p)) {
1055 *bufptr++ = *p;
1056 p++;
f0e67a1d 1057 }
54d004e8
KW
1058 else {
1059 assert(p < e -1 );
a62b247b 1060 *bufptr++ = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
54d004e8
KW
1061 p += 2;
1062 }
f0e67a1d
Z
1063 }
1064 } else {
54d004e8 1065 plain_copy:
f0e67a1d
Z
1066 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1067 bufptr = PL_parser->bufptr;
1068 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
255fdf19 1069 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
f0e67a1d
Z
1070 PL_parser->bufend += len;
1071 Copy(pv, bufptr, len, char);
1072 }
1073 }
1074}
1075
1076/*
9dcc53ea
Z
1077=for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1078
1079Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1080immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1081reallocating the buffer if necessary. This means that lexing code that
1082runs later will see the characters as if they had appeared in the input.
1083It is not recommended to do this as part of normal parsing, and most
1084uses of this facility run the risk of the inserted characters being
1085interpreted in an unintended manner.
1086
2d7f6611 1087The string to be inserted is represented by octets starting at C<pv>
9dcc53ea
Z
1088and continuing to the first nul. These octets are interpreted as either
1089UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
2d7f6611 1090in C<flags>. The characters are recoded for the lexer buffer, according
9dcc53ea
Z
1091to how the buffer is currently being interpreted (L</lex_bufutf8>).
1092If it is not convenient to nul-terminate a string to be inserted, the
1093L</lex_stuff_pvn> function is more appropriate.
1094
1095=cut
1096*/
1097
1098void
1099Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1100{
1101 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1102 lex_stuff_pvn(pv, strlen(pv), flags);
1103}
1104
1105/*
f0e67a1d
Z
1106=for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1107
1108Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1109immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1110reallocating the buffer if necessary. This means that lexing code that
1111runs later will see the characters as if they had appeared in the input.
1112It is not recommended to do this as part of normal parsing, and most
1113uses of this facility run the risk of the inserted characters being
1114interpreted in an unintended manner.
1115
2d7f6611 1116The string to be inserted is the string value of C<sv>. The characters
f0e67a1d 1117are recoded for the lexer buffer, according to how the buffer is currently
9dcc53ea 1118being interpreted (L</lex_bufutf8>). If a string to be inserted is
f0e67a1d
Z
1119not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1120need to construct a scalar.
1121
1122=cut
1123*/
1124
1125void
1126Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1127{
1128 char *pv;
1129 STRLEN len;
1130 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1131 if (flags)
1132 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1133 pv = SvPV(sv, len);
1134 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1135}
1136
1137/*
1138=for apidoc Amx|void|lex_unstuff|char *ptr
1139
1140Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
2d7f6611 1141C<ptr>. Text following C<ptr> will be moved, and the buffer shortened.
f0e67a1d
Z
1142This hides the discarded text from any lexing code that runs later,
1143as if the text had never appeared.
1144
1145This is not the normal way to consume lexed text. For that, use
1146L</lex_read_to>.
1147
1148=cut
1149*/
1150
1151void
1152Perl_lex_unstuff(pTHX_ char *ptr)
1153{
1154 char *buf, *bufend;
1155 STRLEN unstuff_len;
1156 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1157 buf = PL_parser->bufptr;
1158 if (ptr < buf)
1159 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1160 if (ptr == buf)
1161 return;
1162 bufend = PL_parser->bufend;
1163 if (ptr > bufend)
1164 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1165 unstuff_len = ptr - buf;
1166 Move(ptr, buf, bufend+1-ptr, char);
1167 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1168 PL_parser->bufend = bufend - unstuff_len;
1169}
1170
1171/*
1172=for apidoc Amx|void|lex_read_to|char *ptr
1173
1174Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
2d7f6611 1175to C<ptr>. This advances L</PL_parser-E<gt>bufptr> to match C<ptr>,
f0e67a1d
Z
1176performing the correct bookkeeping whenever a newline character is passed.
1177This is the normal way to consume lexed text.
1178
1179Interpretation of the buffer's octets can be abstracted out by
1180using the slightly higher-level functions L</lex_peek_unichar> and
1181L</lex_read_unichar>.
1182
1183=cut
1184*/
1185
1186void
1187Perl_lex_read_to(pTHX_ char *ptr)
1188{
1189 char *s;
1190 PERL_ARGS_ASSERT_LEX_READ_TO;
1191 s = PL_parser->bufptr;
1192 if (ptr < s || ptr > PL_parser->bufend)
1193 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1194 for (; s != ptr; s++)
1195 if (*s == '\n') {
83944c01 1196 COPLINE_INC_WITH_HERELINES;
f0e67a1d
Z
1197 PL_parser->linestart = s+1;
1198 }
1199 PL_parser->bufptr = ptr;
1200}
1201
1202/*
1203=for apidoc Amx|void|lex_discard_to|char *ptr
1204
1205Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
2d7f6611
KW
1206up to C<ptr>. The remaining content of the buffer will be moved, and
1207all pointers into the buffer updated appropriately. C<ptr> must not
f0e67a1d
Z
1208be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1209it is not permitted to discard text that has yet to be lexed.
1210
1211Normally it is not necessarily to do this directly, because it suffices to
1212use the implicit discarding behaviour of L</lex_next_chunk> and things
1213based on it. However, if a token stretches across multiple lines,
1f317c95 1214and the lexing code has kept multiple lines of text in the buffer for
f0e67a1d
Z
1215that purpose, then after completion of the token it would be wise to
1216explicitly discard the now-unneeded earlier lines, to avoid future
1217multi-line tokens growing the buffer without bound.
1218
1219=cut
1220*/
1221
1222void
1223Perl_lex_discard_to(pTHX_ char *ptr)
1224{
1225 char *buf;
1226 STRLEN discard_len;
1227 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1228 buf = SvPVX(PL_parser->linestr);
1229 if (ptr < buf)
1230 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1231 if (ptr == buf)
1232 return;
1233 if (ptr > PL_parser->bufptr)
1234 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1235 discard_len = ptr - buf;
1236 if (PL_parser->oldbufptr < ptr)
1237 PL_parser->oldbufptr = ptr;
1238 if (PL_parser->oldoldbufptr < ptr)
1239 PL_parser->oldoldbufptr = ptr;
1240 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1241 PL_parser->last_uni = NULL;
1242 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1243 PL_parser->last_lop = NULL;
1244 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1245 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1246 PL_parser->bufend -= discard_len;
1247 PL_parser->bufptr -= discard_len;
1248 PL_parser->oldbufptr -= discard_len;
1249 PL_parser->oldoldbufptr -= discard_len;
1250 if (PL_parser->last_uni)
1251 PL_parser->last_uni -= discard_len;
1252 if (PL_parser->last_lop)
1253 PL_parser->last_lop -= discard_len;
1254}
1255
1256/*
1257=for apidoc Amx|bool|lex_next_chunk|U32 flags
1258
1259Reads in the next chunk of text to be lexed, appending it to
1260L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1261looked to the end of the current chunk and wants to know more. It is
1262usual, but not necessary, for lexing to have consumed the entirety of
1263the current chunk at this time.
1264
1265If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1266chunk (i.e., the current chunk has been entirely consumed), normally the
1267current chunk will be discarded at the same time that the new chunk is
c5608a1f 1268read in. If C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, the current chunk
f0e67a1d
Z
1269will not be discarded. If the current chunk has not been entirely
1270consumed, then it will not be discarded regardless of the flag.
1271
1272Returns true if some new text was added to the buffer, or false if the
1273buffer has reached the end of the input text.
1274
1275=cut
1276*/
1277
1278#define LEX_FAKE_EOF 0x80000000
e47d32dc 1279#define LEX_NO_TERM 0x40000000 /* here-doc */
f0e67a1d
Z
1280
1281bool
1282Perl_lex_next_chunk(pTHX_ U32 flags)
1283{
1284 SV *linestr;
1285 char *buf;
1286 STRLEN old_bufend_pos, new_bufend_pos;
1287 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1288 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
17cc9359 1289 bool got_some_for_debugger = 0;
f0e67a1d 1290 bool got_some;
112d1284 1291 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
f0e67a1d 1292 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
d27f4b91 1293 if (!(flags & LEX_NO_TERM) && PL_lex_inwhat)
e47d32dc 1294 return FALSE;
f0e67a1d
Z
1295 linestr = PL_parser->linestr;
1296 buf = SvPVX(linestr);
407f8cf2
KW
1297 if (!(flags & LEX_KEEP_PREVIOUS)
1298 && PL_parser->bufptr == PL_parser->bufend)
1299 {
f0e67a1d
Z
1300 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1301 linestart_pos = 0;
1302 if (PL_parser->last_uni != PL_parser->bufend)
1303 PL_parser->last_uni = NULL;
1304 if (PL_parser->last_lop != PL_parser->bufend)
1305 PL_parser->last_lop = NULL;
1306 last_uni_pos = last_lop_pos = 0;
1307 *buf = 0;
1308 SvCUR(linestr) = 0;
1309 } else {
1310 old_bufend_pos = PL_parser->bufend - buf;
1311 bufptr_pos = PL_parser->bufptr - buf;
1312 oldbufptr_pos = PL_parser->oldbufptr - buf;
1313 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1314 linestart_pos = PL_parser->linestart - buf;
1315 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1316 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1317 }
1318 if (flags & LEX_FAKE_EOF) {
1319 goto eof;
60d63348 1320 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
f0e67a1d
Z
1321 got_some = 0;
1322 } else if (filter_gets(linestr, old_bufend_pos)) {
1323 got_some = 1;
17cc9359 1324 got_some_for_debugger = 1;
112d1284
FC
1325 } else if (flags & LEX_NO_TERM) {
1326 got_some = 0;
f0e67a1d 1327 } else {
580561a3 1328 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
847cc851 1329 SvPVCLEAR(linestr);
f0e67a1d
Z
1330 eof:
1331 /* End of real input. Close filehandle (unless it was STDIN),
1332 * then add implicit termination.
1333 */
87606032 1334 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
f0e67a1d
Z
1335 PerlIO_clearerr(PL_parser->rsfp);
1336 else if (PL_parser->rsfp)
1337 (void)PerlIO_close(PL_parser->rsfp);
1338 PL_parser->rsfp = NULL;
60d63348 1339 PL_parser->in_pod = PL_parser->filtered = 0;
f0e67a1d
Z
1340 if (!PL_in_eval && PL_minus_p) {
1341 sv_catpvs(linestr,
1342 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1343 PL_minus_n = PL_minus_p = 0;
1344 } else if (!PL_in_eval && PL_minus_n) {
1345 sv_catpvs(linestr, /*{*/";}");
1346 PL_minus_n = 0;
1347 } else
1348 sv_catpvs(linestr, ";");
1349 got_some = 1;
1350 }
1351 buf = SvPVX(linestr);
1352 new_bufend_pos = SvCUR(linestr);
1353 PL_parser->bufend = buf + new_bufend_pos;
1354 PL_parser->bufptr = buf + bufptr_pos;
1355 PL_parser->oldbufptr = buf + oldbufptr_pos;
1356 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1357 PL_parser->linestart = buf + linestart_pos;
1358 if (PL_parser->last_uni)
1359 PL_parser->last_uni = buf + last_uni_pos;
1360 if (PL_parser->last_lop)
1361 PL_parser->last_lop = buf + last_lop_pos;
7f1c3e8c
FC
1362 if (PL_parser->preambling != NOLINE) {
1363 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1364 PL_parser->preambling = NOLINE;
1365 }
407f8cf2
KW
1366 if ( got_some_for_debugger
1367 && PERLDB_LINE_OR_SAVESRC
1368 && PL_curstash != PL_debstash)
1369 {
f0e67a1d
Z
1370 /* debugger active and we're not compiling the debugger code,
1371 * so store the line into the debugger's array of lines
1372 */
1373 update_debugger_info(NULL, buf+old_bufend_pos,
1374 new_bufend_pos-old_bufend_pos);
1375 }
1376 return got_some;
1377}
1378
1379/*
1380=for apidoc Amx|I32|lex_peek_unichar|U32 flags
1381
1382Looks ahead one (Unicode) character in the text currently being lexed.
1383Returns the codepoint (unsigned integer value) of the next character,
1384or -1 if lexing has reached the end of the input text. To consume the
1385peeked character, use L</lex_read_unichar>.
1386
1387If the next character is in (or extends into) the next chunk of input
1388text, the next chunk will be read in. Normally the current chunk will be
c5608a1f
KW
1389discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1390bit set, then the current chunk will not be discarded.
f0e67a1d
Z
1391
1392If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1393is encountered, an exception is generated.
1394
1395=cut
1396*/
1397
1398I32
1399Perl_lex_peek_unichar(pTHX_ U32 flags)
1400{
749123ff 1401 dVAR;
f0e67a1d
Z
1402 char *s, *bufend;
1403 if (flags & ~(LEX_KEEP_PREVIOUS))
1404 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1405 s = PL_parser->bufptr;
1406 bufend = PL_parser->bufend;
1407 if (UTF) {
1408 U8 head;
1409 I32 unichar;
1410 STRLEN len, retlen;
1411 if (s == bufend) {
1412 if (!lex_next_chunk(flags))
1413 return -1;
1414 s = PL_parser->bufptr;
1415 bufend = PL_parser->bufend;
1416 }
1417 head = (U8)*s;
54d004e8 1418 if (UTF8_IS_INVARIANT(head))
f0e67a1d 1419 return head;
54d004e8
KW
1420 if (UTF8_IS_START(head)) {
1421 len = UTF8SKIP(&head);
f0e67a1d
Z
1422 while ((STRLEN)(bufend-s) < len) {
1423 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1424 break;
1425 s = PL_parser->bufptr;
1426 bufend = PL_parser->bufend;
1427 }
1428 }
c80e42f3 1429 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
f0e67a1d
Z
1430 if (retlen == (STRLEN)-1) {
1431 /* malformed UTF-8 */
1432 ENTER;
1433 SAVESPTR(PL_warnhook);
1434 PL_warnhook = PERL_WARNHOOK_FATAL;
c80e42f3 1435 utf8n_to_uvchr((U8*)s, bufend-s, NULL, 0);
f0e67a1d
Z
1436 LEAVE;
1437 }
1438 return unichar;
1439 } else {
1440 if (s == bufend) {
1441 if (!lex_next_chunk(flags))
1442 return -1;
1443 s = PL_parser->bufptr;
1444 }
1445 return (U8)*s;
1446 }
1447}
1448
1449/*
1450=for apidoc Amx|I32|lex_read_unichar|U32 flags
1451
1452Reads the next (Unicode) character in the text currently being lexed.
1453Returns the codepoint (unsigned integer value) of the character read,
1454and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1455if lexing has reached the end of the input text. To non-destructively
1456examine the next character, use L</lex_peek_unichar> instead.
1457
1458If the next character is in (or extends into) the next chunk of input
1459text, the next chunk will be read in. Normally the current chunk will be
c5608a1f
KW
1460discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1461bit set, then the current chunk will not be discarded.
f0e67a1d
Z
1462
1463If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1464is encountered, an exception is generated.
1465
1466=cut
1467*/
1468
1469I32
1470Perl_lex_read_unichar(pTHX_ U32 flags)
1471{
1472 I32 c;
1473 if (flags & ~(LEX_KEEP_PREVIOUS))
1474 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1475 c = lex_peek_unichar(flags);
1476 if (c != -1) {
1477 if (c == '\n')
83944c01 1478 COPLINE_INC_WITH_HERELINES;
d9018cbe
EB
1479 if (UTF)
1480 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1481 else
1482 ++(PL_parser->bufptr);
f0e67a1d
Z
1483 }
1484 return c;
1485}
1486
1487/*
1488=for apidoc Amx|void|lex_read_space|U32 flags
1489
1490Reads optional spaces, in Perl style, in the text currently being
1491lexed. The spaces may include ordinary whitespace characters and
1492Perl-style comments. C<#line> directives are processed if encountered.
1493L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1494at a non-space character (or the end of the input text).
1495
1496If spaces extend into the next chunk of input text, the next chunk will
1497be read in. Normally the current chunk will be discarded at the same
c5608a1f 1498time, but if C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, then the current
f0e67a1d
Z
1499chunk will not be discarded.
1500
1501=cut
1502*/
1503
21791330 1504#define LEX_NO_INCLINE 0x40000000
f0998909
Z
1505#define LEX_NO_NEXT_CHUNK 0x80000000
1506
f0e67a1d
Z
1507void
1508Perl_lex_read_space(pTHX_ U32 flags)
1509{
1510 char *s, *bufend;
21791330 1511 const bool can_incline = !(flags & LEX_NO_INCLINE);
f0e67a1d 1512 bool need_incline = 0;
21791330 1513 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
f0e67a1d 1514 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
f0e67a1d
Z
1515 s = PL_parser->bufptr;
1516 bufend = PL_parser->bufend;
1517 while (1) {
1518 char c = *s;
1519 if (c == '#') {
1520 do {
1521 c = *++s;
1522 } while (!(c == '\n' || (c == 0 && s == bufend)));
1523 } else if (c == '\n') {
1524 s++;
21791330
FC
1525 if (can_incline) {
1526 PL_parser->linestart = s;
1527 if (s == bufend)
1528 need_incline = 1;
1529 else
1530 incline(s);
1531 }
f0e67a1d
Z
1532 } else if (isSPACE(c)) {
1533 s++;
1534 } else if (c == 0 && s == bufend) {
1535 bool got_more;
65c68e17 1536 line_t l;
f0998909
Z
1537 if (flags & LEX_NO_NEXT_CHUNK)
1538 break;
f0e67a1d 1539 PL_parser->bufptr = s;
65c68e17 1540 l = CopLINE(PL_curcop);
851b527a 1541 CopLINE(PL_curcop) += PL_parser->herelines + 1;
f0e67a1d 1542 got_more = lex_next_chunk(flags);
65c68e17 1543 CopLINE_set(PL_curcop, l);
f0e67a1d
Z
1544 s = PL_parser->bufptr;
1545 bufend = PL_parser->bufend;
1546 if (!got_more)
1547 break;
21791330 1548 if (can_incline && need_incline && PL_parser->rsfp) {
f0e67a1d
Z
1549 incline(s);
1550 need_incline = 0;
1551 }
3c47da3c
FC
1552 } else if (!c) {
1553 s++;
f0e67a1d
Z
1554 } else {
1555 break;
1556 }
1557 }
f0e67a1d
Z
1558 PL_parser->bufptr = s;
1559}
1560
1561/*
fe788d6b
PM
1562
1563=for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1564
1565This function performs syntax checking on a prototype, C<proto>.
1566If C<warn> is true, any illegal characters or mismatched brackets
1567will trigger illegalproto warnings, declaring that they were
1568detected in the prototype for C<name>.
1569
1570The return value is C<true> if this is a valid prototype, and
1571C<false> if it is not, regardless of whether C<warn> was C<true> or
1572C<false>.
1573
1574Note that C<NULL> is a valid C<proto> and will always return C<true>.
1575
1576=cut
1577
1578 */
1579
1580bool
1581Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1582{
1583 STRLEN len, origlen;
11327fa1 1584 char *p;
fe788d6b
PM
1585 bool bad_proto = FALSE;
1586 bool in_brackets = FALSE;
1587 bool after_slash = FALSE;
1588 char greedy_proto = ' ';
1589 bool proto_after_greedy_proto = FALSE;
1590 bool must_be_last = FALSE;
1591 bool underscore = FALSE;
f791a21a 1592 bool bad_proto_after_underscore = FALSE;
fe788d6b
PM
1593
1594 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1595
1596 if (!proto)
1597 return TRUE;
1598
11327fa1 1599 p = SvPV(proto, len);
fe788d6b
PM
1600 origlen = len;
1601 for (; len--; p++) {
1602 if (!isSPACE(*p)) {
1603 if (must_be_last)
1604 proto_after_greedy_proto = TRUE;
f791a21a
PM
1605 if (underscore) {
1606 if (!strchr(";@%", *p))
1607 bad_proto_after_underscore = TRUE;
1608 underscore = FALSE;
1609 }
fe788d6b
PM
1610 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1611 bad_proto = TRUE;
1612 }
1613 else {
fe788d6b
PM
1614 if (*p == '[')
1615 in_brackets = TRUE;
1616 else if (*p == ']')
1617 in_brackets = FALSE;
407f8cf2
KW
1618 else if ((*p == '@' || *p == '%')
1619 && !after_slash
1620 && !in_brackets )
1621 {
fe788d6b
PM
1622 must_be_last = TRUE;
1623 greedy_proto = *p;
1624 }
1625 else if (*p == '_')
f791a21a 1626 underscore = TRUE;
fe788d6b
PM
1627 }
1628 if (*p == '\\')
1629 after_slash = TRUE;
1630 else
1631 after_slash = FALSE;
1632 }
1633 }
1634
1635 if (warn) {
b54d603d 1636 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
fe788d6b 1637 p -= origlen;
b54d603d
PM
1638 p = SvUTF8(proto)
1639 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1640 origlen, UNI_DISPLAY_ISPRINT)
1641 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1642
fe788d6b
PM
1643 if (proto_after_greedy_proto)
1644 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
147e3846 1645 "Prototype after '%c' for %" SVf " : %s",
fe788d6b 1646 greedy_proto, SVfARG(name), p);
50278ed0
PM
1647 if (in_brackets)
1648 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
147e3846 1649 "Missing ']' in prototype for %" SVf " : %s",
50278ed0 1650 SVfARG(name), p);
b54d603d 1651 if (bad_proto)
fe788d6b 1652 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
147e3846 1653 "Illegal character in prototype for %" SVf " : %s",
f791a21a
PM
1654 SVfARG(name), p);
1655 if (bad_proto_after_underscore)
1656 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
147e3846 1657 "Illegal character after '_' in prototype for %" SVf " : %s",
f791a21a 1658 SVfARG(name), p);
fe788d6b
PM
1659 }
1660
1661 return (! (proto_after_greedy_proto || bad_proto) );
1662}
1663
1664/*
ffb4593c
NT
1665 * S_incline
1666 * This subroutine has nothing to do with tilting, whether at windmills
1667 * or pinball tables. Its name is short for "increment line". It
57843af0 1668 * increments the current line number in CopLINE(PL_curcop) and checks
ffb4593c 1669 * to see whether the line starts with a comment of the form
9cbb5ea2
GS
1670 * # line 500 "foo.pm"
1671 * If so, it sets the current line number and file to the values in the comment.
ffb4593c
NT
1672 */
1673
76e3520e 1674STATIC void
d9095cec 1675S_incline(pTHX_ const char *s)
463ee0b2 1676{
d9095cec
NC
1677 const char *t;
1678 const char *n;
1679 const char *e;
8818d409 1680 line_t line_num;
22ff3130 1681 UV uv;
463ee0b2 1682
7918f24d
NC
1683 PERL_ARGS_ASSERT_INCLINE;
1684
83944c01 1685 COPLINE_INC_WITH_HERELINES;
451f421f
FC
1686 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1687 && s+1 == PL_bufend && *s == ';') {
1688 /* fake newline in string eval */
1689 CopLINE_dec(PL_curcop);
1690 return;
1691 }
463ee0b2
LW
1692 if (*s++ != '#')
1693 return;
d4c19fe8
AL
1694 while (SPACE_OR_TAB(*s))
1695 s++;
847cc851 1696 if (strEQs(s, "line"))
73659bf1
GS
1697 s += 4;
1698 else
1699 return;
084592ab 1700 if (SPACE_OR_TAB(*s))
73659bf1 1701 s++;
4e553d73 1702 else
73659bf1 1703 return;
d4c19fe8
AL
1704 while (SPACE_OR_TAB(*s))
1705 s++;
463ee0b2
LW
1706 if (!isDIGIT(*s))
1707 return;
d4c19fe8 1708
463ee0b2
LW
1709 n = s;
1710 while (isDIGIT(*s))
1711 s++;
07714eb4 1712 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
26b6dc3f 1713 return;
bf4acbe4 1714 while (SPACE_OR_TAB(*s))
463ee0b2 1715 s++;
73659bf1 1716 if (*s == '"' && (t = strchr(s+1, '"'))) {
463ee0b2 1717 s++;
73659bf1
GS
1718 e = t + 1;
1719 }
463ee0b2 1720 else {
c35e046a 1721 t = s;
1bb1a3d6 1722 while (*t && !isSPACE(*t))
c35e046a 1723 t++;
73659bf1 1724 e = t;
463ee0b2 1725 }
bf4acbe4 1726 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
73659bf1
GS
1727 e++;
1728 if (*e != '\n' && *e != '\0')
1729 return; /* false alarm */
1730
22ff3130
HS
1731 if (!grok_atoUV(n, &uv, &e))
1732 return;
1733 line_num = ((line_t)uv) - 1;
8818d409 1734
f4dd75d9 1735 if (t - s > 0) {
d9095cec 1736 const STRLEN len = t - s;
3df32bda 1737
d36ee5be 1738 if (!PL_rsfp && !PL_parser->filtered) {
e66cf94c
RGS
1739 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1740 * to *{"::_<newfilename"} */
44867030
NC
1741 /* However, the long form of evals is only turned on by the
1742 debugger - usually they're "(eval %lu)" */
d36ee5be
FC
1743 GV * const cfgv = CopFILEGV(PL_curcop);
1744 if (cfgv) {
38bd7ad8
FC
1745 char smallbuf[128];
1746 STRLEN tmplen2 = len;
44867030 1747 char *tmpbuf2;
449dd039 1748 GV *gv2;
44867030
NC
1749
1750 if (tmplen2 + 2 <= sizeof smallbuf)
1751 tmpbuf2 = smallbuf;
1752 else
1753 Newx(tmpbuf2, tmplen2 + 2, char);
1754
38bd7ad8
FC
1755 tmpbuf2[0] = '_';
1756 tmpbuf2[1] = '<';
44867030
NC
1757
1758 memcpy(tmpbuf2 + 2, s, tmplen2);
1759 tmplen2 += 2;
1760
8a5ee598 1761 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
e5527e4b 1762 if (!isGV(gv2)) {
8a5ee598 1763 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
e5527e4b
RGS
1764 /* adjust ${"::_<newfilename"} to store the new file name */
1765 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
8818d409
FC
1766 /* The line number may differ. If that is the case,
1767 alias the saved lines that are in the array.
1768 Otherwise alias the whole array. */
1769 if (CopLINE(PL_curcop) == line_num) {
38bd7ad8
FC
1770 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1771 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
8818d409 1772 }
38bd7ad8
FC
1773 else if (GvAV(cfgv)) {
1774 AV * const av = GvAV(cfgv);
8818d409
FC
1775 const I32 start = CopLINE(PL_curcop)+1;
1776 I32 items = AvFILLp(av) - start;
1777 if (items > 0) {
1778 AV * const av2 = GvAVn(gv2);
1779 SV **svp = AvARRAY(av) + start;
1780 I32 l = (I32)line_num+1;
1781 while (items--)
1782 av_store(av2, l++, SvREFCNT_inc(*svp++));
1783 }
1784 }
e5527e4b 1785 }
44867030
NC
1786
1787 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
d36ee5be 1788 }
e66cf94c 1789 }
05ec9bb3 1790 CopFILE_free(PL_curcop);
449dd039 1791 CopFILE_setn(PL_curcop, s, len);
f4dd75d9 1792 }
8818d409 1793 CopLINE_set(PL_curcop, line_num);
463ee0b2
LW
1794}
1795
80a702cd 1796STATIC void
15f169a1 1797S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
80a702cd
RGS
1798{
1799 AV *av = CopFILEAVx(PL_curcop);
1800 if (av) {
7f1c3e8c
FC
1801 SV * sv;
1802 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1803 else {
1804 sv = *av_fetch(av, 0, 1);
1805 SvUPGRADE(sv, SVt_PVMG);
1806 }
847cc851 1807 if (!SvPOK(sv)) SvPVCLEAR(sv);
5fa550fb 1808 if (orig_sv)
7f1c3e8c 1809 sv_catsv(sv, orig_sv);
5fa550fb 1810 else
7f1c3e8c
FC
1811 sv_catpvn(sv, buf, len);
1812 if (!SvIOK(sv)) {
1813 (void)SvIOK_on(sv);
1814 SvIV_set(sv, 0);
1815 }
1816 if (PL_parser->preambling == NOLINE)
1817 av_store(av, CopLINE(PL_curcop), sv);
80a702cd
RGS
1818 }
1819}
1820
ffb4593c 1821/*
8c6b0c7d 1822 * skipspace
ffb4593c
NT
1823 * Called to gobble the appropriate amount and type of whitespace.
1824 * Skips comments as well.
71fff7cb 1825 * Returns the next character after the whitespace that is skipped.
8c6b0c7d
FC
1826 *
1827 * peekspace
1828 * Same thing, but look ahead without incrementing line numbers or
1829 * adjusting PL_linestart.
ffb4593c
NT
1830 */
1831
3218e223 1832#define skipspace(s) skipspace_flags(s, 0)
8c6b0c7d 1833#define peekspace(s) skipspace_flags(s, LEX_NO_INCLINE)
3218e223 1834
76e3520e 1835STATIC char *
21791330 1836S_skipspace_flags(pTHX_ char *s, U32 flags)
a687059c 1837{
21791330 1838 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
3280af22 1839 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3c47da3c 1840 while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s))
463ee0b2 1841 s++;
f0e67a1d
Z
1842 } else {
1843 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1844 PL_bufptr = s;
21791330 1845 lex_read_space(flags | LEX_KEEP_PREVIOUS |
d27f4b91 1846 (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ?
f0998909 1847 LEX_NO_NEXT_CHUNK : 0));
3280af22 1848 s = PL_bufptr;
f0e67a1d
Z
1849 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1850 if (PL_linestart > PL_bufptr)
1851 PL_bufptr = PL_linestart;
1852 return s;
463ee0b2 1853 }
5db06880 1854 return s;
a687059c 1855}
378cc40b 1856
ffb4593c
NT
1857/*
1858 * S_check_uni
1859 * Check the unary operators to ensure there's no ambiguity in how they're
1860 * used. An ambiguous piece of code would be:
1861 * rand + 5
1862 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1863 * the +5 is its argument.
1864 */
1865
76e3520e 1866STATIC void
cea2e8a9 1867S_check_uni(pTHX)
ba106d47 1868{
d4c19fe8
AL
1869 const char *s;
1870 const char *t;
2f3197b3 1871
3280af22 1872 if (PL_oldoldbufptr != PL_last_uni)
2f3197b3 1873 return;
3280af22
NIS
1874 while (isSPACE(*PL_last_uni))
1875 PL_last_uni++;
c35e046a 1876 s = PL_last_uni;
8a2bca12 1877 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
8ce2ba82 1878 s += UTF ? UTF8SKIP(s) : 1;
3280af22 1879 if ((t = strchr(s, '(')) && t < PL_bufptr)
a0d0e21e 1880 return;
6136c704 1881
9b387841 1882 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
147e3846 1883 "Warning: Use of \"%" UTF8f "\" without parentheses is ambiguous",
b59c097b 1884 UTF8fARG(UTF, (int)(s - PL_last_uni), PL_last_uni));
2f3197b3
LW
1885}
1886
ffb4593c
NT
1887/*
1888 * LOP : macro to build a list operator. Its behaviour has been replaced
1889 * with a subroutine, S_lop() for which LOP is just another name.
1890 */
1891
a0d0e21e
LW
1892#define LOP(f,x) return lop(f,x,s)
1893
ffb4593c
NT
1894/*
1895 * S_lop
1896 * Build a list operator (or something that might be one). The rules:
41e8cbf4
FC
1897 * - if we have a next token, then it's a list operator (no parens) for
1898 * which the next token has already been parsed; e.g.,
1899 * sort foo @args
1900 * sort foo (@args)
ffb4593c
NT
1901 * - if the next thing is an opening paren, then it's a function
1902 * - else it's a list operator
1903 */
1904
76e3520e 1905STATIC I32
11288bb3 1906S_lop(pTHX_ I32 f, U8 x, char *s)
ffed7fef 1907{
7918f24d
NC
1908 PERL_ARGS_ASSERT_LOP;
1909
6154021b 1910 pl_yylval.ival = f;
35c8bce7 1911 CLINE;
3280af22
NIS
1912 PL_bufptr = s;
1913 PL_last_lop = PL_oldbufptr;
eb160463 1914 PL_last_lop_op = (OPCODE)f;
3280af22 1915 if (PL_nexttoke)
78cdf107 1916 goto lstop;
19f1898a 1917 PL_expect = x;
79072805 1918 if (*s == '(')
bbf60fe6 1919 return REPORT(FUNC);
294a536f 1920 s = skipspace(s);
79072805 1921 if (*s == '(')
bbf60fe6 1922 return REPORT(FUNC);
78cdf107
Z
1923 else {
1924 lstop:
1925 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1926 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
bbf60fe6 1927 return REPORT(LSTOP);
78cdf107 1928 }
79072805
LW
1929}
1930
ffb4593c
NT
1931/*
1932 * S_force_next
9cbb5ea2 1933 * When the lexer realizes it knows the next token (for instance,
ffb4593c 1934 * it is reordering tokens for the parser) then it can call S_force_next
9cbb5ea2 1935 * to know what token to return the next time the lexer is called. Caller
b5bbe64a
JH
1936 * will need to set PL_nextval[] and possibly PL_expect to ensure
1937 * the lexer handles the token correctly.
ffb4593c
NT
1938 */
1939
4e553d73 1940STATIC void
cea2e8a9 1941S_force_next(pTHX_ I32 type)
79072805 1942{
704d4215
GG
1943#ifdef DEBUGGING
1944 if (DEBUG_T_TEST) {
1945 PerlIO_printf(Perl_debug_log, "### forced token:\n");
f05d7009 1946 tokereport(type, &NEXTVAL_NEXTTOKE);
704d4215
GG
1947 }
1948#endif
1f7c3e7c 1949 assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype));
3280af22
NIS
1950 PL_nexttype[PL_nexttoke] = type;
1951 PL_nexttoke++;
79072805
LW
1952}
1953
89f35911
FC
1954/*
1955 * S_postderef
1956 *
1957 * This subroutine handles postfix deref syntax after the arrow has already
1958 * been emitted. @* $* etc. are emitted as two separate token right here.
1959 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
1960 * only the first, leaving yylex to find the next.
89f35911
FC
1961 */
1962
1963static int
ff25e5db 1964S_postderef(pTHX_ int const funny, char const next)
89f35911 1965{
ff25e5db 1966 assert(funny == DOLSHARP || strchr("$@%&*", funny));
89f35911
FC
1967 if (next == '*') {
1968 PL_expect = XOPERATOR;
cc624add 1969 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
ff25e5db 1970 assert('@' == funny || '$' == funny || DOLSHARP == funny);
cc624add 1971 PL_lex_state = LEX_INTERPEND;
c3492809
FC
1972 if ('@' == funny)
1973 force_next(POSTJOIN);
cc624add 1974 }
89f35911
FC
1975 force_next(next);
1976 PL_bufptr+=2;
1977 }
1978 else {
760ca746
FC
1979 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
1980 && !PL_lex_brackets)
1981 PL_lex_dojoin = 2;
89f35911
FC
1982 PL_expect = XOPERATOR;
1983 PL_bufptr++;
1984 }
1985 return funny;
1986}
1987
28ac2b49
Z
1988void
1989Perl_yyunlex(pTHX)
1990{
a7aaec61
Z
1991 int yyc = PL_parser->yychar;
1992 if (yyc != YYEMPTY) {
1993 if (yyc) {
a7aaec61
Z
1994 NEXTVAL_NEXTTOKE = PL_parser->yylval;
1995 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
78cdf107 1996 PL_lex_allbrackets--;
a7aaec61 1997 PL_lex_brackets--;
78cdf107
Z
1998 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
1999 } else if (yyc == '('/*)*/) {
2000 PL_lex_allbrackets--;
2001 yyc |= (2<<24);
a7aaec61
Z
2002 }
2003 force_next(yyc);
2004 }
28ac2b49
Z
2005 PL_parser->yychar = YYEMPTY;
2006 }
2007}
2008
d0a148a6 2009STATIC SV *
15f169a1 2010S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
d0a148a6 2011{
740cce10 2012 SV * const sv = newSVpvn_utf8(start, len,
c5f058df
KW
2013 !IN_BYTES
2014 && UTF
2015 && !is_utf8_invariant_string((const U8*)start, len)
2016 && is_utf8_string((const U8*)start, len));
d0a148a6
NC
2017 return sv;
2018}
2019
ffb4593c
NT
2020/*
2021 * S_force_word
2022 * When the lexer knows the next thing is a word (for instance, it has
2023 * just seen -> and it knows that the next char is a word char, then
02b34bbe
DM
2024 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2025 * lookahead.
ffb4593c
NT
2026 *
2027 * Arguments:
b1b65b59 2028 * char *start : buffer position (must be within PL_linestr)
185c2e96
DM
2029 * int token : PL_next* will be this type of bare word
2030 * (e.g., METHOD,BAREWORD)
ffb4593c
NT
2031 * int check_keyword : if true, Perl checks to make sure the word isn't
2032 * a keyword (do this if the word is a label, e.g. goto FOO)
2033 * int allow_pack : if true, : characters will also be allowed (require,
2034 * use, etc. do this)
ffb4593c
NT
2035 */
2036
76e3520e 2037STATIC char *
345b3785 2038S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
79072805 2039{
eb578fdb 2040 char *s;
463ee0b2 2041 STRLEN len;
4e553d73 2042
7918f24d
NC
2043 PERL_ARGS_ASSERT_FORCE_WORD;
2044
294a536f 2045 start = skipspace(start);
463ee0b2 2046 s = start;
407f8cf2 2047 if (isIDFIRST_lazy_if(s,UTF)
e7127e21 2048 || (allow_pack && *s == ':' && s[1] == ':') )
a0d0e21e 2049 {
3280af22 2050 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
01b5ef50
FC
2051 if (check_keyword) {
2052 char *s2 = PL_tokenbuf;
487e470d 2053 STRLEN len2 = len;
847cc851 2054 if (allow_pack && len > 6 && strEQs(s2, "CORE::"))
487e470d
FC
2055 s2 += 6, len2 -= 6;
2056 if (keyword(s2, len2, 0))
463ee0b2 2057 return start;
01b5ef50 2058 }
463ee0b2 2059 if (token == METHOD) {
294a536f 2060 s = skipspace(s);
463ee0b2 2061 if (*s == '(')
3280af22 2062 PL_expect = XTERM;
463ee0b2 2063 else {
3280af22 2064 PL_expect = XOPERATOR;
463ee0b2 2065 }
79072805 2066 }
9ded7720 2067 NEXTVAL_NEXTTOKE.opval
275103cd 2068 = newSVOP(OP_CONST,0,
d0a148a6 2069 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
9ded7720 2070 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
79072805
LW
2071 force_next(token);
2072 }
2073 return s;
2074}
2075
ffb4593c
NT
2076/*
2077 * S_force_ident
9cbb5ea2 2078 * Called when the lexer wants $foo *foo &foo etc, but the program
ffb4593c
NT
2079 * text only contains the "foo" portion. The first argument is a pointer
2080 * to the "foo", and the second argument is the type symbol to prefix.
185c2e96 2081 * Forces the next token to be a "BAREWORD".
9cbb5ea2 2082 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
ffb4593c
NT
2083 */
2084
76e3520e 2085STATIC void
5aaab254 2086S_force_ident(pTHX_ const char *s, int kind)
79072805 2087{
7918f24d
NC
2088 PERL_ARGS_ASSERT_FORCE_IDENT;
2089
c9b48522
DD
2090 if (s[0]) {
2091 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
275103cd 2092 OP* const o = newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
728847b1 2093 UTF ? SVf_UTF8 : 0));
9ded7720 2094 NEXTVAL_NEXTTOKE.opval = o;
185c2e96 2095 force_next(BAREWORD);
748a9306 2096 if (kind) {
11343788 2097 o->op_private = OPpCONST_ENTERED;
55497cff
PP
2098 /* XXX see note in pp_entereval() for why we forgo typo
2099 warnings if the symbol must be introduced in an eval.
2100 GSAR 96-10-12 */
90e5519e 2101 gv_fetchpvn_flags(s, len,
4bff32c5 2102 (PL_in_eval ? GV_ADDMULTI
728847b1 2103 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
90e5519e
NC
2104 kind == '$' ? SVt_PV :
2105 kind == '@' ? SVt_PVAV :
2106 kind == '%' ? SVt_PVHV :
a0d0e21e 2107 SVt_PVGV
90e5519e 2108 );
748a9306 2109 }
79072805
LW
2110 }
2111}
2112
3f33d153
FC
2113static void
2114S_force_ident_maybe_lex(pTHX_ char pit)
2115{
3f33d153
FC
2116 NEXTVAL_NEXTTOKE.ival = pit;
2117 force_next('p');
2118}
2119
1571675a
GS
2120NV
2121Perl_str_to_version(pTHX_ SV *sv)
2122{
2123 NV retval = 0.0;
2124 NV nshift = 1.0;
2125 STRLEN len;
cfd0369c 2126 const char *start = SvPV_const(sv,len);
9d4ba2ae 2127 const char * const end = start + len;
504618e9 2128 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
7918f24d
NC
2129
2130 PERL_ARGS_ASSERT_STR_TO_VERSION;
2131
1571675a 2132 while (start < end) {
ba210ebe 2133 STRLEN skip;
1571675a
GS
2134 UV n;
2135 if (utf)
9041c2e3 2136 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1571675a
GS
2137 else {
2138 n = *(U8*)start;
2139 skip = 1;
2140 }
2141 retval += ((NV)n)/nshift;
2142 start += skip;
2143 nshift *= 1000;
2144 }
2145 return retval;
2146}
2147
4e553d73 2148/*
ffb4593c
NT
2149 * S_force_version
2150 * Forces the next token to be a version number.
e759cc13
RGS
2151 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2152 * and if "guessing" is TRUE, then no new token is created (and the caller
2153 * must use an alternative parsing method).
ffb4593c
NT
2154 */
2155
76e3520e 2156STATIC char *
e759cc13 2157S_force_version(pTHX_ char *s, int guessing)
89bfa8cd 2158{
5f66b61c 2159 OP *version = NULL;
44dcb63b 2160 char *d;
89bfa8cd 2161
7918f24d
NC
2162 PERL_ARGS_ASSERT_FORCE_VERSION;
2163
294a536f 2164 s = skipspace(s);
89bfa8cd 2165
44dcb63b 2166 d = s;
dd629d5b 2167 if (*d == 'v')
44dcb63b 2168 d++;
44dcb63b 2169 if (isDIGIT(*d)) {
e759cc13
RGS
2170 while (isDIGIT(*d) || *d == '_' || *d == '.')
2171 d++;
4e4da3ac 2172 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
dd629d5b 2173 SV *ver;
6154021b
RGS
2174 s = scan_num(s, &pl_yylval);
2175 version = pl_yylval.opval;
dd629d5b
GS
2176 ver = cSVOPx(version)->op_sv;
2177 if (SvPOK(ver) && !SvNIOK(ver)) {
862a34c6 2178 SvUPGRADE(ver, SVt_PVNV);
9d6ce603 2179 SvNV_set(ver, str_to_version(ver));
1571675a 2180 SvNOK_on(ver); /* hint that it is a version */
44dcb63b 2181 }
89bfa8cd 2182 }
5db06880 2183 else if (guessing) {
e759cc13 2184 return s;
5db06880 2185 }
89bfa8cd
PP
2186 }
2187
2188 /* NOTE: The parser sees the package name and the VERSION swapped */
9ded7720 2189 NEXTVAL_NEXTTOKE.opval = version;
185c2e96 2190 force_next(BAREWORD);
89bfa8cd 2191
e759cc13 2192 return s;
89bfa8cd
PP
2193}
2194
ffb4593c 2195/*
91152fc1
DG
2196 * S_force_strict_version
2197 * Forces the next token to be a version number using strict syntax rules.
2198 */
2199
2200STATIC char *
2201S_force_strict_version(pTHX_ char *s)
2202{
91152fc1 2203 OP *version = NULL;
91152fc1
DG
2204 const char *errstr = NULL;
2205
2206 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2207
2208 while (isSPACE(*s)) /* leading whitespace */
2209 s++;
2210
2211 if (is_STRICT_VERSION(s,&errstr)) {
2212 SV *ver = newSV(0);
2213 s = (char *)scan_version(s, ver, 0);
2214 version = newSVOP(OP_CONST, 0, ver);
2215 }
407f8cf2
KW
2216 else if ((*s != ';' && *s != '{' && *s != '}' )
2217 && (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
4e4da3ac 2218 {
91152fc1
DG
2219 PL_bufptr = s;
2220 if (errstr)
2221 yyerror(errstr); /* version required */
2222 return s;
2223 }
2224
91152fc1 2225 /* NOTE: The parser sees the package name and the VERSION swapped */
91152fc1 2226 NEXTVAL_NEXTTOKE.opval = version;
185c2e96 2227 force_next(BAREWORD);
91152fc1
DG
2228
2229 return s;
2230}
2231
2232/*
ffb4593c
NT
2233 * S_tokeq
2234 * Tokenize a quoted string passed in as an SV. It finds the next
2235 * chunk, up to end of string or a backslash. It may make a new
2236 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2237 * turns \\ into \.
2238 */
2239
76e3520e 2240STATIC SV *
cea2e8a9 2241S_tokeq(pTHX_ SV *sv)
79072805 2242{
eb578fdb
KW
2243 char *s;
2244 char *send;
2245 char *d;
b3ac6de7 2246 SV *pv = sv;
79072805 2247
7918f24d
NC
2248 PERL_ARGS_ASSERT_TOKEQ;
2249
279b35ad
FC
2250 assert (SvPOK(sv));
2251 assert (SvLEN(sv));
2252 assert (!SvIsCOW(sv));
307ed071 2253 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
b3ac6de7 2254 goto finish;
279b35ad
FC
2255 s = SvPVX(sv);
2256 send = SvEND(sv);
dcb21ed6
NC
2257 /* This is relying on the SV being "well formed" with a trailing '\0' */
2258 while (s < send && !(*s == '\\' && s[1] == '\\'))
79072805
LW
2259 s++;
2260 if (s == send)
b3ac6de7 2261 goto finish;
79072805 2262 d = s;
be4731d2 2263 if ( PL_hints & HINT_NEW_STRING ) {
279b35ad
FC
2264 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2265 SVs_TEMP | SvUTF8(sv));
be4731d2 2266 }
79072805
LW
2267 while (s < send) {
2268 if (*s == '\\') {
a0d0e21e 2269 if (s + 1 < send && (s[1] == '\\'))
79072805
LW
2270 s++; /* all that, just for this */
2271 }
2272 *d++ = *s++;
2273 }
2274 *d = '\0';
95a20fc0 2275 SvCUR_set(sv, d - SvPVX_const(sv));
b3ac6de7 2276 finish:
3280af22 2277 if ( PL_hints & HINT_NEW_STRING )
eb0d8d16 2278 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
79072805
LW
2279 return sv;
2280}
2281
ffb4593c
NT
2282/*
2283 * Now come three functions related to double-quote context,
2284 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2285 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2286 * interact with PL_lex_state, and create fake ( ... ) argument lists
2287 * to handle functions and concatenation.
ecd24171
DM
2288 * For example,
2289 * "foo\lbar"
2290 * is tokenised as
2291 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
ffb4593c
NT
2292 */
2293
2294/*
2295 * S_sublex_start
6154021b 2296 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
ffb4593c
NT
2297 *
2298 * Pattern matching will set PL_lex_op to the pattern-matching op to
6154021b 2299 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
ffb4593c 2300 *
16d1d8bd 2301 * OP_CONST is easy--just make the new op and return.
ffb4593c
NT
2302 *
2303 * Everything else becomes a FUNC.
2304 *
16d1d8bd
LM
2305 * Sets PL_lex_state to LEX_INTERPPUSH unless ival was OP_NULL or we
2306 * had an OP_CONST. This just sets us up for a
ffb4593c
NT
2307 * call to S_sublex_push().
2308 */
2309
76e3520e 2310STATIC I32
cea2e8a9 2311S_sublex_start(pTHX)
79072805 2312{
eb578fdb 2313 const I32 op_type = pl_yylval.ival;
79072805
LW
2314
2315 if (op_type == OP_NULL) {
6154021b 2316 pl_yylval.opval = PL_lex_op;
5f66b61c 2317 PL_lex_op = NULL;
79072805
LW
2318 return THING;
2319 }
466112bb 2320 if (op_type == OP_CONST) {
67c71cbb
FC
2321 SV *sv = PL_lex_stuff;
2322 PL_lex_stuff = NULL;
2323 sv = tokeq(sv);
b3ac6de7
IZ
2324
2325 if (SvTYPE(sv) == SVt_PVIV) {
2326 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2327 STRLEN len;
96a5add6 2328 const char * const p = SvPV_const(sv, len);
740cce10 2329 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
b3ac6de7
IZ
2330 SvREFCNT_dec(sv);
2331 sv = nsv;
4e553d73 2332 }
275103cd 2333 pl_yylval.opval = newSVOP(op_type, 0, sv);
79072805
LW
2334 return THING;
2335 }
2336
7ef70b3d
FC
2337 PL_parser->lex_super_state = PL_lex_state;
2338 PL_parser->lex_sub_inwhat = (U16)op_type;
2339 PL_parser->lex_sub_op = PL_lex_op;
3280af22 2340 PL_lex_state = LEX_INTERPPUSH;
55497cff 2341
3280af22
NIS
2342 PL_expect = XTERM;
2343 if (PL_lex_op) {
6154021b 2344 pl_yylval.opval = PL_lex_op;
5f66b61c 2345 PL_lex_op = NULL;
55497cff
PP
2346 return PMFUNC;
2347 }
2348 else
2349 return FUNC;
2350}
2351
ffb4593c
NT
2352/*
2353 * S_sublex_push
2354 * Create a new scope to save the lexing state. The scope will be
2355 * ended in S_sublex_done. Returns a '(', starting the function arguments
2356 * to the uc, lc, etc. found before.
2357 * Sets PL_lex_state to LEX_INTERPCONCAT.
2358 */
2359
76e3520e 2360STATIC I32
cea2e8a9 2361S_sublex_push(pTHX)
55497cff 2362{
78a635de 2363 LEXSHARED *shared;
801d32ac 2364 const bool is_heredoc = PL_multi_close == '<';
f46d017c 2365 ENTER;
55497cff 2366
7ef70b3d 2367 PL_lex_state = PL_parser->lex_super_state;
cc624add 2368 SAVEI8(PL_lex_dojoin);
3280af22 2369 SAVEI32(PL_lex_brackets);
78cdf107 2370 SAVEI32(PL_lex_allbrackets);
b27dce25 2371 SAVEI32(PL_lex_formbrack);
78cdf107 2372 SAVEI8(PL_lex_fakeeof);
3280af22
NIS
2373 SAVEI32(PL_lex_casemods);
2374 SAVEI32(PL_lex_starts);
651b5b28 2375 SAVEI8(PL_lex_state);
7cc34111 2376 SAVESPTR(PL_lex_repl);
7766f137 2377 SAVEVPTR(PL_lex_inpat);
98246f1e 2378 SAVEI16(PL_lex_inwhat);
ffdb8b16 2379 if (is_heredoc)
b42366d4 2380 {
ffdb8b16 2381 SAVECOPLINE(PL_curcop);
b42366d4 2382 SAVEI32(PL_multi_end);
851b527a
FC
2383 SAVEI32(PL_parser->herelines);
2384 PL_parser->herelines = 0;
b42366d4 2385 }
2ca4363d 2386 SAVEIV(PL_multi_close);
3280af22 2387 SAVEPPTR(PL_bufptr);
8452ff4b 2388 SAVEPPTR(PL_bufend);
3280af22
NIS
2389 SAVEPPTR(PL_oldbufptr);
2390 SAVEPPTR(PL_oldoldbufptr);
207e3d1a
JH
2391 SAVEPPTR(PL_last_lop);
2392 SAVEPPTR(PL_last_uni);
3280af22
NIS
2393 SAVEPPTR(PL_linestart);
2394 SAVESPTR(PL_linestr);
8edd5f42
RGS
2395 SAVEGENERICPV(PL_lex_brackstack);
2396 SAVEGENERICPV(PL_lex_casestack);
78a635de 2397 SAVEGENERICPV(PL_parser->lex_shared);
3a54fd60 2398 SAVEBOOL(PL_parser->lex_re_reparsing);
ffdb8b16 2399 SAVEI32(PL_copline);
3280af22 2400
99bd9d90 2401 /* The here-doc parser needs to be able to peek into outer lexing
60f40a38
FC
2402 scopes to find the body of the here-doc. So we put PL_linestr and
2403 PL_bufptr into lex_shared, to ‘share’ those values.
99bd9d90 2404 */
60f40a38
FC
2405 PL_parser->lex_shared->ls_linestr = PL_linestr;
2406 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
99bd9d90 2407
3280af22 2408 PL_linestr = PL_lex_stuff;
7ef70b3d 2409 PL_lex_repl = PL_parser->lex_sub_repl;
a0714e2c 2410 PL_lex_stuff = NULL;
7ef70b3d 2411 PL_parser->lex_sub_repl = NULL;
3280af22 2412
eabab8bc
FC
2413 /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2414 set for an inner quote-like operator and then an error causes scope-
2415 popping. We must not have a PL_lex_stuff value left dangling, as
2416 that breaks assumptions elsewhere. See bug #123617. */
2417 SAVEGENERICSV(PL_lex_stuff);
7ef70b3d 2418 SAVEGENERICSV(PL_parser->lex_sub_repl);
eabab8bc 2419
9cbb5ea2
GS
2420 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2421 = SvPVX(PL_linestr);
3280af22 2422 PL_bufend += SvCUR(PL_linestr);
bd61b366 2423 PL_last_lop = PL_last_uni = NULL;
3280af22 2424 SAVEFREESV(PL_linestr);
4dc843bc 2425 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
3280af22
NIS
2426
2427 PL_lex_dojoin = FALSE;
b27dce25 2428 PL_lex_brackets = PL_lex_formbrack = 0;
78cdf107
Z
2429 PL_lex_allbrackets = 0;
2430 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
a02a5408
JC
2431 Newx(PL_lex_brackstack, 120, char);
2432 Newx(PL_lex_casestack, 12, char);
3280af22
NIS
2433 PL_lex_casemods = 0;
2434 *PL_lex_casestack = '\0';
2435 PL_lex_starts = 0;
2436 PL_lex_state = LEX_INTERPCONCAT;
ffdb8b16 2437 if (is_heredoc)
6ddcf93b 2438 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
ffdb8b16 2439 PL_copline = NOLINE;
78a635de
FC
2440
2441 Newxz(shared, 1, LEXSHARED);
2442 shared->ls_prev = PL_parser->lex_shared;
2443 PL_parser->lex_shared = shared;
3280af22 2444
7ef70b3d 2445 PL_lex_inwhat = PL_parser->lex_sub_inwhat;
bb16bae8 2446 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
3280af22 2447 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
7ef70b3d 2448 PL_lex_inpat = PL_parser->lex_sub_op;
79072805 2449 else
5f66b61c 2450 PL_lex_inpat = NULL;
79072805 2451
3a54fd60
DM
2452 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2453 PL_in_eval &= ~EVAL_RE_REPARSING;
2454
55497cff 2455 return '(';
79072805
LW
2456}
2457
ffb4593c
NT
2458/*
2459 * S_sublex_done
2460 * Restores lexer state after a S_sublex_push.
2461 */
2462
76e3520e 2463STATIC I32
cea2e8a9 2464S_sublex_done(pTHX)
79072805 2465{
3280af22 2466 if (!PL_lex_starts++) {
396482e1 2467 SV * const sv = newSVpvs("");
9aa983d2
JH
2468 if (SvUTF8(PL_linestr))
2469 SvUTF8_on(sv);
3280af22 2470 PL_expect = XOPERATOR;
275103cd 2471 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
79072805
LW
2472 return THING;
2473 }
2474
3280af22
NIS
2475 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2476 PL_lex_state = LEX_INTERPCASEMOD;
cea2e8a9 2477 return yylex();
79072805
LW
2478 }
2479
ffb4593c 2480 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
bb16bae8 2481 assert(PL_lex_inwhat != OP_TRANSR);
5aa91856
FC
2482 if (PL_lex_repl) {
2483 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
3280af22
NIS
2484 PL_linestr = PL_lex_repl;
2485 PL_lex_inpat = 0;
2486 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2487 PL_bufend += SvCUR(PL_linestr);
bd61b366 2488 PL_last_lop = PL_last_uni = NULL;
3280af22
NIS
2489 PL_lex_dojoin = FALSE;
2490 PL_lex_brackets = 0;
78cdf107
Z
2491 PL_lex_allbrackets = 0;
2492 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
3280af22
NIS
2493 PL_lex_casemods = 0;
2494 *PL_lex_casestack = '\0';
2495 PL_lex_starts = 0;
25da4f38 2496 if (SvEVALED(PL_lex_repl)) {
3280af22
NIS
2497 PL_lex_state = LEX_INTERPNORMAL;
2498 PL_lex_starts++;
e9fa98b2
HS
2499 /* we don't clear PL_lex_repl here, so that we can check later
2500 whether this is an evalled subst; that means we rely on the
2501 logic to ensure sublex_done() is called again only via the
2502 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
79072805 2503 }
e9fa98b2 2504 else {
3280af22 2505 PL_lex_state = LEX_INTERPCONCAT;
a0714e2c 2506 PL_lex_repl = NULL;
e9fa98b2 2507 }
ffdb8b16
FC
2508 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2509 CopLINE(PL_curcop) +=
9420b268 2510 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xnv_lines
851b527a
FC
2511 + PL_parser->herelines;
2512 PL_parser->herelines = 0;
ffdb8b16 2513 }
9b6b7be8 2514 return '/';
ffed7fef
LW
2515 }
2516 else {
b42366d4 2517 const line_t l = CopLINE(PL_curcop);
f46d017c 2518 LEAVE;
b42366d4 2519 if (PL_multi_close == '<')
851b527a 2520 PL_parser->herelines += l - PL_multi_end;
3280af22
NIS
2521 PL_bufend = SvPVX(PL_linestr);
2522 PL_bufend += SvCUR(PL_linestr);
2523 PL_expect = XOPERATOR;
79072805 2524 return ')';
ffed7fef
LW
2525 }
2526}
2527
6f613c73
KW
2528PERL_STATIC_INLINE SV*
2529S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2530{
140b12ad
KW
2531 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2532 * interior, hence to the "}". Finds what the name resolves to, returning
2533 * an SV* containing it; NULL if no valid one found */
2534
dd2b1b72 2535 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
6f613c73 2536
0c415a79
KW
2537 HV * table;
2538 SV **cvp;
2539 SV *cv;
2540 SV *rv;
2541 HV *stash;
2542 const U8* first_bad_char_loc;
2543 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2544
6f613c73
KW
2545 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2546
d8d26cac
KW
2547 if (!SvCUR(res)) {
2548 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
2549 "Unknown charname '' is deprecated");
b7e6151c 2550 return res;
d8d26cac 2551 }
b7e6151c 2552
107160e2
KW
2553 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2554 e - backslash_ptr,
2555 &first_bad_char_loc))
2556 {
2557 /* If warnings are on, this will print a more detailed analysis of what
2558 * is wrong than the error message below */
c80e42f3 2559 utf8n_to_uvchr(first_bad_char_loc,
107160e2
KW
2560 e - ((char *) first_bad_char_loc),
2561 NULL, 0);
2562
2563 /* We deliberately don't try to print the malformed character, which
2564 * might not print very well; it also may be just the first of many
2565 * malformations, so don't print what comes after it */
b59c097b 2566 yyerror_pv(Perl_form(aTHX_
107160e2 2567 "Malformed UTF-8 character immediately after '%.*s'",
b59c097b
AV
2568 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr),
2569 SVf_UTF8);
107160e2
KW
2570 return NULL;
2571 }
2572
2573 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2574 /* include the <}> */
2575 e - backslash_ptr + 1);
6f613c73 2576 if (! SvPOK(res)) {
b6407c49 2577 SvREFCNT_dec_NN(res);
6f613c73
KW
2578 return NULL;
2579 }
2580
0c415a79
KW
2581 /* See if the charnames handler is the Perl core's, and if so, we can skip
2582 * the validation needed for a user-supplied one, as Perl's does its own
2583 * validation. */
2584 table = GvHV(PL_hintgv); /* ^H */
2585 cvp = hv_fetchs(table, "charnames", FALSE);
5882ddb3
FC
2586 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2587 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
0c415a79
KW
2588 {
2589 const char * const name = HvNAME(stash);
6a642c21
FC
2590 if (HvNAMELEN(stash) == sizeof("_charnames")-1
2591 && strEQ(name, "_charnames")) {
0c415a79
KW
2592 return res;
2593 }
2594 }
2595
bde9e88d
KW
2596 /* Here, it isn't Perl's charname handler. We can't rely on a
2597 * user-supplied handler to validate the input name. For non-ut8 input,
2598 * look to see that the first character is legal. Then loop through the
2599 * rest checking that each is a continuation */
6f613c73 2600
36897d64
KW
2601 /* This code makes the reasonable assumption that the only Latin1-range
2602 * characters that begin a character name alias are alphabetic, otherwise
2603 * would have to create a isCHARNAME_BEGIN macro */
b6ba1137 2604
b6ba1137 2605 if (! UTF) {
bde9e88d 2606 if (! isALPHAU(*s)) {
b6ba1137
KW
2607 goto bad_charname;
2608 }
bde9e88d
KW
2609 s++;
2610 while (s < e) {
2611 if (! isCHARNAME_CONT(*s)) {
b6ba1137
KW
2612 goto bad_charname;
2613 }
2d8eb851
KW
2614 if (*s == ' ' && *(s-1) == ' ') {
2615 goto multi_spaces;
bd299e29 2616 }
bde9e88d 2617 s++;
b6ba1137
KW
2618 }
2619 }
2620 else {
bde9e88d
KW
2621 /* Similarly for utf8. For invariants can check directly; for other
2622 * Latin1, can calculate their code point and check; otherwise use a
2623 * swash */
2624 if (UTF8_IS_INVARIANT(*s)) {
2625 if (! isALPHAU(*s)) {
140b12ad
KW
2626 goto bad_charname;
2627 }
bde9e88d
KW
2628 s++;
2629 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
a62b247b 2630 if (! isALPHAU(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1)))) {
b6ba1137 2631 goto bad_charname;
6f613c73 2632 }
bde9e88d 2633 s += 2;
6f613c73 2634 }
bde9e88d
KW
2635 else {
2636 if (! PL_utf8_charname_begin) {
2637 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2638 PL_utf8_charname_begin = _core_swash_init("utf8",
2639 "_Perl_Charname_Begin",
2640 &PL_sv_undef,
2641 1, 0, NULL, &flags);
2642 }
2643 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2644 goto bad_charname;
2645 }
2646 s += UTF8SKIP(s);
2647 }
2648
2649 while (s < e) {
2650 if (UTF8_IS_INVARIANT(*s)) {
2651 if (! isCHARNAME_CONT(*s)) {
2652 goto bad_charname;
2653 }
2d8eb851
KW
2654 if (*s == ' ' && *(s-1) == ' ') {
2655 goto multi_spaces;
bd299e29 2656 }
bde9e88d
KW
2657 s++;
2658 }
2659 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
a62b247b 2660 if (! isCHARNAME_CONT(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1))))
bde9e88d
KW
2661 {
2662 goto bad_charname;
2663 }
2664 s += 2;
2665 }
2666 else {
2667 if (! PL_utf8_charname_continue) {
2668 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2669 PL_utf8_charname_continue = _core_swash_init("utf8",
2670 "_Perl_Charname_Continue",
2671 &PL_sv_undef,
2672 1, 0, NULL, &flags);
2673 }
2674 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2675 goto bad_charname;
2676 }
2677 s += UTF8SKIP(s);
6f613c73
KW
2678 }
2679 }
2d8eb851
KW
2680 }
2681 if (*(s-1) == ' ') {
2682 yyerror_pv(
2683 Perl_form(aTHX_
2684 "charnames alias definitions may not contain trailing "
2685 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2686 (int)(s - backslash_ptr + 1), backslash_ptr,
2687 (int)(e - s + 1), s + 1
2688 ),
2689 UTF ? SVf_UTF8 : 0);
2690 return NULL;
6f613c73
KW
2691 }
2692
94ca1619 2693 if (SvUTF8(res)) { /* Don't accept malformed input */
bde9e88d
KW
2694 const U8* first_bad_char_loc;
2695 STRLEN len;
2696 const char* const str = SvPV_const(res, len);
2697 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2698 /* If warnings are on, this will print a more detailed analysis of
2699 * what is wrong than the error message below */
c80e42f3 2700 utf8n_to_uvchr(first_bad_char_loc,
bde9e88d
KW
2701 (char *) first_bad_char_loc - str,
2702 NULL, 0);
2703
2704 /* We deliberately don't try to print the malformed character,
2705 * which might not print very well; it also may be just the first
2706 * of many malformations, so don't print what comes after it */
2707 yyerror_pv(
2708 Perl_form(aTHX_
2709 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2710 (int) (e - backslash_ptr + 1), backslash_ptr,
2711 (int) ((char *) first_bad_char_loc - str), str
2712 ),
2713 SVf_UTF8);
2714 return NULL;
2715 }
2716 }
140b12ad 2717
bde9e88d 2718 return res;
140b12ad 2719
bde9e88d 2720 bad_charname: {
bde9e88d
KW
2721
2722 /* The final %.*s makes sure that should the trailing NUL be missing
2723 * that this print won't run off the end of the string */
2724 yyerror_pv(
2725 Perl_form(aTHX_
2726 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2d8eb851
KW
2727 (int)(s - backslash_ptr + 1), backslash_ptr,
2728 (int)(e - s + 1), s + 1
bde9e88d
KW
2729 ),
2730 UTF ? SVf_UTF8 : 0);
2731 return NULL;
2732 }
2d8eb851
KW
2733
2734 multi_spaces:
2735 yyerror_pv(
2736 Perl_form(aTHX_
2737 "charnames alias definitions may not contain a sequence of "
2738 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2739 (int)(s - backslash_ptr + 1), backslash_ptr,
2740 (int)(e - s + 1), s + 1
2741 ),
2742 UTF ? SVf_UTF8 : 0);
2743 return NULL;
6f613c73
KW
2744}
2745
02aa26ce
NT
2746/*
2747 scan_const
2748
9da1dd8f
DM
2749 Extracts the next constant part of a pattern, double-quoted string,
2750 or transliteration. This is terrifying code.
2751
2752 For example, in parsing the double-quoted string "ab\x63$d", it would
2753 stop at the '$' and return an OP_CONST containing 'abc'.
02aa26ce 2754
94def140 2755 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
3280af22 2756 processing a pattern (PL_lex_inpat is true), a transliteration
94def140 2757 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
02aa26ce 2758
94def140
ST
2759 Returns a pointer to the character scanned up to. If this is
2760 advanced from the start pointer supplied (i.e. if anything was
9da1dd8f 2761 successfully parsed), will leave an OP_CONST for the substring scanned
6154021b 2762 in pl_yylval. Caller must intuit reason for not parsing further
9b599b2a
GS
2763 by looking at the next characters herself.
2764
02aa26ce 2765 In patterns:
9da1dd8f 2766 expand:
537124e4
KW
2767 \N{FOO} => \N{U+hex_for_character_FOO}
2768 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
9da1dd8f
DM
2769
2770 pass through:
2771 all other \-char, including \N and \N{ apart from \N{ABC}
2772
2773 stops on:
2774 @ and $ where it appears to be a var, but not for $ as tail anchor
2775 \l \L \u \U \Q \E
2776 (?{ or (??{
2777
02aa26ce
NT
2778 In transliterations:
2779 characters are VERY literal, except for - not at the start or end
94def140
ST
2780 of the string, which indicates a range. If the range is in bytes,
2781 scan_const expands the range to the full set of intermediate
2782 characters. If the range is in utf8, the hyphen is replaced with
2783 a certain range mark which will be handled by pmtrans() in op.c.
02aa26ce
NT
2784
2785 In double-quoted strings:
2786 backslashes:
2787 double-quoted style: \r and \n
ff3f963a 2788 constants: \x31, etc.
94def140 2789 deprecated backrefs: \1 (in substitution replacements)
02aa26ce
NT
2790 case and quoting: \U \Q \E
2791 stops on @ and $
2792
2793 scan_const does *not* construct ops to handle interpolated strings.
2794 It stops processing as soon as it finds an embedded $ or @ variable
2795 and leaves it to the caller to work out what's going on.
2796
94def140
ST
2797 embedded arrays (whether in pattern or not) could be:
2798 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2799
2800 $ in double-quoted strings must be the symbol of an embedded scalar.
02aa26ce
NT
2801
2802 $ in pattern could be $foo or could be tail anchor. Assumption:
2803 it's a tail anchor if $ is the last thing in the string, or if it's
94def140 2804 followed by one of "()| \r\n\t"
02aa26ce 2805
9da1dd8f 2806 \1 (backreferences) are turned into $1 in substitutions
02aa26ce
NT
2807
2808 The structure of the code is
2809 while (there's a character to process) {
94def140
ST
2810 handle transliteration ranges
2811 skip regexp comments /(?#comment)/ and codes /(?{code})/
2812 skip #-initiated comments in //x patterns
2813 check for embedded arrays
02aa26ce
NT
2814 check for embedded scalars
2815 if (backslash) {
94def140 2816 deprecate \1 in substitution replacements
02aa26ce
NT
2817 handle string-changing backslashes \l \U \Q \E, etc.
2818 switch (what was escaped) {
94def140 2819 handle \- in a transliteration (becomes a literal -)
ff3f963a 2820 if a pattern and not \N{, go treat as regular character
94def140
ST
2821 handle \132 (octal characters)
2822 handle \x15 and \x{1234} (hex characters)
ff3f963a 2823 handle \N{name} (named characters, also \N{3,5} in a pattern)
94def140
ST
2824 handle \cV (control characters)
2825 handle printf-style backslashes (\f, \r, \n, etc)
02aa26ce 2826 } (end switch)
77a135fe 2827 continue
02aa26ce 2828 } (end if backslash)
77a135fe 2829 handle regular character
02aa26ce 2830 } (end while character to read)
4e553d73 2831
02aa26ce
NT
2832*/
2833
76e3520e 2834STATIC char *
cea2e8a9 2835S_scan_const(pTHX_ char *start)
79072805 2836{
eb578fdb 2837 char *send = PL_bufend; /* end of the constant */
dc023dbb
KW
2838 SV *sv = newSV(send - start); /* sv for the constant. See note below
2839 on sizing. */
eb578fdb
KW
2840 char *s = start; /* start of the constant */
2841 char *d = SvPVX(sv); /* destination for copies */
dc023dbb
KW
2842 bool dorange = FALSE; /* are we in a translit range? */
2843 bool didrange = FALSE; /* did we just finish a range? */
2844 bool in_charclass = FALSE; /* within /[...]/ */
2845 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2846 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2847 UTF8? But, this can show as true
2848 when the source isn't utf8, as for
2849 example when it is entirely composed
2850 of hex constants */
6f613c73 2851 SV *res; /* result from charnames */
f4240379
KW
2852 STRLEN offset_to_max; /* The offset in the output to where the range
2853 high-end character is temporarily placed */
77a135fe
KW
2854
2855 /* Note on sizing: The scanned constant is placed into sv, which is
2856 * initialized by newSV() assuming one byte of output for every byte of
2857 * input. This routine expects newSV() to allocate an extra byte for a
2858 * trailing NUL, which this routine will append if it gets to the end of
2859 * the input. There may be more bytes of input than output (eg., \N{LATIN
2860 * CAPITAL LETTER A}), or more output than input if the constant ends up
2861 * recoded to utf8, but each time a construct is found that might increase
2862 * the needed size, SvGROW() is called. Its size parameter each time is
2863 * based on the best guess estimate at the time, namely the length used so
2864 * far, plus the length the current construct will occupy, plus room for
2865 * the trailing NUL, plus one byte for every input byte still unscanned */
2866
c3320c2a
KW
2867 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2868 before set */
4c3a8340 2869#ifdef EBCDIC
f4240379
KW
2870 int backslash_N = 0; /* ? was the character from \N{} */
2871 int non_portable_endpoint = 0; /* ? In a range is an endpoint
2872 platform-specific like \x65 */
4c3a8340 2873#endif
012bcf8d 2874
7918f24d
NC
2875 PERL_ARGS_ASSERT_SCAN_CONST;
2876
bb16bae8 2877 assert(PL_lex_inwhat != OP_TRANSR);
7ef70b3d 2878 if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
2b9d42f0 2879 /* If we are doing a trans and we know we want UTF8 set expectation */
7ef70b3d
FC
2880 has_utf8 = PL_parser->lex_sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2881 this_utf8 = PL_parser->lex_sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2b9d42f0
NIS
2882 }
2883
b899e89d
FC
2884 /* Protect sv from errors and fatal warnings. */
2885 ENTER_with_name("scan_const");
2886 SAVEFREESV(sv);
2b9d42f0 2887
f4240379
KW
2888 while (s < send
2889 || dorange /* Handle tr/// range at right edge of input */
2890 ) {
ff3f963a 2891
02aa26ce 2892 /* get transliterations out of the way (they're most literal) */
3280af22 2893 if (PL_lex_inwhat == OP_TRANS) {
02aa26ce 2894
f4240379
KW
2895 /* But there isn't any special handling necessary unless there is a
2896 * range, so for most cases we just drop down and handle the value
2897 * as any other. There are two exceptions.
2898 *
2899 * 1. A minus sign indicates that we are actually going to have
2900 * a range. In this case, skip the '-', set a flag, then drop
2901 * down to handle what should be the end range value.
2902 * 2. After we've handled that value, the next time through, that
2903 * flag is set and we fix up the range.
2904 *
2905 * Ranges entirely within Latin1 are expanded out entirely, in
2906 * order to avoid the significant overhead of making a swash.
2907 * Ranges that extend above Latin1 have to have a swash, so there
4698efb6
KW
2908 * is no advantage to abbreviating them here, so they are stored
2909 * here as Min, ILLEGAL_UTF8_BYTE, Max. The illegal byte signifies
2910 * a hyphen without any possible ambiguity. On EBCDIC machines, if
f4240379
KW
2911 * the range is expressed as Unicode, the Latin1 portion is
2912 * expanded out even if the entire range extends above Latin1.
2913 * This is because each code point in it has to be processed here
2914 * individually to get its native translation */
2915
2916 if (! dorange) {
2917
2918 /* Here, we don't think we're in a range. If we've processed
2919 * at least one character, then see if this next one is a '-',
2920 * indicating the previous one was the start of a range. But
2921 * don't bother if we're too close to the end for the minus to
2922 * mean that. */
2923 if (*s != '-' || s >= send - 1 || s == start) {
2924
2925 /* A regular character. Process like any other, but first
2926 * clear any flags */
2927 didrange = FALSE;
2928 dorange = FALSE;
e294cc5d 2929#ifdef EBCDIC
f4240379
KW
2930 non_portable_endpoint = 0;
2931 backslash_N = 0;
e294cc5d 2932#endif
f4240379
KW
2933 /* Drops down to generic code to process current byte */
2934 }
2935 else {
2936 if (didrange) { /* Something like y/A-C-Z// */
2937 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2938 }
e294cc5d 2939
f4240379 2940 dorange = TRUE;
2b9d42f0 2941
f4240379
KW
2942 s++; /* Skip past the minus */
2943
2944 /* d now points to where the end-range character will be
2945 * placed. Save it so won't have to go finding it later,
2946 * and drop down to get that character. (Actually we
2947 * instead save the offset, to handle the case where a
2948 * realloc in the meantime could change the actual
2949 * pointer). We'll finish processing the range the next
2950 * time through the loop */
2951 offset_to_max = d - SvPVX_const(sv);
2952 }
2953 } /* End of not a range */
2954 else {
2955 /* Here we have parsed a range. Now must handle it. At this
2956 * point:
2957 * 'sv' is a SV* that contains the output string we are
2958 * constructing. The final two characters in that string
2959 * are the range start and range end, in order.
2960 * 'd' points to just beyond the range end in the 'sv' string,
2961 * where we would next place something
2962 * 'offset_to_max' is the offset in 'sv' at which the character
2963 * before 'd' begins.
2964 */
2965 const char * max_ptr = SvPVX_const(sv) + offset_to_max;
2966 const char * min_ptr;
2967 IV range_min;
2968 IV range_max; /* last character in range */
2969 STRLEN save_offset;
2970 STRLEN grow;
11327fa1 2971#ifdef EBCDIC
f4240379
KW
2972 bool convert_unicode;
2973 IV real_range_max = 0;
e294cc5d 2974#endif
f4240379
KW
2975
2976 /* Get the range-ends code point values. */
e294cc5d 2977 if (has_utf8) {
f4240379
KW
2978 /* We know the utf8 is valid, because we just constructed
2979 * it ourselves in previous loop iterations */
2980 min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1);
2981 range_min = valid_utf8_to_uvchr( (U8*) min_ptr, NULL);
2982 range_max = valid_utf8_to_uvchr( (U8*) max_ptr, NULL);
e294cc5d 2983 }
f4240379
KW
2984 else {
2985 min_ptr = max_ptr - 1;
2986 range_min = * (U8*) min_ptr;
2987 range_max = * (U8*) max_ptr;
2988 }
2989
e294cc5d 2990#ifdef EBCDIC
f4240379
KW
2991 /* On EBCDIC platforms, we may have to deal with portable
2992 * ranges. These happen if at least one range endpoint is a
2993 * Unicode value (\N{...}), or if the range is a subset of
2994 * [A-Z] or [a-z], and both ends are literal characters,
2995 * like 'A', and not like \x{C1} */
2996 if ((convert_unicode
2997 = cBOOL(backslash_N) /* \N{} forces Unicode, hence
2998 portable range */
2999 || ( ! non_portable_endpoint
3000 && (( isLOWER_A(range_min) && isLOWER_A(range_max))
3001 || (isUPPER_A(range_min) && isUPPER_A(range_max))))
3002 )) {
3003
3004 /* Special handling is needed for these portable ranges.
3005 * They are defined to all be in Unicode terms, which
3006 * include all Unicode code points between the end points.
3007 * Convert to Unicode to get the Unicode range. Later we
3008 * will convert each code point in the range back to
3009 * native. */
3010 range_min = NATIVE_TO_UNI(range_min);
3011 range_max = NATIVE_TO_UNI(range_max);
3012 }
e294cc5d 3013#endif
8ada0baa 3014
f4240379 3015 if (range_min > range_max) {
11327fa1 3016#ifdef EBCDIC
f4240379
KW
3017 if (convert_unicode) {
3018 /* Need to convert back to native for meaningful
3019 * messages for this platform */
3020 range_min = UNI_TO_NATIVE(range_min);
3021 range_max = UNI_TO_NATIVE(range_max);
3022 }
11327fa1 3023#endif
f4240379
KW
3024
3025 /* Use the characters themselves for the error message if
3026 * ASCII printables; otherwise some visible representation
3027 * of them */
3028 if (isPRINT_A(range_min) && isPRINT_A(range_max)) {
3029 Perl_croak(aTHX_
3030 "Invalid range \"%c-%c\" in transliteration operator",
3031 (char)range_min, (char)range_max);
3032 }
11327fa1 3033#ifdef EBCDIC
f4240379
KW
3034 else if (convert_unicode) {
3035 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3036 Perl_croak(aTHX_
147e3846 3037 "Invalid range \"\\N{U+%04" UVXf "}-\\N{U+%04" UVXf "}\""
f4240379
KW
3038 " in transliteration operator",
3039 range_min, range_max);
3040 }
11327fa1 3041#endif
f4240379
KW
3042 else {
3043 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3044 Perl_croak(aTHX_
147e3846 3045 "Invalid range \"\\x{%04" UVXf "}-\\x{%04" UVXf "}\""
f4240379
KW
3046 " in transliteration operator",
3047 range_min, range_max);
3048 }
c2e66d9e
GS
3049 }
3050
f4240379
KW
3051 if (has_utf8) {
3052
3053 /* We try to avoid creating a swash. If the upper end of
3054 * this range is below 256, this range won't force a swash;
3055 * otherwise it does force a swash, and as long as we have
3056 * to have one, we might as well not expand things out.
3057 * But if it's EBCDIC, we may have to look at each
3058 * character below 256 if we have to convert to/from
3059 * Unicode values */
3060 if (range_max > 255
c7f1f016 3061#ifdef EBCDIC
f4240379 3062 && (range_min > 255 || ! convert_unicode)
8ada0baa 3063#endif
f4240379
KW
3064 ) {
3065 /* Move the high character one byte to the right; then
3066 * insert between it and the range begin, an illegal
3067 * byte which serves to indicate this is a range (using
3068 * a '-' could be ambiguous). */
3069 char *e = d++;
3070 while (e-- > max_ptr) {
3071 *(e + 1) = *e;
e294cc5d 3072 }
f4240379
KW
3073 *(e + 1) = (char) ILLEGAL_UTF8_BYTE;
3074 goto range_done;
3075 }
3076
3077 /* Here, we're going to expand out the range. For EBCDIC
3078 * the range can extend above 255 (not so in ASCII), so
3079 * for EBCDIC, split it into the parts above and below
3080 * 255/256 */
e294cc5d 3081#ifdef EBCDIC
f4240379
KW
3082 if (range_max > 255) {
3083 real_range_max = range_max;
3084 range_max = 255;
3085 }
e294cc5d 3086#endif
f4240379 3087 }
02aa26ce 3088
f4240379
KW
3089 /* Here we need to expand out the string to contain each
3090 * character in the range. Grow the output to handle this */
3091
3092 save_offset = min_ptr - SvPVX_const(sv);
3093
3094 /* The base growth is the number of code points in the range */
3095 grow = range_max - range_min + 1;
3096 if (has_utf8) {
3097
3098 /* But if the output is UTF-8, some of those characters may
3099 * need two bytes (since the maximum range value here is
3100 * 255, the max bytes per character is two). On ASCII
3101 * platforms, it's not much trouble to get an accurate
3102 * count of what's needed. But on EBCDIC, the ones that
3103 * need 2 bytes are scattered around, so just use a worst
3104 * case value instead of calculating for that platform. */
4c3a8340 3105#ifdef EBCDIC
f4240379
KW
3106 grow *= 2;
3107#else
3108 /* Only those above 127 require 2 bytes. This may be
3109 * everything in the range, or not */
3110 if (range_min > 127) {
3111 grow *= 2;
3112 }
3113 else if (range_max > 127) {
3114 grow += range_max - 127;
3115 }
4c3a8340 3116#endif
f4240379
KW
3117 }
3118
3119 /* Subtract 3 for the bytes that were already accounted for
3120 * (min, max, and the hyphen) */
10656159 3121 d = save_offset + SvGROW(sv, SvLEN(sv) + grow - 3);
f4240379 3122
11327fa1
AL
3123#ifdef EBCDIC
3124 /* Here, we expand out the range. */
f4240379
KW
3125 if (convert_unicode) {
3126 IV i;
02aa26ce 3127
f4240379
KW
3128 /* Recall that the min and max are now in Unicode terms, so
3129 * we have to convert each character to its native
3130 * equivalent */
3131 if (has_utf8) {
3132 for (i = range_min; i <= range_max; i++) {
81324705 3133 append_utf8_from_native_byte(LATIN1_TO_NATIVE((U8) i),
f4240379
KW
3134 (U8 **) &d);
3135 }
3136 }
3137 else {
3138 for (i = range_min; i <= range_max; i++) {
81324705 3139 *d++ = (char)LATIN1_TO_NATIVE((U8) i);
f4240379
KW
3140 }
3141 }
01ec43d0 3142 }
11327fa1
AL
3143 else
3144#endif
3145 /* Always gets run for ASCII, and sometimes for EBCDIC. */
3146 {
f4240379
KW
3147 IV i;
3148
3149 /* Here, no conversions are necessary, which means that the
3150 * first character in the range is already in 'd' and
3151 * valid, so we can skip overwriting it */
3152 if (has_utf8) {
3153 d += UTF8SKIP(d);
3154 for (i = range_min + 1; i <= range_max; i++) {
81324705 3155 append_utf8_from_native_byte((U8) i, (U8 **) &d);
f4240379
KW
3156 }
3157 }
3158 else {
3159 d++;
3160 for (i = range_min + 1; i <= range_max; i++) {
3161 *d++ = (char)i;
3162 }
3163 }
a0ed51b3 3164 }
02aa26ce 3165
11327fa1
AL
3166#ifdef EBCDIC
3167 /* If the original range extended above 255, add in that portion. */
f4240379
KW
3168 if (real_range_max) {
3169 *d++ = (char) UTF8_TWO_BYTE_HI(0x100);
3170 *d++ = (char) UTF8_TWO_BYTE_LO(0x100);
3171 if (real_range_max > 0x101)
3172 *d++ = (char) ILLEGAL_UTF8_BYTE;
3173 if (real_range_max > 0x100)
3174 d = (char*)uvchr_to_utf8((U8*)d, real_range_max);
3175 }
11327fa1 3176#endif
02aa26ce 3177
f4240379
KW
3178 range_done:
3179 /* mark the range as done, and continue */
3180 didrange = TRUE;
3181 dorange = FALSE;
3182#ifdef EBCDIC
3183 non_portable_endpoint = 0;
3184 backslash_N = 0;
3185#endif
3186 continue;
3187 } /* End of is a range */
3188 } /* End of transliteration. Joins main code after these else's */
e4a2df84
DM
3189 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3190 char *s1 = s-1;
3191 int esc = 0;
3192 while (s1 >= start && *s1-- == '\\')
3193 esc = !esc;
3194 if (!esc)
3195 in_charclass = TRUE;
3196 }
2866decb 3197
e4a2df84
DM
3198 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3199 char *s1 = s-1;
3200 int esc = 0;
3201 while (s1 >= start && *s1-- == '\\')
3202 esc = !esc;
3203 if (!esc)
3204 in_charclass = FALSE;
3205 }
2866decb 3206
9da1dd8f
DM
3207 /* skip for regexp comments /(?#comment)/, except for the last
3208 * char, which will be done separately.
3209 * Stop on (?{..}) and friends */
3210
c30fc27b 3211 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
cc6b7395 3212 if (s[2] == '#') {
e994fd66 3213 while (s+1 < send && *s != ')')
5ff03569 3214 *d++ = *s++;
155aba94 3215 }
407f8cf2
KW
3216 else if (!PL_lex_casemods
3217 && ( s[2] == '{' /* This should match regcomp.c */
3218 || (s[2] == '?' && s[3] == '{')))
155aba94 3219 {
9da1dd8f 3220 break;
cc6b7395 3221 }
748a9306 3222 }
02aa26ce
NT
3223
3224 /* likewise skip #-initiated comments in //x patterns */
407f8cf2
KW
3225 else if (*s == '#'
3226 && PL_lex_inpat
3227 && !in_charclass
3228 && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED)
3229 {
748a9306 3230 while (s+1 < send && *s != '\n')
5ff03569 3231 *d++ = *s++;
748a9306 3232 }
02aa26ce 3233
9da1dd8f
DM
3234 /* no further processing of single-quoted regex */
3235 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3236 goto default_action;
3237
5d1d4326 3238 /* check for embedded arrays
da6eedaa 3239 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
5d1d4326 3240 */
1749ea0d 3241 else if (*s == '@' && s[1]) {
9d58dbc4 3242 if (UTF ? isIDFIRST_utf8((U8*)s+1) : isWORDCHAR_A(s[1]))
1749ea0d
ST
3243 break;
3244 if (strchr(":'{$", s[1]))
3245 break;
3246 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3247 break; /* in regexp, neither @+ nor @- are interpolated */
3248 }
02aa26ce
NT
3249
3250 /* check for embedded scalars. only stop if we're sure it's a
3251 variable.
3252 */
79072805 3253 else if (*s == '$') {
3280af22 3254 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
79072805 3255 break;
77772344 3256 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
a2a5de95
NC
3257 if (s[1] == '\\') {
3258 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3259 "Possible unintended interpolation of $\\ in regex");
77772344 3260 }
79072805 3261 break; /* in regexp, $ might be tail anchor */
77772344 3262 }
79072805 3263 }
02aa26ce 3264
2b9d42f0
NIS
3265 /* End of else if chain - OP_TRANS rejoin rest */
3266
02aa26ce 3267 /* backslashes */
79072805 3268 if (*s == '\\' && s+1 < send) {
ff3f963a
KW
3269 char* e; /* Can be used for ending '}', etc. */
3270
79072805 3271 s++;
02aa26ce 3272
7d0fc23c
KW
3273 /* warn on \1 - \9 in substitution replacements, but note that \11
3274 * is an octal; and \19 is \1 followed by '9' */
407f8cf2
KW
3275 if (PL_lex_inwhat == OP_SUBST
3276 && !PL_lex_inpat
3277 && isDIGIT(*s)
3278 && *s != '0'
3279 && !isDIGIT(s[1]))
79072805 3280 {
c782d7ee 3281 /* diag_listed_as: \%d better written as $%d */
a2a5de95 3282 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
79072805
LW
3283 *--s = '$';
3284 break;
3285 }
02aa26ce
NT
3286
3287 /* string-change backslash escapes */
838f2281 3288 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
79072805
LW
3289 --s;
3290 break;
3291 }
ff3f963a
KW
3292 /* In a pattern, process \N, but skip any other backslash escapes.
3293 * This is because we don't want to translate an escape sequence
3294 * into a meta symbol and have the regex compiler use the meta
3295 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3296 * in spite of this, we do have to process \N here while the proper
3297 * charnames handler is in scope. See bugs #56444 and #62056.
85fba779 3298 *
ff3f963a
KW
3299 * There is a complication because \N in a pattern may also stand
3300 * for 'match a non-nl', and not mean a charname, in which case its
3301 * processing should be deferred to the regex compiler. To be a
3302 * charname it must be followed immediately by a '{', and not look
3303 * like \N followed by a curly quantifier, i.e., not something like
3304 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3305 * quantifier */
3306 else if (PL_lex_inpat
3307 && (*s != 'N'
3308 || s[1] != '{'
412f55bb 3309 || regcurly(s + 1)))
ff3f963a 3310 {
4d73d076 3311 *d++ = '\\';
cc74c5bd
ST
3312 goto default_action;
3313 }
02aa26ce 3314
79072805 3315 switch (*s) {
79072805 3316 default:
11b8faa4 3317 {
15861f94 3318 if ((isALPHANUMERIC(*s)))
a2a5de95
NC
3319 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3320 "Unrecognized escape \\%c passed through",
3321 *s);
11b8faa4 3322 /* default action is to copy the quoted character */
f9a63242 3323 goto default_action;
11b8faa4 3324 }
02aa26ce 3325
632403cc 3326 /* eg. \132 indicates the octal constant 0132 */
79072805
LW
3327 case '0': case '1': case '2': case '3':
3328 case '4': case '5': case '6': case '7':
ba210ebe 3329 {
5e0a247b 3330 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
53305cf1 3331 STRLEN len = 3;
06972766 3332 uv = grok_oct(s, &len, &flags, NULL);
ba210ebe 3333 s += len;
5e0a247b
KW
3334 if (len < 3 && s < send && isDIGIT(*s)
3335 && ckWARN(WARN_MISC))
3336 {
3337 Perl_warner(aTHX_ packWARN(WARN_MISC),
3338 "%s", form_short_octal_warning(s, len));
3339 }
ba210ebe 3340 }
012bcf8d 3341 goto NUM_ESCAPE_INSERT;
02aa26ce 3342
f0a2b745
KW
3343 /* eg. \o{24} indicates the octal constant \024 */
3344 case 'o':
3345 {
454155d9 3346 const char* error;
f0a2b745 3347
00ce5563 3348 bool valid = grok_bslash_o(&s, &uv, &error,
80f4111b
KW
3349 TRUE, /* Output warning */
3350 FALSE, /* Not strict */
17896a85
KW
3351 TRUE, /* Output warnings for
3352 non-portables */
80f4111b 3353 UTF);
454155d9 3354 if (! valid) {
f0a2b745
KW
3355 yyerror(error);
3356 continue;
3357 }
3358 goto NUM_ESCAPE_INSERT;
3359 }
3360
77a135fe 3361 /* eg. \x24 indicates the hex constant 0x24 */
79072805 3362 case 'x':
a0481293 3363 {
a0481293 3364 const char* error;
355860ce 3365
00ce5563 3366 bool valid = grok_bslash_x(&s, &uv, &error,
80f4111b
KW
3367 TRUE, /* Output warning */
3368 FALSE, /* Not strict */
17896a85
KW
3369 TRUE, /* Output warnings for
3370 non-portables */
80f4111b 3371 UTF);
a0481293
KW
3372 if (! valid) {
3373 yyerror(error);
355860ce 3374 continue;
ba210ebe 3375 }
012bcf8d
GS
3376 }
3377
3378 NUM_ESCAPE_INSERT:
b67fd2c5 3379 /* Insert oct or hex escaped character. */
ba7cea30 3380
06972766 3381 /* Here uv is the ordinal of the next character being added */
f4240379
KW
3382 if (UVCHR_IS_INVARIANT(uv)) {
3383 *d++ = (char) uv;
3384 }
3385 else {
9aa983d2 3386 if (!has_utf8 && uv > 255) {
77a135fe
KW
3387 /* Might need to recode whatever we have accumulated so
3388 * far if it contains any chars variant in utf8 or
3389 * utf-ebcdic. */
3390
3391 SvCUR_set(sv, d - SvPVX_const(sv));
3392 SvPOK_on(sv);
3393 *d = '\0';
77a135fe 3394 /* See Note on sizing above. */
5eef447b 3395 sv_utf8_upgrade_flags_grow(
5f560d8a
KW
3396 sv,
3397 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE
5eef447b
KW
3398 /* Above-latin1 in string
3399 * implies no encoding */
3400 |SV_UTF8_NO_ENCODING,
5f560d8a 3401 UVCHR_SKIP(uv) + (STRLEN)(send - s) + 1);
77a135fe
KW
3402 d = SvPVX(sv) + SvCUR(sv);
3403 has_utf8 = TRUE;
012bcf8d
GS
3404 }
3405
77a135fe 3406 if (has_utf8) {
b67fd2c5
KW
3407 /* Usually, there will already be enough room in 'sv'
3408 * since such escapes are likely longer than any UTF-8
3409 * sequence they can end up as. This isn't the case on
3410 * EBCDIC where \x{40000000} contains 12 bytes, and the
3411 * UTF-8 for it contains 14. And, we have to allow for
3412 * a trailing NUL. It probably can't happen on ASCII
3413 * platforms, but be safe */
3414 const STRLEN needed = d - SvPVX(sv) + UVCHR_SKIP(uv)
3415 + 1;
3416 if (UNLIKELY(needed > SvLEN(sv))) {
3417 SvCUR_set(sv, d - SvPVX_const(sv));
3418 d = sv_grow(sv, needed) + SvCUR(sv);
3419 }
3420
c80e42f3 3421 d = (char*)uvchr_to_utf8((U8*)d, uv);
407f8cf2 3422 if (PL_lex_inwhat == OP_TRANS
7ef70b3d 3423 && PL_parser->lex_sub_op)
407f8cf2 3424 {
7ef70b3d 3425 PL_parser->lex_sub_op->op_private |=
f9a63242
JH
3426 (PL_lex_repl ? OPpTRANS_FROM_UTF
3427 : OPpTRANS_TO_UTF);
f9a63242 3428 }
012bcf8d 3429 }
a0ed51b3 3430 else {
012bcf8d 3431 *d++ = (char)uv;
a0ed51b3 3432 }
012bcf8d 3433 }
f4240379
KW
3434#ifdef EBCDIC
3435 non_portable_endpoint++;
3436#endif
79072805 3437 continue;
02aa26ce 3438
4a2d328f 3439 case 'N':
85fba779
KW
3440 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3441 * named character, like \N{LATIN SMALL LETTER A}, or a named
3442 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
f4240379
KW
3443 * GRAVE} (except y/// can't handle the latter, croaking). For
3444 * convenience all three forms are referred to as "named
3445 * characters" below.
85fba779
KW
3446 *
3447 * For patterns, \N also can mean to match a non-newline. Code
3448 * before this 'switch' statement should already have handled
3449 * this situation, and hence this code only has to deal with
3450 * the named character cases.
3451 *
3452 * For non-patterns, the named characters are converted to
3453 * their string equivalents. In patterns, named characters are
3454 * not converted to their ultimate forms for the same reasons
3455 * that other escapes aren't. Instead, they are converted to
3456 * the \N{U+...} form to get the value from the charnames that
3457 * is in effect right now, while preserving the fact that it
3458 * was a named character, so that the regex compiler knows
3459 * this.
3460 *
3461 * The structure of this section of code (besides checking for
ff3f963a 3462 * errors and upgrading to utf8) is:
f4240379 3463 * If the named character is of the form \N{U+...}, pass it
85fba779
KW
3464 * through if a pattern; otherwise convert the code point
3465 * to utf8
f4240379
KW
3466 * Otherwise must be some \N{NAME}: convert to
3467 * \N{U+c1.c2...} if a pattern; otherwise convert to utf8
3468 *
3469 * Transliteration is an exception. The conversion to utf8 is
3470 * only done if the code point requires it to be representable.
85fba779 3471 *
b6d67071 3472 * Here, 's' points to the 'N'; the test below is guaranteed to
85fba779
KW
3473 * succeed if we are being called on a pattern, as we already
3474 * know from a test above that the next character is a '{'. A
3475 * non-pattern \N must mean 'named character', which requires
3476 * braces */
ff3f963a
KW
3477 s++;
3478 if (*s != '{') {
3479 yyerror("Missing braces on \\N{}");
3480 continue;
3481 }
3482 s++;
3483
0a96133f 3484 /* If there is no matching '}', it is an error. */
ff3f963a
KW
3485 if (! (e = strchr(s, '}'))) {
3486 if (! PL_lex_inpat) {
5777a3f7 3487 yyerror("Missing right brace on \\N{}");
0a96133f 3488 } else {
4407f1b8 3489 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
dbc0d4f2 3490 }
0a96133f 3491 continue;
ff3f963a 3492 }
cddc7ef4 3493
ff3f963a 3494 /* Here it looks like a named character */
cddc7ef4 3495
ff3f963a 3496 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
ff3f963a 3497 s += 2; /* Skip to next char after the 'U+' */
ff3f963a 3498 if (PL_lex_inpat) {
af352bf2
KW
3499
3500 /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
fb2eed93
FC
3501 /* Check the syntax. */
3502 const char *orig_s;
3503 orig_s = s - 5;
3504 if (!isXDIGIT(*s)) {
3505 bad_NU:
3506 yyerror(
3507 "Invalid hexadecimal number in \\N{U+...}"
3508 );
3509 s = e + 1;
3510 continue;
3511 }
3512 while (++s < e) {
3513 if (isXDIGIT(*s))
3514 continue;
3515 else if ((*s == '.' || *s == '_')
3516 && isXDIGIT(s[1]))
3517 continue;
3518 goto bad_NU;
4cbd7e22 3519 }
af352bf2 3520
fb2eed93
FC
3521 /* Pass everything through unchanged.
3522 * +1 is for the '}' */
4cbd7e22
FC
3523 Copy(orig_s, d, e - orig_s + 1, char);
3524 d += e - orig_s + 1;
ff3f963a
KW
3525 }
3526 else { /* Not a pattern: convert the hex to string */
fb2eed93
FC
3527 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3528 | PERL_SCAN_SILENT_ILLDIGIT
3529 | PERL_SCAN_DISALLOW_PREFIX;
3530 STRLEN len = e - s;
3531 uv = grok_hex(s, &len, &flags, NULL);
3532 if (len == 0 || (len != (STRLEN)(e - s)))
3533 goto bad_NU;
ff3f963a 3534
f4240379
KW
3535 /* For non-tr///, if the destination is not in utf8,
3536 * unconditionally recode it to be so. This is
3537 * because \N{} implies Unicode semantics, and scalars
3538 * have to be in utf8 to guarantee those semantics.
3539 * tr/// doesn't care about Unicode rules, so no need
3540 * there to upgrade to UTF-8 for small enough code
3541 * points */
3542 if (! has_utf8 && ( uv > 0xFF
3543 || PL_lex_inwhat != OP_TRANS))
3544 {
ff3f963a
KW
3545 SvCUR_set(sv, d - SvPVX_const(sv));
3546 SvPOK_on(sv);
3547 *d = '\0';
3548 /* See Note on sizing above. */
3549 sv_utf8_upgrade_flags_grow(
5f560d8a
KW
3550 sv,
3551 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
b2873c15 3552 OFFUNISKIP(uv) + (STRLEN)(send - e) + 1);
ff3f963a
KW
3553 d = SvPVX(sv) + SvCUR(sv);
3554 has_utf8 = TRUE;
3555 }
3556
a46469e6 3557 /* Add the (Unicode) code point to the output. */
3a34ca0b 3558 if (! has_utf8 || OFFUNI_IS_INVARIANT(uv)) {
a46469e6 3559 *d++ = (char) LATIN1_TO_NATIVE(uv);
ff3f963a 3560 }
a46469e6
KW
3561 else {
3562 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3563 }
ff3f963a
KW
3564 }
3565 }
6f613c73
KW
3566 else /* Here is \N{NAME} but not \N{U+...}. */
3567 if ((res = get_and_check_backslash_N_name(s, e)))
3568 {
3569 STRLEN len;
3570 const char *str = SvPV_const(res, len);
3571 if (PL_lex_inpat) {
ff3f963a
KW
3572
3573 if (! len) { /* The name resolved to an empty string */
3574 Copy("\\N{}", d, 4, char);
3575 d += 4;
3576 }
3577 else {
3578 /* In order to not lose information for the regex
3579 * compiler, pass the result in the specially made
3580 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3581 * the code points in hex of each character
3582 * returned by charnames */
3583
3584 const char *str_end = str + len;
3b721c4f 3585 const STRLEN off = d - SvPVX_const(sv);
94ca1619
KW
3586
3587 if (! SvUTF8(res)) {
3588 /* For the non-UTF-8 case, we can determine the
3589 * exact length needed without having to parse
3590 * through the string. Each character takes up
3591 * 2 hex digits plus either a trailing dot or
3592 * the "}" */
9765