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