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