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