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