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