This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
toke.c: Add, clarify comments
[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? */
2866decb 2675 bool in_charclass = FALSE; /* within /[...]/ */
b953e60c
KW
2676 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2677 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
77a135fe
KW
2678 to be UTF8? But, this can
2679 show as true when the source
2680 isn't utf8, as for example
2681 when it is entirely composed
2682 of hex constants */
2683
2684 /* Note on sizing: The scanned constant is placed into sv, which is
2685 * initialized by newSV() assuming one byte of output for every byte of
2686 * input. This routine expects newSV() to allocate an extra byte for a
2687 * trailing NUL, which this routine will append if it gets to the end of
2688 * the input. There may be more bytes of input than output (eg., \N{LATIN
2689 * CAPITAL LETTER A}), or more output than input if the constant ends up
2690 * recoded to utf8, but each time a construct is found that might increase
2691 * the needed size, SvGROW() is called. Its size parameter each time is
2692 * based on the best guess estimate at the time, namely the length used so
2693 * far, plus the length the current construct will occupy, plus room for
2694 * the trailing NUL, plus one byte for every input byte still unscanned */
2695
012bcf8d 2696 UV uv;
4c3a8340
ST
2697#ifdef EBCDIC
2698 UV literal_endpoint = 0;
e294cc5d 2699 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
4c3a8340 2700#endif
012bcf8d 2701
7918f24d
NC
2702 PERL_ARGS_ASSERT_SCAN_CONST;
2703
bb16bae8 2704 assert(PL_lex_inwhat != OP_TRANSR);
2b9d42f0
NIS
2705 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2706 /* If we are doing a trans and we know we want UTF8 set expectation */
2707 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2708 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2709 }
2710
2711
79072805 2712 while (s < send || dorange) {
ff3f963a 2713
02aa26ce 2714 /* get transliterations out of the way (they're most literal) */
3280af22 2715 if (PL_lex_inwhat == OP_TRANS) {
02aa26ce 2716 /* expand a range A-Z to the full set of characters. AIE! */
79072805 2717 if (dorange) {
1ba5c669
JH
2718 I32 i; /* current expanded character */
2719 I32 min; /* first character in range */
2720 I32 max; /* last character in range */
02aa26ce 2721
e294cc5d
JH
2722#ifdef EBCDIC
2723 UV uvmax = 0;
2724#endif
2725
2726 if (has_utf8
2727#ifdef EBCDIC
2728 && !native_range
2729#endif
2730 ) {
9d4ba2ae 2731 char * const c = (char*)utf8_hop((U8*)d, -1);
8973db79
JH
2732 char *e = d++;
2733 while (e-- > c)
2734 *(e + 1) = *e;
25716404 2735 *c = (char)UTF_TO_NATIVE(0xff);
8973db79
JH
2736 /* mark the range as done, and continue */
2737 dorange = FALSE;
2738 didrange = TRUE;
2739 continue;
2740 }
2b9d42f0 2741
95a20fc0 2742 i = d - SvPVX_const(sv); /* remember current offset */
e294cc5d
JH
2743#ifdef EBCDIC
2744 SvGROW(sv,
2745 SvLEN(sv) + (has_utf8 ?
2746 (512 - UTF_CONTINUATION_MARK +
2747 UNISKIP(0x100))
2748 : 256));
2749 /* How many two-byte within 0..255: 128 in UTF-8,
2750 * 96 in UTF-8-mod. */
2751#else
9cbb5ea2 2752 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
e294cc5d 2753#endif
9cbb5ea2 2754 d = SvPVX(sv) + i; /* refresh d after realloc */
e294cc5d
JH
2755#ifdef EBCDIC
2756 if (has_utf8) {
2757 int j;
2758 for (j = 0; j <= 1; j++) {
2759 char * const c = (char*)utf8_hop((U8*)d, -1);
2760 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2761 if (j)
2762 min = (U8)uv;
2763 else if (uv < 256)
2764 max = (U8)uv;
2765 else {
2766 max = (U8)0xff; /* only to \xff */
2767 uvmax = uv; /* \x{100} to uvmax */
2768 }
2769 d = c; /* eat endpoint chars */
2770 }
2771 }
2772 else {
2773#endif
2774 d -= 2; /* eat the first char and the - */
2775 min = (U8)*d; /* first char in range */
2776 max = (U8)d[1]; /* last char in range */
2777#ifdef EBCDIC
2778 }
2779#endif
8ada0baa 2780
c2e66d9e 2781 if (min > max) {
01ec43d0 2782 Perl_croak(aTHX_
d1573ac7 2783 "Invalid range \"%c-%c\" in transliteration operator",
1ba5c669 2784 (char)min, (char)max);
c2e66d9e
GS
2785 }
2786
c7f1f016 2787#ifdef EBCDIC
4c3a8340
ST
2788 if (literal_endpoint == 2 &&
2789 ((isLOWER(min) && isLOWER(max)) ||
2790 (isUPPER(min) && isUPPER(max)))) {
8ada0baa
JH
2791 if (isLOWER(min)) {
2792 for (i = min; i <= max; i++)
2793 if (isLOWER(i))
db42d148 2794 *d++ = NATIVE_TO_NEED(has_utf8,i);
8ada0baa
JH
2795 } else {
2796 for (i = min; i <= max; i++)
2797 if (isUPPER(i))
db42d148 2798 *d++ = NATIVE_TO_NEED(has_utf8,i);
8ada0baa
JH
2799 }
2800 }
2801 else
2802#endif
2803 for (i = min; i <= max; i++)
e294cc5d
JH
2804#ifdef EBCDIC
2805 if (has_utf8) {
2806 const U8 ch = (U8)NATIVE_TO_UTF(i);
2807 if (UNI_IS_INVARIANT(ch))
2808 *d++ = (U8)i;
2809 else {
2810 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
2811 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2812 }
2813 }
2814 else
2815#endif
2816 *d++ = (char)i;
2817
2818#ifdef EBCDIC
2819 if (uvmax) {
2820 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2821 if (uvmax > 0x101)
2822 *d++ = (char)UTF_TO_NATIVE(0xff);
2823 if (uvmax > 0x100)
2824 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2825 }
2826#endif
02aa26ce
NT
2827
2828 /* mark the range as done, and continue */
79072805 2829 dorange = FALSE;
01ec43d0 2830 didrange = TRUE;
4c3a8340
ST
2831#ifdef EBCDIC
2832 literal_endpoint = 0;
2833#endif
79072805 2834 continue;
4e553d73 2835 }
02aa26ce
NT
2836
2837 /* range begins (ignore - as first or last char) */
79072805 2838 else if (*s == '-' && s+1 < send && s != start) {
4e553d73 2839 if (didrange) {
1fafa243 2840 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
01ec43d0 2841 }
e294cc5d
JH
2842 if (has_utf8
2843#ifdef EBCDIC
2844 && !native_range
2845#endif
2846 ) {
25716404 2847 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
a0ed51b3
LW
2848 s++;
2849 continue;
2850 }
79072805
LW
2851 dorange = TRUE;
2852 s++;
01ec43d0
GS
2853 }
2854 else {
2855 didrange = FALSE;
4c3a8340
ST
2856#ifdef EBCDIC
2857 literal_endpoint = 0;
e294cc5d 2858 native_range = TRUE;
4c3a8340 2859#endif
01ec43d0 2860 }
79072805 2861 }
02aa26ce
NT
2862
2863 /* if we get here, we're not doing a transliteration */
2864
e4a2df84
DM
2865 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
2866 char *s1 = s-1;
2867 int esc = 0;
2868 while (s1 >= start && *s1-- == '\\')
2869 esc = !esc;
2870 if (!esc)
2871 in_charclass = TRUE;
2872 }
2866decb 2873
e4a2df84
DM
2874 else if (*s == ']' && PL_lex_inpat && in_charclass) {
2875 char *s1 = s-1;
2876 int esc = 0;
2877 while (s1 >= start && *s1-- == '\\')
2878 esc = !esc;
2879 if (!esc)
2880 in_charclass = FALSE;
2881 }
2866decb 2882
9da1dd8f
DM
2883 /* skip for regexp comments /(?#comment)/, except for the last
2884 * char, which will be done separately.
2885 * Stop on (?{..}) and friends */
2886
3280af22 2887 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
cc6b7395 2888 if (s[2] == '#') {
e994fd66 2889 while (s+1 < send && *s != ')')
db42d148 2890 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
155aba94 2891 }
2866decb 2892 else if (!PL_lex_casemods && !in_charclass &&
d3cec5e5
DM
2893 ( s[2] == '{' /* This should match regcomp.c */
2894 || (s[2] == '?' && s[3] == '{')))
155aba94 2895 {
9da1dd8f 2896 break;
cc6b7395 2897 }
748a9306 2898 }
02aa26ce
NT
2899
2900 /* likewise skip #-initiated comments in //x patterns */
3280af22 2901 else if (*s == '#' && PL_lex_inpat &&
73134a2e 2902 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
748a9306 2903 while (s+1 < send && *s != '\n')
db42d148 2904 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
748a9306 2905 }
02aa26ce 2906
9da1dd8f
DM
2907 /* no further processing of single-quoted regex */
2908 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
2909 goto default_action;
2910
5d1d4326 2911 /* check for embedded arrays
da6eedaa 2912 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
5d1d4326 2913 */
1749ea0d
ST
2914 else if (*s == '@' && s[1]) {
2915 if (isALNUM_lazy_if(s+1,UTF))
2916 break;
2917 if (strchr(":'{$", s[1]))
2918 break;
2919 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2920 break; /* in regexp, neither @+ nor @- are interpolated */
2921 }
02aa26ce
NT
2922
2923 /* check for embedded scalars. only stop if we're sure it's a
2924 variable.
2925 */
79072805 2926 else if (*s == '$') {
3280af22 2927 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
79072805 2928 break;
77772344 2929 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
a2a5de95
NC
2930 if (s[1] == '\\') {
2931 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
2932 "Possible unintended interpolation of $\\ in regex");
77772344 2933 }
79072805 2934 break; /* in regexp, $ might be tail anchor */
77772344 2935 }
79072805 2936 }
02aa26ce 2937
2b9d42f0
NIS
2938 /* End of else if chain - OP_TRANS rejoin rest */
2939
02aa26ce 2940 /* backslashes */
79072805 2941 if (*s == '\\' && s+1 < send) {
ff3f963a
KW
2942 char* e; /* Can be used for ending '}', etc. */
2943
79072805 2944 s++;
02aa26ce 2945
7d0fc23c
KW
2946 /* warn on \1 - \9 in substitution replacements, but note that \11
2947 * is an octal; and \19 is \1 followed by '9' */
3280af22 2948 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
a0d0e21e 2949 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
79072805 2950 {
a2a5de95 2951 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
79072805
LW
2952 *--s = '$';
2953 break;
2954 }
02aa26ce
NT
2955
2956 /* string-change backslash escapes */
838f2281 2957 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
79072805
LW
2958 --s;
2959 break;
2960 }
ff3f963a
KW
2961 /* In a pattern, process \N, but skip any other backslash escapes.
2962 * This is because we don't want to translate an escape sequence
2963 * into a meta symbol and have the regex compiler use the meta
2964 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
2965 * in spite of this, we do have to process \N here while the proper
2966 * charnames handler is in scope. See bugs #56444 and #62056.
2967 * There is a complication because \N in a pattern may also stand
2968 * for 'match a non-nl', and not mean a charname, in which case its
2969 * processing should be deferred to the regex compiler. To be a
2970 * charname it must be followed immediately by a '{', and not look
2971 * like \N followed by a curly quantifier, i.e., not something like
2972 * \N{3,}. regcurly returns a boolean indicating if it is a legal
2973 * quantifier */
2974 else if (PL_lex_inpat
2975 && (*s != 'N'
2976 || s[1] != '{'
2977 || regcurly(s + 1)))
2978 {
cc74c5bd
ST
2979 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2980 goto default_action;
2981 }
02aa26ce 2982
79072805 2983 switch (*s) {
02aa26ce
NT
2984
2985 /* quoted - in transliterations */
79072805 2986 case '-':
3280af22 2987 if (PL_lex_inwhat == OP_TRANS) {
79072805
LW
2988 *d++ = *s++;
2989 continue;
2990 }
2991 /* FALL THROUGH */
2992 default:
11b8faa4 2993 {
e4ca4584 2994 if ((isALNUMC(*s)))
a2a5de95
NC
2995 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2996 "Unrecognized escape \\%c passed through",
2997 *s);
11b8faa4 2998 /* default action is to copy the quoted character */
f9a63242 2999 goto default_action;
11b8faa4 3000 }
02aa26ce 3001
632403cc 3002 /* eg. \132 indicates the octal constant 0132 */
79072805
LW
3003 case '0': case '1': case '2': case '3':
3004 case '4': case '5': case '6': case '7':
ba210ebe 3005 {
53305cf1
NC
3006 I32 flags = 0;
3007 STRLEN len = 3;
77a135fe 3008 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
ba210ebe
JH
3009 s += len;
3010 }
012bcf8d 3011 goto NUM_ESCAPE_INSERT;
02aa26ce 3012
f0a2b745
KW
3013 /* eg. \o{24} indicates the octal constant \024 */
3014 case 'o':
3015 {
3016 STRLEN len;
454155d9 3017 const char* error;
f0a2b745 3018
454155d9 3019 bool valid = grok_bslash_o(s, &uv, &len, &error, 1);
f0a2b745 3020 s += len;
454155d9 3021 if (! valid) {
f0a2b745
KW
3022 yyerror(error);
3023 continue;
3024 }
3025 goto NUM_ESCAPE_INSERT;
3026 }
3027
77a135fe 3028 /* eg. \x24 indicates the hex constant 0x24 */
79072805 3029 case 'x':
a0481293 3030 {
53305cf1 3031 STRLEN len;
a0481293 3032 const char* error;
355860ce 3033
a0481293
KW
3034 bool valid = grok_bslash_x(s, &uv, &len, &error, 1);
3035 s += len;
3036 if (! valid) {
3037 yyerror(error);
355860ce 3038 continue;
ba210ebe 3039 }
012bcf8d
GS
3040 }
3041
3042 NUM_ESCAPE_INSERT:
ff3f963a
KW
3043 /* Insert oct or hex escaped character. There will always be
3044 * enough room in sv since such escapes will be longer than any
3045 * UTF-8 sequence they can end up as, except if they force us
3046 * to recode the rest of the string into utf8 */
ba7cea30 3047
77a135fe 3048 /* Here uv is the ordinal of the next character being added in
ff3f963a 3049 * unicode (converted from native). */
77a135fe 3050 if (!UNI_IS_INVARIANT(uv)) {
9aa983d2 3051 if (!has_utf8 && uv > 255) {
77a135fe
KW
3052 /* Might need to recode whatever we have accumulated so
3053 * far if it contains any chars variant in utf8 or
3054 * utf-ebcdic. */
3055
3056 SvCUR_set(sv, d - SvPVX_const(sv));
3057 SvPOK_on(sv);
3058 *d = '\0';
77a135fe 3059 /* See Note on sizing above. */
7bf79863
KW
3060 sv_utf8_upgrade_flags_grow(sv,
3061 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3062 UNISKIP(uv) + (STRLEN)(send - s) + 1);
77a135fe
KW
3063 d = SvPVX(sv) + SvCUR(sv);
3064 has_utf8 = TRUE;
012bcf8d
GS
3065 }
3066
77a135fe
KW
3067 if (has_utf8) {
3068 d = (char*)uvuni_to_utf8((U8*)d, uv);
f9a63242
JH
3069 if (PL_lex_inwhat == OP_TRANS &&
3070 PL_sublex_info.sub_op) {
3071 PL_sublex_info.sub_op->op_private |=
3072 (PL_lex_repl ? OPpTRANS_FROM_UTF
3073 : OPpTRANS_TO_UTF);
f9a63242 3074 }
e294cc5d
JH
3075#ifdef EBCDIC
3076 if (uv > 255 && !dorange)
3077 native_range = FALSE;
3078#endif
012bcf8d 3079 }
a0ed51b3 3080 else {
012bcf8d 3081 *d++ = (char)uv;
a0ed51b3 3082 }
012bcf8d
GS
3083 }
3084 else {
c4d5f83a 3085 *d++ = (char) uv;
a0ed51b3 3086 }
79072805 3087 continue;
02aa26ce 3088
4a2d328f 3089 case 'N':
ff3f963a
KW
3090 /* In a non-pattern \N must be a named character, like \N{LATIN
3091 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3092 * mean to match a non-newline. For non-patterns, named
3093 * characters are converted to their string equivalents. In
3094 * patterns, named characters are not converted to their
3095 * ultimate forms for the same reasons that other escapes
3096 * aren't. Instead, they are converted to the \N{U+...} form
3097 * to get the value from the charnames that is in effect right
3098 * now, while preserving the fact that it was a named character
3099 * so that the regex compiler knows this */
3100
3101 /* This section of code doesn't generally use the
3102 * NATIVE_TO_NEED() macro to transform the input. I (khw) did
3103 * a close examination of this macro and determined it is a
3104 * no-op except on utfebcdic variant characters. Every
3105 * character generated by this that would normally need to be
3106 * enclosed by this macro is invariant, so the macro is not
7538f724
KW
3107 * needed, and would complicate use of copy(). XXX There are
3108 * other parts of this file where the macro is used
3109 * inconsistently, but are saved by it being a no-op */
ff3f963a
KW
3110
3111 /* The structure of this section of code (besides checking for
3112 * errors and upgrading to utf8) is:
3113 * Further disambiguate between the two meanings of \N, and if
3114 * not a charname, go process it elsewhere
0a96133f
KW
3115 * If of form \N{U+...}, pass it through if a pattern;
3116 * otherwise convert to utf8
3117 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3118 * pattern; otherwise convert to utf8 */
ff3f963a
KW
3119
3120 /* Here, s points to the 'N'; the test below is guaranteed to
3121 * succeed if we are being called on a pattern as we already
3122 * know from a test above that the next character is a '{'.
3123 * On a non-pattern \N must mean 'named sequence, which
3124 * requires braces */
3125 s++;
3126 if (*s != '{') {
3127 yyerror("Missing braces on \\N{}");
3128 continue;
3129 }
3130 s++;
3131
0a96133f 3132 /* If there is no matching '}', it is an error. */
ff3f963a
KW
3133 if (! (e = strchr(s, '}'))) {
3134 if (! PL_lex_inpat) {
5777a3f7 3135 yyerror("Missing right brace on \\N{}");
0a96133f
KW
3136 } else {
3137 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
dbc0d4f2 3138 }
0a96133f 3139 continue;
ff3f963a 3140 }
cddc7ef4 3141
ff3f963a 3142 /* Here it looks like a named character */
cddc7ef4 3143
ff3f963a
KW
3144 if (PL_lex_inpat) {
3145
3146 /* XXX This block is temporary code. \N{} implies that the
3147 * pattern is to have Unicode semantics, and therefore
3148 * currently has to be encoded in utf8. By putting it in
3149 * utf8 now, we save a whole pass in the regular expression
3150 * compiler. Once that code is changed so Unicode
3151 * semantics doesn't necessarily have to be in utf8, this
da3a4baf
KW
3152 * block should be removed. However, the code that parses
3153 * the output of this would have to be changed to not
3154 * necessarily expect utf8 */
ff3f963a 3155 if (!has_utf8) {
77a135fe 3156 SvCUR_set(sv, d - SvPVX_const(sv));
f08d6ad9 3157 SvPOK_on(sv);
e4f3eed8 3158 *d = '\0';
77a135fe 3159 /* See Note on sizing above. */
7bf79863 3160 sv_utf8_upgrade_flags_grow(sv,
ff3f963a
KW
3161 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3162 /* 5 = '\N{' + cur char + NUL */
3163 (STRLEN)(send - s) + 5);
f08d6ad9 3164 d = SvPVX(sv) + SvCUR(sv);
89491803 3165 has_utf8 = TRUE;
ff3f963a
KW
3166 }
3167 }
423cee85 3168
ff3f963a
KW
3169 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3170 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3171 | PERL_SCAN_DISALLOW_PREFIX;
3172 STRLEN len;
3173
3174 /* For \N{U+...}, the '...' is a unicode value even on
3175 * EBCDIC machines */
3176 s += 2; /* Skip to next char after the 'U+' */
3177 len = e - s;
3178 uv = grok_hex(s, &len, &flags, NULL);
3179 if (len == 0 || len != (STRLEN)(e - s)) {
3180 yyerror("Invalid hexadecimal number in \\N{U+...}");
3181 s = e + 1;
3182 continue;
3183 }
3184
3185 if (PL_lex_inpat) {
3186
e2a7e165
KW
3187 /* On non-EBCDIC platforms, pass through to the regex
3188 * compiler unchanged. The reason we evaluated the
3189 * number above is to make sure there wasn't a syntax
3190 * error. But on EBCDIC we convert to native so
3191 * downstream code can continue to assume it's native
3192 */
ff3f963a 3193 s -= 5; /* Include the '\N{U+' */
e2a7e165
KW
3194#ifdef EBCDIC
3195 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3196 and the \0 */
3197 "\\N{U+%X}",
3198 (unsigned int) UNI_TO_NATIVE(uv));
3199#else
ff3f963a
KW
3200 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3201 d += e - s + 1;
e2a7e165 3202#endif
ff3f963a
KW
3203 }
3204 else { /* Not a pattern: convert the hex to string */
3205
3206 /* If destination is not in utf8, unconditionally
3207 * recode it to be so. This is because \N{} implies
3208 * Unicode semantics, and scalars have to be in utf8
3209 * to guarantee those semantics */
3210 if (! has_utf8) {
3211 SvCUR_set(sv, d - SvPVX_const(sv));
3212 SvPOK_on(sv);
3213 *d = '\0';
3214 /* See Note on sizing above. */
3215 sv_utf8_upgrade_flags_grow(
3216 sv,
3217 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3218 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3219 d = SvPVX(sv) + SvCUR(sv);
3220 has_utf8 = TRUE;
3221 }
3222
3223 /* Add the string to the output */
3224 if (UNI_IS_INVARIANT(uv)) {
3225 *d++ = (char) uv;
3226 }
3227 else d = (char*)uvuni_to_utf8((U8*)d, uv);
3228 }
3229 }
3230 else { /* Here is \N{NAME} but not \N{U+...}. */
3231
3232 SV *res; /* result from charnames */
3233 const char *str; /* the string in 'res' */
3234 STRLEN len; /* its length */
3235
3236 /* Get the value for NAME */
3237 res = newSVpvn(s, e - s);
3238 res = new_constant( NULL, 0, "charnames",
3239 /* includes all of: \N{...} */
3240 res, NULL, s - 3, e - s + 4 );
3241
3242 /* Most likely res will be in utf8 already since the
3243 * standard charnames uses pack U, but a custom translator
3244 * can leave it otherwise, so make sure. XXX This can be
3245 * revisited to not have charnames use utf8 for characters
3246 * that don't need it when regexes don't have to be in utf8
3247 * for Unicode semantics. If doing so, remember EBCDIC */
3248 sv_utf8_upgrade(res);
3249 str = SvPV_const(res, len);
3250
3251 /* Don't accept malformed input */
3252 if (! is_utf8_string((U8 *) str, len)) {
3253 yyerror("Malformed UTF-8 returned by \\N");
3254 }
3255 else if (PL_lex_inpat) {
3256
3257 if (! len) { /* The name resolved to an empty string */
3258 Copy("\\N{}", d, 4, char);
3259 d += 4;
3260 }
3261 else {
3262 /* In order to not lose information for the regex
3263 * compiler, pass the result in the specially made
3264 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3265 * the code points in hex of each character
3266 * returned by charnames */
3267
3268 const char *str_end = str + len;
3269 STRLEN char_length; /* cur char's byte length */
3270 STRLEN output_length; /* and the number of bytes
3271 after this is translated
3272 into hex digits */
3273 const STRLEN off = d - SvPVX_const(sv);
3274
3275 /* 2 hex per byte; 2 chars for '\N'; 2 chars for
3276 * max('U+', '.'); and 1 for NUL */
3277 char hex_string[2 * UTF8_MAXBYTES + 5];
3278
3279 /* Get the first character of the result. */
3280 U32 uv = utf8n_to_uvuni((U8 *) str,
3281 len,
3282 &char_length,
3283 UTF8_ALLOW_ANYUV);
3284
3285 /* The call to is_utf8_string() above hopefully
3286 * guarantees that there won't be an error. But
3287 * it's easy here to make sure. The function just
3288 * above warns and returns 0 if invalid utf8, but
3289 * it can also return 0 if the input is validly a
3290 * NUL. Disambiguate */
3291 if (uv == 0 && NATIVE_TO_ASCII(*str) != '\0') {
3292 uv = UNICODE_REPLACEMENT;
3293 }
3294
3295 /* Convert first code point to hex, including the
e2a7e165
KW
3296 * boiler plate before it. For all these, we
3297 * convert to native format so that downstream code
3298 * can continue to assume the input is native */
78c35590 3299 output_length =
3353de27 3300 my_snprintf(hex_string, sizeof(hex_string),
e2a7e165
KW
3301 "\\N{U+%X",
3302 (unsigned int) UNI_TO_NATIVE(uv));
ff3f963a
KW
3303
3304 /* Make sure there is enough space to hold it */
3305 d = off + SvGROW(sv, off
3306 + output_length
3307 + (STRLEN)(send - e)
3308 + 2); /* '}' + NUL */
3309 /* And output it */
3310 Copy(hex_string, d, output_length, char);
3311 d += output_length;
3312
3313 /* For each subsequent character, append dot and
3314 * its ordinal in hex */
3315 while ((str += char_length) < str_end) {
3316 const STRLEN off = d - SvPVX_const(sv);
3317 U32 uv = utf8n_to_uvuni((U8 *) str,
3318 str_end - str,
3319 &char_length,
3320 UTF8_ALLOW_ANYUV);
3321 if (uv == 0 && NATIVE_TO_ASCII(*str) != '\0') {
3322 uv = UNICODE_REPLACEMENT;
3323 }
3324
78c35590 3325 output_length =
3353de27 3326 my_snprintf(hex_string, sizeof(hex_string),
e2a7e165
KW
3327 ".%X",
3328 (unsigned int) UNI_TO_NATIVE(uv));
ff3f963a
KW
3329
3330 d = off + SvGROW(sv, off
3331 + output_length
3332 + (STRLEN)(send - e)
3333 + 2); /* '}' + NUL */
3334 Copy(hex_string, d, output_length, char);
3335 d += output_length;
3336 }
3337
3338 *d++ = '}'; /* Done. Add the trailing brace */
3339 }
3340 }
3341 else { /* Here, not in a pattern. Convert the name to a
3342 * string. */
3343
3344 /* If destination is not in utf8, unconditionally
3345 * recode it to be so. This is because \N{} implies
3346 * Unicode semantics, and scalars have to be in utf8
3347 * to guarantee those semantics */
3348 if (! has_utf8) {
3349 SvCUR_set(sv, d - SvPVX_const(sv));
3350 SvPOK_on(sv);
3351 *d = '\0';
3352 /* See Note on sizing above. */
3353 sv_utf8_upgrade_flags_grow(sv,
3354 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3355 len + (STRLEN)(send - s) + 1);
3356 d = SvPVX(sv) + SvCUR(sv);
3357 has_utf8 = TRUE;
3358 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3359
3360 /* See Note on sizing above. (NOTE: SvCUR() is not
3361 * set correctly here). */
3362 const STRLEN off = d - SvPVX_const(sv);
3363 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3364 }
3365 Copy(str, d, len, char);
3366 d += len;
423cee85 3367 }
423cee85 3368 SvREFCNT_dec(res);
cb233ae3
KW
3369
3370 /* Deprecate non-approved name syntax */
3371 if (ckWARN_d(WARN_DEPRECATED)) {
3372 bool problematic = FALSE;
3373 char* i = s;
3374
3375 /* For non-ut8 input, look to see that the first
3376 * character is an alpha, then loop through the rest
3377 * checking that each is a continuation */
3378 if (! this_utf8) {
3379 if (! isALPHAU(*i)) problematic = TRUE;
3380 else for (i = s + 1; i < e; i++) {
3381 if (isCHARNAME_CONT(*i)) continue;
3382 problematic = TRUE;
3383 break;
3384 }
3385 }
3386 else {
3387 /* Similarly for utf8. For invariants can check
3388 * directly. We accept anything above the latin1
3389 * range because it is immaterial to Perl if it is
3390 * correct or not, and is expensive to check. But
3391 * it is fairly easy in the latin1 range to convert
3392 * the variants into a single character and check
3393 * those */
3394 if (UTF8_IS_INVARIANT(*i)) {
3395 if (! isALPHAU(*i)) problematic = TRUE;
3396 } else if (UTF8_IS_DOWNGRADEABLE_START(*i)) {
81c14aa2 3397 if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*i,
cb233ae3
KW
3398 *(i+1)))))
3399 {
3400 problematic = TRUE;
3401 }
3402 }
3403 if (! problematic) for (i = s + UTF8SKIP(s);
3404 i < e;
3405 i+= UTF8SKIP(i))
3406 {
3407 if (UTF8_IS_INVARIANT(*i)) {
3408 if (isCHARNAME_CONT(*i)) continue;
3409 } else if (! UTF8_IS_DOWNGRADEABLE_START(*i)) {
3410 continue;
3411 } else if (isCHARNAME_CONT(
3412 UNI_TO_NATIVE(
81c14aa2 3413 TWO_BYTE_UTF8_TO_UNI(*i, *(i+1)))))
cb233ae3
KW
3414 {
3415 continue;
3416 }
3417 problematic = TRUE;
3418 break;
3419 }
3420 }
3421 if (problematic) {
6e1bad6c
KW
3422 /* The e-i passed to the final %.*s makes sure that
3423 * should the trailing NUL be missing that this
3424 * print won't run off the end of the string */
cb233ae3 3425 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
b00fc8d4
NC
3426 "Deprecated character in \\N{...}; marked by <-- HERE in \\N{%.*s<-- HERE %.*s",
3427 (int)(i - s + 1), s, (int)(e - i), i + 1);
cb233ae3
KW
3428 }
3429 }
3430 } /* End \N{NAME} */
ff3f963a
KW
3431#ifdef EBCDIC
3432 if (!dorange)
3433 native_range = FALSE; /* \N{} is defined to be Unicode */
3434#endif
3435 s = e + 1; /* Point to just after the '}' */
423cee85
JH
3436 continue;
3437
02aa26ce 3438 /* \c is a control character */
79072805
LW
3439 case 'c':
3440 s++;
961ce445 3441 if (s < send) {
17a3df4c 3442 *d++ = grok_bslash_c(*s++, has_utf8, 1);
ba210ebe 3443 }
961ce445
RGS
3444 else {
3445 yyerror("Missing control char name in \\c");
3446 }
79072805 3447 continue;
02aa26ce
NT
3448
3449 /* printf-style backslashes, formfeeds, newlines, etc */
79072805 3450 case 'b':
db42d148 3451 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
79072805
LW
3452 break;
3453 case 'n':
db42d148 3454 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
79072805
LW
3455 break;
3456 case 'r':
db42d148 3457 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
79072805
LW
3458 break;
3459 case 'f':
db42d148 3460 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
79072805
LW
3461 break;
3462 case 't':
db42d148 3463 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
79072805 3464 break;
34a3fe2a 3465 case 'e':
db42d148 3466 *d++ = ASCII_TO_NEED(has_utf8,'\033');
34a3fe2a
PP
3467 break;
3468 case 'a':
db42d148 3469 *d++ = ASCII_TO_NEED(has_utf8,'\007');
79072805 3470 break;
02aa26ce
NT
3471 } /* end switch */
3472
79072805
LW
3473 s++;
3474 continue;
02aa26ce 3475 } /* end if (backslash) */
4c3a8340
ST
3476#ifdef EBCDIC
3477 else
3478 literal_endpoint++;
3479#endif
02aa26ce 3480
f9a63242 3481 default_action:
77a135fe
KW
3482 /* If we started with encoded form, or already know we want it,
3483 then encode the next character */
3484 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
2b9d42f0 3485 STRLEN len = 1;
77a135fe
KW
3486
3487
3488 /* One might think that it is wasted effort in the case of the
3489 * source being utf8 (this_utf8 == TRUE) to take the next character
3490 * in the source, convert it to an unsigned value, and then convert
3491 * it back again. But the source has not been validated here. The
3492 * routine that does the conversion checks for errors like
3493 * malformed utf8 */
3494
5f66b61c
AL
3495 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
3496 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
77a135fe
KW
3497 if (!has_utf8) {
3498 SvCUR_set(sv, d - SvPVX_const(sv));
3499 SvPOK_on(sv);
3500 *d = '\0';
77a135fe 3501 /* See Note on sizing above. */
7bf79863
KW
3502 sv_utf8_upgrade_flags_grow(sv,
3503 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3504 need + (STRLEN)(send - s) + 1);
77a135fe
KW
3505 d = SvPVX(sv) + SvCUR(sv);
3506 has_utf8 = TRUE;
3507 } else if (need > len) {
3508 /* encoded value larger than old, may need extra space (NOTE:
3509 * SvCUR() is not set correctly here). See Note on sizing
3510 * above. */
9d4ba2ae 3511 const STRLEN off = d - SvPVX_const(sv);
77a135fe 3512 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
2b9d42f0 3513 }
77a135fe
KW
3514 s += len;
3515
5f66b61c 3516 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
e294cc5d
JH
3517#ifdef EBCDIC
3518 if (uv > 255 && !dorange)
3519 native_range = FALSE;
3520#endif
2b9d42f0
NIS
3521 }
3522 else {
3523 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3524 }
02aa26ce
NT
3525 } /* while loop to process each character */
3526
3527 /* terminate the string and set up the sv */
79072805 3528 *d = '\0';
95a20fc0 3529 SvCUR_set(sv, d - SvPVX_const(sv));
2b9d42f0 3530 if (SvCUR(sv) >= SvLEN(sv))
5637ef5b
NC
3531 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3532 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
2b9d42f0 3533
79072805 3534 SvPOK_on(sv);
9f4817db 3535 if (PL_encoding && !has_utf8) {
d0063567
DK
3536 sv_recode_to_utf8(sv, PL_encoding);
3537 if (SvUTF8(sv))
3538 has_utf8 = TRUE;
9f4817db 3539 }
2b9d42f0 3540 if (has_utf8) {
7e2040f0 3541 SvUTF8_on(sv);
2b9d42f0 3542 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
d0063567 3543 PL_sublex_info.sub_op->op_private |=
2b9d42f0
NIS
3544 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3545 }
3546 }
79072805 3547
02aa26ce 3548 /* shrink the sv if we allocated more than we used */
79072805 3549 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1da4ca5f 3550 SvPV_shrink_to_cur(sv);
79072805 3551 }
02aa26ce 3552
6154021b 3553 /* return the substring (via pl_yylval) only if we parsed anything */
3280af22 3554 if (s > PL_bufptr) {
eb0d8d16
NC
3555 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
3556 const char *const key = PL_lex_inpat ? "qr" : "q";
3557 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3558 const char *type;
3559 STRLEN typelen;
3560
3561 if (PL_lex_inwhat == OP_TRANS) {
3562 type = "tr";
3563 typelen = 2;
3564 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3565 type = "s";
3566 typelen = 1;
9da1dd8f
DM
3567 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3568 type = "q";
3569 typelen = 1;
eb0d8d16
NC
3570 } else {
3571 type = "qq";
3572 typelen = 2;
3573 }
3574
3575 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3576 type, typelen);
3577 }
6154021b 3578 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
b3ac6de7 3579 } else
8990e307 3580 SvREFCNT_dec(sv);
79072805
LW
3581 return s;
3582}
3583
ffb4593c
NT
3584/* S_intuit_more
3585 * Returns TRUE if there's more to the expression (e.g., a subscript),
3586 * FALSE otherwise.
ffb4593c
NT
3587 *
3588 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3589 *
3590 * ->[ and ->{ return TRUE
3591 * { and [ outside a pattern are always subscripts, so return TRUE
3592 * if we're outside a pattern and it's not { or [, then return FALSE
3593 * if we're in a pattern and the first char is a {
3594 * {4,5} (any digits around the comma) returns FALSE
3595 * if we're in a pattern and the first char is a [
3596 * [] returns FALSE
3597 * [SOMETHING] has a funky algorithm to decide whether it's a
3598 * character class or not. It has to deal with things like
3599 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3600 * anything else returns TRUE
3601 */
3602
9cbb5ea2
GS
3603/* This is the one truly awful dwimmer necessary to conflate C and sed. */
3604
76e3520e 3605STATIC int
cea2e8a9 3606S_intuit_more(pTHX_ register char *s)
79072805 3607{
97aff369 3608 dVAR;
7918f24d
NC
3609
3610 PERL_ARGS_ASSERT_INTUIT_MORE;
3611
3280af22 3612 if (PL_lex_brackets)
79072805
LW
3613 return TRUE;
3614 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3615 return TRUE;
3616 if (*s != '{' && *s != '[')
3617 return FALSE;
3280af22 3618 if (!PL_lex_inpat)
79072805
LW
3619 return TRUE;
3620
3621 /* In a pattern, so maybe we have {n,m}. */
3622 if (*s == '{') {
b3155d95 3623 if (regcurly(s)) {
79072805 3624 return FALSE;
b3155d95 3625 }
79072805 3626 return TRUE;
79072805
LW
3627 }
3628
3629 /* On the other hand, maybe we have a character class */
3630
3631 s++;
3632 if (*s == ']' || *s == '^')
3633 return FALSE;
3634 else {
ffb4593c 3635 /* this is terrifying, and it works */
79072805
LW
3636 int weight = 2; /* let's weigh the evidence */
3637 char seen[256];
f27ffc4a 3638 unsigned char un_char = 255, last_un_char;
9d4ba2ae 3639 const char * const send = strchr(s,']');
3280af22 3640 char tmpbuf[sizeof PL_tokenbuf * 4];
79072805
LW
3641
3642 if (!send) /* has to be an expression */
3643 return TRUE;
3644
3645 Zero(seen,256,char);
3646 if (*s == '$')
3647 weight -= 3;
3648 else if (isDIGIT(*s)) {
3649 if (s[1] != ']') {
3650 if (isDIGIT(s[1]) && s[2] == ']')
3651 weight -= 10;
3652 }
3653 else
3654 weight -= 100;
3655 }
3656 for (; s < send; s++) {
3657 last_un_char = un_char;
3658 un_char = (unsigned char)*s;
3659 switch (*s) {
3660 case '@':
3661 case '&':
3662 case '$':
3663 weight -= seen[un_char] * 10;
7e2040f0 3664 if (isALNUM_lazy_if(s+1,UTF)) {
90e5519e 3665 int len;
8903cb82 3666 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
90e5519e 3667 len = (int)strlen(tmpbuf);
6fbd0d97
BF
3668 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3669 UTF ? SVf_UTF8 : 0, SVt_PV))
79072805
LW
3670 weight -= 100;
3671 else
3672 weight -= 10;
3673 }
3674 else if (*s == '$' && s[1] &&
93a17b20
LW
3675 strchr("[#!%*<>()-=",s[1])) {
3676 if (/*{*/ strchr("])} =",s[2]))
79072805
LW
3677 weight -= 10;
3678 else
3679 weight -= 1;
3680 }
3681 break;
3682 case '\\':
3683 un_char = 254;
3684 if (s[1]) {
93a17b20 3685 if (strchr("wds]",s[1]))
79072805 3686 weight += 100;
10edeb5d 3687 else if (seen[(U8)'\''] || seen[(U8)'"'])
79072805 3688 weight += 1;
93a17b20 3689 else if (strchr("rnftbxcav",s[1]))
79072805
LW
3690 weight += 40;
3691 else if (isDIGIT(s[1])) {
3692 weight += 40;
3693 while (s[1] && isDIGIT(s[1]))
3694 s++;
3695 }
3696 }
3697 else
3698 weight += 100;
3699 break;
3700 case '-':
3701 if (s[1] == '\\')
3702 weight += 50;
93a17b20 3703 if (strchr("aA01! ",last_un_char))
79072805 3704 weight += 30;
93a17b20 3705 if (strchr("zZ79~",s[1]))
79072805 3706 weight += 30;
f27ffc4a
GS
3707 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3708 weight -= 5; /* cope with negative subscript */
79072805
LW
3709 break;
3710 default:
3792a11b
NC
3711 if (!isALNUM(last_un_char)
3712 && !(last_un_char == '$' || last_un_char == '@'
3713 || last_un_char == '&')
3714 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
79072805
LW
3715 char *d = tmpbuf;
3716 while (isALPHA(*s))
3717 *d++ = *s++;
3718 *d = '\0';
5458a98a 3719 if (keyword(tmpbuf, d - tmpbuf, 0))
79072805
LW
3720 weight -= 150;
3721 }
3722 if (un_char == last_un_char + 1)
3723 weight += 5;
3724 weight -= seen[un_char];
3725 break;
3726 }
3727 seen[un_char]++;
3728 }
3729 if (weight >= 0) /* probably a character class */
3730 return FALSE;
3731 }
3732
3733 return TRUE;
3734}
ffed7fef 3735
ffb4593c
NT
3736/*
3737 * S_intuit_method
3738 *
3739 * Does all the checking to disambiguate
3740 * foo bar
3741 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3742 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3743 *
3744 * First argument is the stuff after the first token, e.g. "bar".
3745 *
3746 * Not a method if bar is a filehandle.
3747 * Not a method if foo is a subroutine prototyped to take a filehandle.
3748 * Not a method if it's really "Foo $bar"
3749 * Method if it's "foo $bar"
3750 * Not a method if it's really "print foo $bar"
3751 * Method if it's really "foo package::" (interpreted as package->foo)
8f8cf39c 3752 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3cb0bbe5 3753 * Not a method if bar is a filehandle or package, but is quoted with
ffb4593c
NT
3754 * =>
3755 */
3756
76e3520e 3757STATIC int
62d55b22 3758S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
a0d0e21e 3759{
97aff369 3760 dVAR;
a0d0e21e 3761 char *s = start + (*start == '$');
3280af22 3762 char tmpbuf[sizeof PL_tokenbuf];
a0d0e21e
LW
3763 STRLEN len;
3764 GV* indirgv;
5db06880
NC
3765#ifdef PERL_MAD
3766 int soff;
3767#endif
a0d0e21e 3768
7918f24d
NC
3769 PERL_ARGS_ASSERT_INTUIT_METHOD;
3770