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