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