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