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