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