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