line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
/* toke.c |
2
|
|
|
|
|
|
* |
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 |
5
|
|
|
|
|
|
* |
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. |
8
|
|
|
|
|
|
* |
9
|
|
|
|
|
|
*/ |
10
|
|
|
|
|
|
|
11
|
|
|
|
|
|
/* |
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"] |
15
|
|
|
|
|
|
*/ |
16
|
|
|
|
|
|
|
17
|
|
|
|
|
|
/* |
18
|
|
|
|
|
|
* This file is the lexer for Perl. It's closely linked to the |
19
|
|
|
|
|
|
* parser, perly.y. |
20
|
|
|
|
|
|
* |
21
|
|
|
|
|
|
* The main routine is yylex(), which returns the next token. |
22
|
|
|
|
|
|
*/ |
23
|
|
|
|
|
|
|
24
|
|
|
|
|
|
/* |
25
|
|
|
|
|
|
=head1 Lexer interface |
26
|
|
|
|
|
|
|
27
|
|
|
|
|
|
This is the lower layer of the Perl parser, managing characters and tokens. |
28
|
|
|
|
|
|
|
29
|
|
|
|
|
|
=for apidoc AmU|yy_parser *|PL_parser |
30
|
|
|
|
|
|
|
31
|
|
|
|
|
|
Pointer to a structure encapsulating the state of the parsing operation |
32
|
|
|
|
|
|
currently in progress. The pointer can be locally changed to perform |
33
|
|
|
|
|
|
a nested parse without interfering with the state of an outer parse. |
34
|
|
|
|
|
|
Individual members of C have their own documentation. |
35
|
|
|
|
|
|
|
36
|
|
|
|
|
|
=cut |
37
|
|
|
|
|
|
*/ |
38
|
|
|
|
|
|
|
39
|
|
|
|
|
|
#include "EXTERN.h" |
40
|
|
|
|
|
|
#define PERL_IN_TOKE_C |
41
|
|
|
|
|
|
#include "perl.h" |
42
|
|
|
|
|
|
#include "dquote_static.c" |
43
|
|
|
|
|
|
|
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
|
|
|
|
|
|
|
47
|
|
|
|
|
|
#define pl_yylval (PL_parser->yylval) |
48
|
|
|
|
|
|
|
49
|
|
|
|
|
|
/* XXX temporary backwards compatibility */ |
50
|
|
|
|
|
|
#define PL_lex_brackets (PL_parser->lex_brackets) |
51
|
|
|
|
|
|
#define PL_lex_allbrackets (PL_parser->lex_allbrackets) |
52
|
|
|
|
|
|
#define PL_lex_fakeeof (PL_parser->lex_fakeeof) |
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_preambled (PL_parser->preambled) |
70
|
|
|
|
|
|
#define PL_sublex_info (PL_parser->sublex_info) |
71
|
|
|
|
|
|
#define PL_linestr (PL_parser->linestr) |
72
|
|
|
|
|
|
#define PL_expect (PL_parser->expect) |
73
|
|
|
|
|
|
#define PL_copline (PL_parser->copline) |
74
|
|
|
|
|
|
#define PL_bufptr (PL_parser->bufptr) |
75
|
|
|
|
|
|
#define PL_oldbufptr (PL_parser->oldbufptr) |
76
|
|
|
|
|
|
#define PL_oldoldbufptr (PL_parser->oldoldbufptr) |
77
|
|
|
|
|
|
#define PL_linestart (PL_parser->linestart) |
78
|
|
|
|
|
|
#define PL_bufend (PL_parser->bufend) |
79
|
|
|
|
|
|
#define PL_last_uni (PL_parser->last_uni) |
80
|
|
|
|
|
|
#define PL_last_lop (PL_parser->last_lop) |
81
|
|
|
|
|
|
#define PL_last_lop_op (PL_parser->last_lop_op) |
82
|
|
|
|
|
|
#define PL_lex_state (PL_parser->lex_state) |
83
|
|
|
|
|
|
#define PL_rsfp (PL_parser->rsfp) |
84
|
|
|
|
|
|
#define PL_rsfp_filters (PL_parser->rsfp_filters) |
85
|
|
|
|
|
|
#define PL_in_my (PL_parser->in_my) |
86
|
|
|
|
|
|
#define PL_in_my_stash (PL_parser->in_my_stash) |
87
|
|
|
|
|
|
#define PL_tokenbuf (PL_parser->tokenbuf) |
88
|
|
|
|
|
|
#define PL_multi_end (PL_parser->multi_end) |
89
|
|
|
|
|
|
#define PL_error_count (PL_parser->error_count) |
90
|
|
|
|
|
|
|
91
|
|
|
|
|
|
#ifdef PERL_MAD |
92
|
|
|
|
|
|
# define PL_endwhite (PL_parser->endwhite) |
93
|
|
|
|
|
|
# define PL_faketokens (PL_parser->faketokens) |
94
|
|
|
|
|
|
# define PL_lasttoke (PL_parser->lasttoke) |
95
|
|
|
|
|
|
# define PL_nextwhite (PL_parser->nextwhite) |
96
|
|
|
|
|
|
# define PL_realtokenstart (PL_parser->realtokenstart) |
97
|
|
|
|
|
|
# define PL_skipwhite (PL_parser->skipwhite) |
98
|
|
|
|
|
|
# define PL_thisclose (PL_parser->thisclose) |
99
|
|
|
|
|
|
# define PL_thismad (PL_parser->thismad) |
100
|
|
|
|
|
|
# define PL_thisopen (PL_parser->thisopen) |
101
|
|
|
|
|
|
# define PL_thisstuff (PL_parser->thisstuff) |
102
|
|
|
|
|
|
# define PL_thistoken (PL_parser->thistoken) |
103
|
|
|
|
|
|
# define PL_thiswhite (PL_parser->thiswhite) |
104
|
|
|
|
|
|
# define PL_thiswhite (PL_parser->thiswhite) |
105
|
|
|
|
|
|
# define PL_nexttoke (PL_parser->nexttoke) |
106
|
|
|
|
|
|
# define PL_curforce (PL_parser->curforce) |
107
|
|
|
|
|
|
#else |
108
|
|
|
|
|
|
# define PL_nexttoke (PL_parser->nexttoke) |
109
|
|
|
|
|
|
# define PL_nexttype (PL_parser->nexttype) |
110
|
|
|
|
|
|
# define PL_nextval (PL_parser->nextval) |
111
|
|
|
|
|
|
#endif |
112
|
|
|
|
|
|
|
113
|
|
|
|
|
|
static const char* const ident_too_long = "Identifier too long"; |
114
|
|
|
|
|
|
|
115
|
|
|
|
|
|
#ifdef PERL_MAD |
116
|
|
|
|
|
|
# define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; } |
117
|
|
|
|
|
|
# define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val |
118
|
|
|
|
|
|
#else |
119
|
|
|
|
|
|
# define CURMAD(slot,sv) |
120
|
|
|
|
|
|
# define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke] |
121
|
|
|
|
|
|
#endif |
122
|
|
|
|
|
|
|
123
|
|
|
|
|
|
#define XENUMMASK 0x3f |
124
|
|
|
|
|
|
#define XFAKEEOF 0x40 |
125
|
|
|
|
|
|
#define XFAKEBRACK 0x80 |
126
|
|
|
|
|
|
|
127
|
|
|
|
|
|
#ifdef USE_UTF8_SCRIPTS |
128
|
|
|
|
|
|
# define UTF (!IN_BYTES) |
129
|
|
|
|
|
|
#else |
130
|
|
|
|
|
|
# define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8))) |
131
|
|
|
|
|
|
#endif |
132
|
|
|
|
|
|
|
133
|
|
|
|
|
|
/* The maximum number of characters preceding the unrecognized one to display */ |
134
|
|
|
|
|
|
#define UNRECOGNIZED_PRECEDE_COUNT 10 |
135
|
|
|
|
|
|
|
136
|
|
|
|
|
|
/* In variables named $^X, these are the legal values for X. |
137
|
|
|
|
|
|
* 1999-02-27 mjd-perl-patch@plover.com */ |
138
|
|
|
|
|
|
#define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x))) |
139
|
|
|
|
|
|
|
140
|
|
|
|
|
|
#define SPACE_OR_TAB(c) isBLANK_A(c) |
141
|
|
|
|
|
|
|
142
|
|
|
|
|
|
/* LEX_* are values for PL_lex_state, the state of the lexer. |
143
|
|
|
|
|
|
* They are arranged oddly so that the guard on the switch statement |
144
|
|
|
|
|
|
* can get by with a single comparison (if the compiler is smart enough). |
145
|
|
|
|
|
|
* |
146
|
|
|
|
|
|
* These values refer to the various states within a sublex parse, |
147
|
|
|
|
|
|
* i.e. within a double quotish string |
148
|
|
|
|
|
|
*/ |
149
|
|
|
|
|
|
|
150
|
|
|
|
|
|
/* #define LEX_NOTPARSING 11 is done in perl.h. */ |
151
|
|
|
|
|
|
|
152
|
|
|
|
|
|
#define LEX_NORMAL 10 /* normal code (ie not within "...") */ |
153
|
|
|
|
|
|
#define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */ |
154
|
|
|
|
|
|
#define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */ |
155
|
|
|
|
|
|
#define LEX_INTERPPUSH 7 /* starting a new sublex parse level */ |
156
|
|
|
|
|
|
#define LEX_INTERPSTART 6 /* expecting the start of a $var */ |
157
|
|
|
|
|
|
|
158
|
|
|
|
|
|
/* at end of code, eg "$x" followed by: */ |
159
|
|
|
|
|
|
#define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */ |
160
|
|
|
|
|
|
#define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */ |
161
|
|
|
|
|
|
|
162
|
|
|
|
|
|
#define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of |
163
|
|
|
|
|
|
string or after \E, $foo, etc */ |
164
|
|
|
|
|
|
#define LEX_INTERPCONST 2 /* NOT USED */ |
165
|
|
|
|
|
|
#define LEX_FORMLINE 1 /* expecting a format line */ |
166
|
|
|
|
|
|
#define LEX_KNOWNEXT 0 /* next token known; just return it */ |
167
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
169
|
|
|
|
|
|
#ifdef DEBUGGING |
170
|
|
|
|
|
|
static const char* const lex_state_names[] = { |
171
|
|
|
|
|
|
"KNOWNEXT", |
172
|
|
|
|
|
|
"FORMLINE", |
173
|
|
|
|
|
|
"INTERPCONST", |
174
|
|
|
|
|
|
"INTERPCONCAT", |
175
|
|
|
|
|
|
"INTERPENDMAYBE", |
176
|
|
|
|
|
|
"INTERPEND", |
177
|
|
|
|
|
|
"INTERPSTART", |
178
|
|
|
|
|
|
"INTERPPUSH", |
179
|
|
|
|
|
|
"INTERPCASEMOD", |
180
|
|
|
|
|
|
"INTERPNORMAL", |
181
|
|
|
|
|
|
"NORMAL" |
182
|
|
|
|
|
|
}; |
183
|
|
|
|
|
|
#endif |
184
|
|
|
|
|
|
|
185
|
|
|
|
|
|
#ifdef ff_next |
186
|
|
|
|
|
|
#undef ff_next |
187
|
|
|
|
|
|
#endif |
188
|
|
|
|
|
|
|
189
|
|
|
|
|
|
#include "keywords.h" |
190
|
|
|
|
|
|
|
191
|
|
|
|
|
|
/* CLINE is a macro that ensures PL_copline has a sane value */ |
192
|
|
|
|
|
|
|
193
|
|
|
|
|
|
#ifdef CLINE |
194
|
|
|
|
|
|
#undef CLINE |
195
|
|
|
|
|
|
#endif |
196
|
|
|
|
|
|
#define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline)) |
197
|
|
|
|
|
|
|
198
|
|
|
|
|
|
#ifdef PERL_MAD |
199
|
|
|
|
|
|
# define SKIPSPACE0(s) skipspace0(s) |
200
|
|
|
|
|
|
# define SKIPSPACE1(s) skipspace1(s) |
201
|
|
|
|
|
|
# define SKIPSPACE2(s,tsv) skipspace2(s,&tsv) |
202
|
|
|
|
|
|
# define PEEKSPACE(s) skipspace2(s,0) |
203
|
|
|
|
|
|
#else |
204
|
|
|
|
|
|
# define SKIPSPACE0(s) skipspace(s) |
205
|
|
|
|
|
|
# define SKIPSPACE1(s) skipspace(s) |
206
|
|
|
|
|
|
# define SKIPSPACE2(s,tsv) skipspace(s) |
207
|
|
|
|
|
|
# define PEEKSPACE(s) skipspace(s) |
208
|
|
|
|
|
|
#endif |
209
|
|
|
|
|
|
|
210
|
|
|
|
|
|
/* |
211
|
|
|
|
|
|
* Convenience functions to return different tokens and prime the |
212
|
|
|
|
|
|
* lexer for the next token. They all take an argument. |
213
|
|
|
|
|
|
* |
214
|
|
|
|
|
|
* TOKEN : generic token (used for '(', DOLSHARP, etc) |
215
|
|
|
|
|
|
* OPERATOR : generic operator |
216
|
|
|
|
|
|
* AOPERATOR : assignment operator |
217
|
|
|
|
|
|
* PREBLOCK : beginning the block after an if, while, foreach, ... |
218
|
|
|
|
|
|
* PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref) |
219
|
|
|
|
|
|
* PREREF : *EXPR where EXPR is not a simple identifier |
220
|
|
|
|
|
|
* TERM : expression term |
221
|
|
|
|
|
|
* LOOPX : loop exiting command (goto, last, dump, etc) |
222
|
|
|
|
|
|
* FTST : file test operator |
223
|
|
|
|
|
|
* FUN0 : zero-argument function |
224
|
|
|
|
|
|
* FUN0OP : zero-argument function, with its op created in this file |
225
|
|
|
|
|
|
* FUN1 : not used, except for not, which isn't a UNIOP |
226
|
|
|
|
|
|
* BOop : bitwise or or xor |
227
|
|
|
|
|
|
* BAop : bitwise and |
228
|
|
|
|
|
|
* SHop : shift operator |
229
|
|
|
|
|
|
* PWop : power operator |
230
|
|
|
|
|
|
* PMop : pattern-matching operator |
231
|
|
|
|
|
|
* Aop : addition-level operator |
232
|
|
|
|
|
|
* Mop : multiplication-level operator |
233
|
|
|
|
|
|
* Eop : equality-testing operator |
234
|
|
|
|
|
|
* Rop : relational operator <= != gt |
235
|
|
|
|
|
|
* |
236
|
|
|
|
|
|
* Also see LOP and lop() below. |
237
|
|
|
|
|
|
*/ |
238
|
|
|
|
|
|
|
239
|
|
|
|
|
|
#ifdef DEBUGGING /* Serve -DT. */ |
240
|
|
|
|
|
|
# define REPORT(retval) tokereport((I32)retval, &pl_yylval) |
241
|
|
|
|
|
|
#else |
242
|
|
|
|
|
|
# define REPORT(retval) (retval) |
243
|
|
|
|
|
|
#endif |
244
|
|
|
|
|
|
|
245
|
|
|
|
|
|
#define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval)) |
246
|
|
|
|
|
|
#define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval)) |
247
|
|
|
|
|
|
#define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval))) |
248
|
|
|
|
|
|
#define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval)) |
249
|
|
|
|
|
|
#define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval)) |
250
|
|
|
|
|
|
#define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval)) |
251
|
|
|
|
|
|
#define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval)) |
252
|
|
|
|
|
|
#define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX)) |
253
|
|
|
|
|
|
#define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP)) |
254
|
|
|
|
|
|
#define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0)) |
255
|
|
|
|
|
|
#define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP)) |
256
|
|
|
|
|
|
#define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1)) |
257
|
|
|
|
|
|
#define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP))) |
258
|
|
|
|
|
|
#define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP))) |
259
|
|
|
|
|
|
#define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP))) |
260
|
|
|
|
|
|
#define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP))) |
261
|
|
|
|
|
|
#define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP)) |
262
|
|
|
|
|
|
#define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP))) |
263
|
|
|
|
|
|
#define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP))) |
264
|
|
|
|
|
|
#define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP)) |
265
|
|
|
|
|
|
#define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP)) |
266
|
|
|
|
|
|
|
267
|
|
|
|
|
|
/* This bit of chicanery makes a unary function followed by |
268
|
|
|
|
|
|
* a parenthesis into a function with one argument, highest precedence. |
269
|
|
|
|
|
|
* The UNIDOR macro is for unary functions that can be followed by the // |
270
|
|
|
|
|
|
* operator (such as C). |
271
|
|
|
|
|
|
*/ |
272
|
|
|
|
|
|
#define UNI3(f,x,have_x) { \ |
273
|
|
|
|
|
|
pl_yylval.ival = f; \ |
274
|
|
|
|
|
|
if (have_x) PL_expect = x; \ |
275
|
|
|
|
|
|
PL_bufptr = s; \ |
276
|
|
|
|
|
|
PL_last_uni = PL_oldbufptr; \ |
277
|
|
|
|
|
|
PL_last_lop_op = f; \ |
278
|
|
|
|
|
|
if (*s == '(') \ |
279
|
|
|
|
|
|
return REPORT( (int)FUNC1 ); \ |
280
|
|
|
|
|
|
s = PEEKSPACE(s); \ |
281
|
|
|
|
|
|
return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \ |
282
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
#define UNI(f) UNI3(f,XTERM,1) |
284
|
|
|
|
|
|
#define UNIDOR(f) UNI3(f,XTERMORDORDOR,1) |
285
|
|
|
|
|
|
#define UNIPROTO(f,optional) { \ |
286
|
|
|
|
|
|
if (optional) PL_last_uni = PL_oldbufptr; \ |
287
|
|
|
|
|
|
OPERATOR(f); \ |
288
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
290
|
|
|
|
|
|
#define UNIBRACK(f) UNI3(f,0,0) |
291
|
|
|
|
|
|
|
292
|
|
|
|
|
|
/* grandfather return to old style */ |
293
|
|
|
|
|
|
#define OLDLOP(f) \ |
294
|
|
|
|
|
|
do { \ |
295
|
|
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \ |
296
|
|
|
|
|
|
PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \ |
297
|
|
|
|
|
|
pl_yylval.ival = (f); \ |
298
|
|
|
|
|
|
PL_expect = XTERM; \ |
299
|
|
|
|
|
|
PL_bufptr = s; \ |
300
|
|
|
|
|
|
return (int)LSTOP; \ |
301
|
|
|
|
|
|
} while(0) |
302
|
|
|
|
|
|
|
303
|
|
|
|
|
|
#define COPLINE_INC_WITH_HERELINES \ |
304
|
|
|
|
|
|
STMT_START { \ |
305
|
|
|
|
|
|
CopLINE_inc(PL_curcop); \ |
306
|
|
|
|
|
|
if (PL_parser->lex_shared->herelines) \ |
307
|
|
|
|
|
|
CopLINE(PL_curcop) += PL_parser->lex_shared->herelines, \ |
308
|
|
|
|
|
|
PL_parser->lex_shared->herelines = 0; \ |
309
|
|
|
|
|
|
} STMT_END |
310
|
|
|
|
|
|
/* Called after scan_str to update CopLINE(PL_curcop), but only when there |
311
|
|
|
|
|
|
* is no sublex_push to follow. */ |
312
|
|
|
|
|
|
#define COPLINE_SET_FROM_MULTI_END \ |
313
|
|
|
|
|
|
STMT_START { \ |
314
|
|
|
|
|
|
CopLINE_set(PL_curcop, PL_multi_end); \ |
315
|
|
|
|
|
|
if (PL_multi_end != PL_multi_start) \ |
316
|
|
|
|
|
|
PL_parser->lex_shared->herelines = 0; \ |
317
|
|
|
|
|
|
} STMT_END |
318
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
320
|
|
|
|
|
|
#ifdef DEBUGGING |
321
|
|
|
|
|
|
|
322
|
|
|
|
|
|
/* how to interpret the pl_yylval associated with the token */ |
323
|
|
|
|
|
|
enum token_type { |
324
|
|
|
|
|
|
TOKENTYPE_NONE, |
325
|
|
|
|
|
|
TOKENTYPE_IVAL, |
326
|
|
|
|
|
|
TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */ |
327
|
|
|
|
|
|
TOKENTYPE_PVAL, |
328
|
|
|
|
|
|
TOKENTYPE_OPVAL |
329
|
|
|
|
|
|
}; |
330
|
|
|
|
|
|
|
331
|
|
|
|
|
|
static struct debug_tokens { |
332
|
|
|
|
|
|
const int token; |
333
|
|
|
|
|
|
enum token_type type; |
334
|
|
|
|
|
|
const char *name; |
335
|
|
|
|
|
|
} const debug_tokens[] = |
336
|
|
|
|
|
|
{ |
337
|
|
|
|
|
|
{ ADDOP, TOKENTYPE_OPNUM, "ADDOP" }, |
338
|
|
|
|
|
|
{ ANDAND, TOKENTYPE_NONE, "ANDAND" }, |
339
|
|
|
|
|
|
{ ANDOP, TOKENTYPE_NONE, "ANDOP" }, |
340
|
|
|
|
|
|
{ ANONSUB, TOKENTYPE_IVAL, "ANONSUB" }, |
341
|
|
|
|
|
|
{ ARROW, TOKENTYPE_NONE, "ARROW" }, |
342
|
|
|
|
|
|
{ ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" }, |
343
|
|
|
|
|
|
{ BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" }, |
344
|
|
|
|
|
|
{ BITOROP, TOKENTYPE_OPNUM, "BITOROP" }, |
345
|
|
|
|
|
|
{ COLONATTR, TOKENTYPE_NONE, "COLONATTR" }, |
346
|
|
|
|
|
|
{ CONTINUE, TOKENTYPE_NONE, "CONTINUE" }, |
347
|
|
|
|
|
|
{ DEFAULT, TOKENTYPE_NONE, "DEFAULT" }, |
348
|
|
|
|
|
|
{ DO, TOKENTYPE_NONE, "DO" }, |
349
|
|
|
|
|
|
{ DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" }, |
350
|
|
|
|
|
|
{ DORDOR, TOKENTYPE_NONE, "DORDOR" }, |
351
|
|
|
|
|
|
{ DOROP, TOKENTYPE_OPNUM, "DOROP" }, |
352
|
|
|
|
|
|
{ DOTDOT, TOKENTYPE_IVAL, "DOTDOT" }, |
353
|
|
|
|
|
|
{ ELSE, TOKENTYPE_NONE, "ELSE" }, |
354
|
|
|
|
|
|
{ ELSIF, TOKENTYPE_IVAL, "ELSIF" }, |
355
|
|
|
|
|
|
{ EQOP, TOKENTYPE_OPNUM, "EQOP" }, |
356
|
|
|
|
|
|
{ FOR, TOKENTYPE_IVAL, "FOR" }, |
357
|
|
|
|
|
|
{ FORMAT, TOKENTYPE_NONE, "FORMAT" }, |
358
|
|
|
|
|
|
{ FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" }, |
359
|
|
|
|
|
|
{ FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" }, |
360
|
|
|
|
|
|
{ FUNC, TOKENTYPE_OPNUM, "FUNC" }, |
361
|
|
|
|
|
|
{ FUNC0, TOKENTYPE_OPNUM, "FUNC0" }, |
362
|
|
|
|
|
|
{ FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" }, |
363
|
|
|
|
|
|
{ FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" }, |
364
|
|
|
|
|
|
{ FUNC1, TOKENTYPE_OPNUM, "FUNC1" }, |
365
|
|
|
|
|
|
{ FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" }, |
366
|
|
|
|
|
|
{ GIVEN, TOKENTYPE_IVAL, "GIVEN" }, |
367
|
|
|
|
|
|
{ HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" }, |
368
|
|
|
|
|
|
{ IF, TOKENTYPE_IVAL, "IF" }, |
369
|
|
|
|
|
|
{ LABEL, TOKENTYPE_PVAL, "LABEL" }, |
370
|
|
|
|
|
|
{ LOCAL, TOKENTYPE_IVAL, "LOCAL" }, |
371
|
|
|
|
|
|
{ LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" }, |
372
|
|
|
|
|
|
{ LSTOP, TOKENTYPE_OPNUM, "LSTOP" }, |
373
|
|
|
|
|
|
{ LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" }, |
374
|
|
|
|
|
|
{ MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" }, |
375
|
|
|
|
|
|
{ METHOD, TOKENTYPE_OPVAL, "METHOD" }, |
376
|
|
|
|
|
|
{ MULOP, TOKENTYPE_OPNUM, "MULOP" }, |
377
|
|
|
|
|
|
{ MY, TOKENTYPE_IVAL, "MY" }, |
378
|
|
|
|
|
|
{ NOAMP, TOKENTYPE_NONE, "NOAMP" }, |
379
|
|
|
|
|
|
{ NOTOP, TOKENTYPE_NONE, "NOTOP" }, |
380
|
|
|
|
|
|
{ OROP, TOKENTYPE_IVAL, "OROP" }, |
381
|
|
|
|
|
|
{ OROR, TOKENTYPE_NONE, "OROR" }, |
382
|
|
|
|
|
|
{ PACKAGE, TOKENTYPE_NONE, "PACKAGE" }, |
383
|
|
|
|
|
|
{ PEG, TOKENTYPE_NONE, "PEG" }, |
384
|
|
|
|
|
|
{ PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" }, |
385
|
|
|
|
|
|
{ PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" }, |
386
|
|
|
|
|
|
{ PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" }, |
387
|
|
|
|
|
|
{ POSTDEC, TOKENTYPE_NONE, "POSTDEC" }, |
388
|
|
|
|
|
|
{ POSTINC, TOKENTYPE_NONE, "POSTINC" }, |
389
|
|
|
|
|
|
{ POWOP, TOKENTYPE_OPNUM, "POWOP" }, |
390
|
|
|
|
|
|
{ PREDEC, TOKENTYPE_NONE, "PREDEC" }, |
391
|
|
|
|
|
|
{ PREINC, TOKENTYPE_NONE, "PREINC" }, |
392
|
|
|
|
|
|
{ PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" }, |
393
|
|
|
|
|
|
{ QWLIST, TOKENTYPE_OPVAL, "QWLIST" }, |
394
|
|
|
|
|
|
{ REFGEN, TOKENTYPE_NONE, "REFGEN" }, |
395
|
|
|
|
|
|
{ RELOP, TOKENTYPE_OPNUM, "RELOP" }, |
396
|
|
|
|
|
|
{ REQUIRE, TOKENTYPE_NONE, "REQUIRE" }, |
397
|
|
|
|
|
|
{ SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" }, |
398
|
|
|
|
|
|
{ SUB, TOKENTYPE_NONE, "SUB" }, |
399
|
|
|
|
|
|
{ THING, TOKENTYPE_OPVAL, "THING" }, |
400
|
|
|
|
|
|
{ UMINUS, TOKENTYPE_NONE, "UMINUS" }, |
401
|
|
|
|
|
|
{ UNIOP, TOKENTYPE_OPNUM, "UNIOP" }, |
402
|
|
|
|
|
|
{ UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" }, |
403
|
|
|
|
|
|
{ UNLESS, TOKENTYPE_IVAL, "UNLESS" }, |
404
|
|
|
|
|
|
{ UNTIL, TOKENTYPE_IVAL, "UNTIL" }, |
405
|
|
|
|
|
|
{ USE, TOKENTYPE_IVAL, "USE" }, |
406
|
|
|
|
|
|
{ WHEN, TOKENTYPE_IVAL, "WHEN" }, |
407
|
|
|
|
|
|
{ WHILE, TOKENTYPE_IVAL, "WHILE" }, |
408
|
|
|
|
|
|
{ WORD, TOKENTYPE_OPVAL, "WORD" }, |
409
|
|
|
|
|
|
{ YADAYADA, TOKENTYPE_IVAL, "YADAYADA" }, |
410
|
|
|
|
|
|
{ 0, TOKENTYPE_NONE, NULL } |
411
|
|
|
|
|
|
}; |
412
|
|
|
|
|
|
|
413
|
|
|
|
|
|
/* dump the returned token in rv, plus any optional arg in pl_yylval */ |
414
|
|
|
|
|
|
|
415
|
|
|
|
|
|
STATIC int |
416
|
|
|
|
|
|
S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp) |
417
|
|
|
|
|
|
{ |
418
|
|
|
|
|
|
dVAR; |
419
|
|
|
|
|
|
|
420
|
|
|
|
|
|
PERL_ARGS_ASSERT_TOKEREPORT; |
421
|
|
|
|
|
|
|
422
|
|
|
|
|
|
if (DEBUG_T_TEST) { |
423
|
|
|
|
|
|
const char *name = NULL; |
424
|
|
|
|
|
|
enum token_type type = TOKENTYPE_NONE; |
425
|
|
|
|
|
|
const struct debug_tokens *p; |
426
|
|
|
|
|
|
SV* const report = newSVpvs("<== "); |
427
|
|
|
|
|
|
|
428
|
|
|
|
|
|
for (p = debug_tokens; p->token; p++) { |
429
|
|
|
|
|
|
if (p->token == (int)rv) { |
430
|
|
|
|
|
|
name = p->name; |
431
|
|
|
|
|
|
type = p->type; |
432
|
|
|
|
|
|
break; |
433
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
if (name) |
436
|
|
|
|
|
|
Perl_sv_catpv(aTHX_ report, name); |
437
|
|
|
|
|
|
else if ((char)rv > ' ' && (char)rv <= '~') |
438
|
|
|
|
|
|
{ |
439
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv); |
440
|
|
|
|
|
|
if ((char)rv == 'p') |
441
|
|
|
|
|
|
sv_catpvs(report, " (pending identifier)"); |
442
|
|
|
|
|
|
} |
443
|
|
|
|
|
|
else if (!rv) |
444
|
|
|
|
|
|
sv_catpvs(report, "EOF"); |
445
|
|
|
|
|
|
else |
446
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv); |
447
|
|
|
|
|
|
switch (type) { |
448
|
|
|
|
|
|
case TOKENTYPE_NONE: |
449
|
|
|
|
|
|
break; |
450
|
|
|
|
|
|
case TOKENTYPE_IVAL: |
451
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival); |
452
|
|
|
|
|
|
break; |
453
|
|
|
|
|
|
case TOKENTYPE_OPNUM: |
454
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)", |
455
|
|
|
|
|
|
PL_op_name[lvalp->ival]); |
456
|
|
|
|
|
|
break; |
457
|
|
|
|
|
|
case TOKENTYPE_PVAL: |
458
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval); |
459
|
|
|
|
|
|
break; |
460
|
|
|
|
|
|
case TOKENTYPE_OPVAL: |
461
|
|
|
|
|
|
if (lvalp->opval) { |
462
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)", |
463
|
|
|
|
|
|
PL_op_name[lvalp->opval->op_type]); |
464
|
|
|
|
|
|
if (lvalp->opval->op_type == OP_CONST) { |
465
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ report, " %s", |
466
|
|
|
|
|
|
SvPEEK(cSVOPx_sv(lvalp->opval))); |
467
|
|
|
|
|
|
} |
468
|
|
|
|
|
|
|
469
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
else |
471
|
|
|
|
|
|
sv_catpvs(report, "(opval=null)"); |
472
|
|
|
|
|
|
break; |
473
|
|
|
|
|
|
} |
474
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report)); |
475
|
|
|
|
|
|
}; |
476
|
|
|
|
|
|
return (int)rv; |
477
|
|
|
|
|
|
} |
478
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
480
|
|
|
|
|
|
/* print the buffer with suitable escapes */ |
481
|
|
|
|
|
|
|
482
|
|
|
|
|
|
STATIC void |
483
|
|
|
|
|
|
S_printbuf(pTHX_ const char *const fmt, const char *const s) |
484
|
|
|
|
|
|
{ |
485
|
|
|
|
|
|
SV* const tmp = newSVpvs(""); |
486
|
|
|
|
|
|
|
487
|
|
|
|
|
|
PERL_ARGS_ASSERT_PRINTBUF; |
488
|
|
|
|
|
|
|
489
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60)); |
490
|
|
|
|
|
|
SvREFCNT_dec(tmp); |
491
|
|
|
|
|
|
} |
492
|
|
|
|
|
|
|
493
|
|
|
|
|
|
#endif |
494
|
|
|
|
|
|
|
495
|
|
|
|
|
|
static int |
496
|
12
|
|
|
|
|
S_deprecate_commaless_var_list(pTHX) { |
497
|
12
|
|
|
|
|
PL_expect = XTERM; |
498
|
12
|
|
|
|
|
deprecate("comma-less variable list"); |
499
|
12
|
|
|
|
|
return REPORT(','); /* grandfather non-comma-format format */ |
500
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
502
|
|
|
|
|
|
/* |
503
|
|
|
|
|
|
* S_ao |
504
|
|
|
|
|
|
* |
505
|
|
|
|
|
|
* This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR |
506
|
|
|
|
|
|
* into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN |
507
|
|
|
|
|
|
*/ |
508
|
|
|
|
|
|
|
509
|
|
|
|
|
|
STATIC int |
510
|
25594627
|
|
|
|
|
S_ao(pTHX_ int toketype) |
511
|
|
|
|
|
|
{ |
512
|
|
|
|
|
|
dVAR; |
513
|
25594627
|
100
|
|
|
|
if (*PL_bufptr == '=') { |
514
|
2374478
|
|
|
|
|
PL_bufptr++; |
515
|
2374478
|
100
|
|
|
|
if (toketype == ANDAND) |
516
|
54
|
|
|
|
|
pl_yylval.ival = OP_ANDASSIGN; |
517
|
2374424
|
100
|
|
|
|
else if (toketype == OROR) |
518
|
533831
|
|
|
|
|
pl_yylval.ival = OP_ORASSIGN; |
519
|
1840593
|
100
|
|
|
|
else if (toketype == DORDOR) |
520
|
1010
|
|
|
|
|
pl_yylval.ival = OP_DORASSIGN; |
521
|
|
|
|
|
|
toketype = ASSIGNOP; |
522
|
|
|
|
|
|
} |
523
|
25594627
|
|
|
|
|
return toketype; |
524
|
|
|
|
|
|
} |
525
|
|
|
|
|
|
|
526
|
|
|
|
|
|
/* |
527
|
|
|
|
|
|
* S_no_op |
528
|
|
|
|
|
|
* When Perl expects an operator and finds something else, no_op |
529
|
|
|
|
|
|
* prints the warning. It always prints " found where |
530
|
|
|
|
|
|
* operator expected. It prints "Missing semicolon on previous line?" |
531
|
|
|
|
|
|
* if the surprise occurs at the start of the line. "do you need to |
532
|
|
|
|
|
|
* predeclare ..." is printed out for code like "sub bar; foo bar $x" |
533
|
|
|
|
|
|
* where the compiler doesn't know if foo is a method call or a function. |
534
|
|
|
|
|
|
* It prints "Missing operator before end of line" if there's nothing |
535
|
|
|
|
|
|
* after the missing operator, or "... before <...>" if there is something |
536
|
|
|
|
|
|
* after the missing operator. |
537
|
|
|
|
|
|
*/ |
538
|
|
|
|
|
|
|
539
|
|
|
|
|
|
STATIC void |
540
|
108
|
|
|
|
|
S_no_op(pTHX_ const char *const what, char *s) |
541
|
|
|
|
|
|
{ |
542
|
|
|
|
|
|
dVAR; |
543
|
108
|
|
|
|
|
char * const oldbp = PL_bufptr; |
544
|
108
|
|
|
|
|
const bool is_first = (PL_oldbufptr == PL_linestart); |
545
|
|
|
|
|
|
|
546
|
|
|
|
|
|
PERL_ARGS_ASSERT_NO_OP; |
547
|
|
|
|
|
|
|
548
|
108
|
50
|
|
|
|
if (!s) |
549
|
|
|
|
|
|
s = oldbp; |
550
|
|
|
|
|
|
else |
551
|
108
|
|
|
|
|
PL_bufptr = s; |
552
|
108
|
50
|
|
|
|
yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
553
|
108
|
100
|
|
|
|
if (ckWARN_d(WARN_SYNTAX)) { |
554
|
62
|
50
|
|
|
|
if (is_first) |
555
|
0
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), |
556
|
|
|
|
|
|
"\t(Missing semicolon on previous line?)\n"); |
557
|
62
|
50
|
|
|
|
else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
558
|
|
|
|
|
|
const char *t; |
559
|
297
|
50
|
|
|
|
for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if(t,UTF) || *t == ':'); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
560
|
240
|
50
|
|
|
|
t += UTF ? UTF8SKIP(t) : 1) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
561
|
|
|
|
|
|
NOOP; |
562
|
38
|
100
|
|
|
|
if (t < PL_bufptr && isSPACE(*t)) |
|
|
100
|
|
|
|
|
563
|
70
|
50
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), |
|
|
50
|
|
|
|
|
564
|
|
|
|
|
|
"\t(Do you need to predeclare %"UTF8f"?)\n", |
565
|
60
|
50
|
|
|
|
UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr)); |
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
566
|
|
|
|
|
|
} |
567
|
|
|
|
|
|
else { |
568
|
|
|
|
|
|
assert(s >= oldbp); |
569
|
84
|
50
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), |
|
|
50
|
|
|
|
|
570
|
|
|
|
|
|
"\t(Missing operator before %"UTF8f"?)\n", |
571
|
72
|
50
|
|
|
|
UTF8fARG(UTF, s - oldbp, oldbp)); |
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
572
|
|
|
|
|
|
} |
573
|
|
|
|
|
|
} |
574
|
108
|
|
|
|
|
PL_bufptr = oldbp; |
575
|
108
|
|
|
|
|
} |
576
|
|
|
|
|
|
|
577
|
|
|
|
|
|
/* |
578
|
|
|
|
|
|
* S_missingterm |
579
|
|
|
|
|
|
* Complain about missing quote/regexp/heredoc terminator. |
580
|
|
|
|
|
|
* If it's called with NULL then it cauterizes the line buffer. |
581
|
|
|
|
|
|
* If we're in a delimited string and the delimiter is a control |
582
|
|
|
|
|
|
* character, it's reformatted into a two-char sequence like ^C. |
583
|
|
|
|
|
|
* This is fatal. |
584
|
|
|
|
|
|
*/ |
585
|
|
|
|
|
|
|
586
|
|
|
|
|
|
STATIC void |
587
|
98
|
|
|
|
|
S_missingterm(pTHX_ char *s) |
588
|
|
|
|
|
|
{ |
589
|
|
|
|
|
|
dVAR; |
590
|
|
|
|
|
|
char tmpbuf[3]; |
591
|
|
|
|
|
|
char q; |
592
|
98
|
100
|
|
|
|
if (s) { |
593
|
86
|
|
|
|
|
char * const nl = strrchr(s,'\n'); |
594
|
86
|
50
|
|
|
|
if (nl) |
595
|
86
|
|
|
|
|
*nl = '\0'; |
596
|
|
|
|
|
|
} |
597
|
12
|
50
|
|
|
|
else if ((U8) PL_multi_close < 32) { |
598
|
0
|
|
|
|
|
*tmpbuf = '^'; |
599
|
0
|
0
|
|
|
|
tmpbuf[1] = (char)toCTRL(PL_multi_close); |
600
|
0
|
|
|
|
|
tmpbuf[2] = '\0'; |
601
|
|
|
|
|
|
s = tmpbuf; |
602
|
|
|
|
|
|
} |
603
|
|
|
|
|
|
else { |
604
|
12
|
|
|
|
|
*tmpbuf = (char)PL_multi_close; |
605
|
12
|
|
|
|
|
tmpbuf[1] = '\0'; |
606
|
|
|
|
|
|
s = tmpbuf; |
607
|
|
|
|
|
|
} |
608
|
98
|
50
|
|
|
|
q = strchr(s,'"') ? '\'' : '"'; |
609
|
98
|
|
|
|
|
Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q); |
610
|
|
|
|
|
|
} |
611
|
|
|
|
|
|
|
612
|
|
|
|
|
|
#include "feature.h" |
613
|
|
|
|
|
|
|
614
|
|
|
|
|
|
/* |
615
|
|
|
|
|
|
* Check whether the named feature is enabled. |
616
|
|
|
|
|
|
*/ |
617
|
|
|
|
|
|
bool |
618
|
3312
|
|
|
|
|
Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen) |
619
|
|
|
|
|
|
{ |
620
|
|
|
|
|
|
dVAR; |
621
|
3312
|
|
|
|
|
char he_name[8 + MAX_FEATURE_LEN] = "feature_"; |
622
|
|
|
|
|
|
|
623
|
|
|
|
|
|
PERL_ARGS_ASSERT_FEATURE_IS_ENABLED; |
624
|
|
|
|
|
|
|
625
|
|
|
|
|
|
assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM); |
626
|
|
|
|
|
|
|
627
|
3312
|
50
|
|
|
|
if (namelen > MAX_FEATURE_LEN) |
628
|
|
|
|
|
|
return FALSE; |
629
|
3312
|
|
|
|
|
memcpy(&he_name[8], name, namelen); |
630
|
|
|
|
|
|
|
631
|
3312
|
|
|
|
|
return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0, |
632
|
|
|
|
|
|
REFCOUNTED_HE_EXISTS)); |
633
|
|
|
|
|
|
} |
634
|
|
|
|
|
|
|
635
|
|
|
|
|
|
/* |
636
|
|
|
|
|
|
* experimental text filters for win32 carriage-returns, utf16-to-utf8 and |
637
|
|
|
|
|
|
* utf16-to-utf8-reversed. |
638
|
|
|
|
|
|
*/ |
639
|
|
|
|
|
|
|
640
|
|
|
|
|
|
#ifdef PERL_CR_FILTER |
641
|
|
|
|
|
|
static void |
642
|
|
|
|
|
|
strip_return(SV *sv) |
643
|
|
|
|
|
|
{ |
644
|
|
|
|
|
|
const char *s = SvPVX_const(sv); |
645
|
|
|
|
|
|
const char * const e = s + SvCUR(sv); |
646
|
|
|
|
|
|
|
647
|
|
|
|
|
|
PERL_ARGS_ASSERT_STRIP_RETURN; |
648
|
|
|
|
|
|
|
649
|
|
|
|
|
|
/* outer loop optimized to do nothing if there are no CR-LFs */ |
650
|
|
|
|
|
|
while (s < e) { |
651
|
|
|
|
|
|
if (*s++ == '\r' && *s == '\n') { |
652
|
|
|
|
|
|
/* hit a CR-LF, need to copy the rest */ |
653
|
|
|
|
|
|
char *d = s - 1; |
654
|
|
|
|
|
|
*d++ = *s++; |
655
|
|
|
|
|
|
while (s < e) { |
656
|
|
|
|
|
|
if (*s == '\r' && s[1] == '\n') |
657
|
|
|
|
|
|
s++; |
658
|
|
|
|
|
|
*d++ = *s++; |
659
|
|
|
|
|
|
} |
660
|
|
|
|
|
|
SvCUR(sv) -= s - d; |
661
|
|
|
|
|
|
return; |
662
|
|
|
|
|
|
} |
663
|
|
|
|
|
|
} |
664
|
|
|
|
|
|
} |
665
|
|
|
|
|
|
|
666
|
|
|
|
|
|
STATIC I32 |
667
|
|
|
|
|
|
S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) |
668
|
|
|
|
|
|
{ |
669
|
|
|
|
|
|
const I32 count = FILTER_READ(idx+1, sv, maxlen); |
670
|
|
|
|
|
|
if (count > 0 && !maxlen) |
671
|
|
|
|
|
|
strip_return(sv); |
672
|
|
|
|
|
|
return count; |
673
|
|
|
|
|
|
} |
674
|
|
|
|
|
|
#endif |
675
|
|
|
|
|
|
|
676
|
|
|
|
|
|
/* |
677
|
|
|
|
|
|
=for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags |
678
|
|
|
|
|
|
|
679
|
|
|
|
|
|
Creates and initialises a new lexer/parser state object, supplying |
680
|
|
|
|
|
|
a context in which to lex and parse from a new source of Perl code. |
681
|
|
|
|
|
|
A pointer to the new state object is placed in L. An entry |
682
|
|
|
|
|
|
is made on the save stack so that upon unwinding the new state object |
683
|
|
|
|
|
|
will be destroyed and the former value of L will be restored. |
684
|
|
|
|
|
|
Nothing else need be done to clean up the parsing context. |
685
|
|
|
|
|
|
|
686
|
|
|
|
|
|
The code to be parsed comes from I and I. I, if |
687
|
|
|
|
|
|
non-null, provides a string (in SV form) containing code to be parsed. |
688
|
|
|
|
|
|
A copy of the string is made, so subsequent modification of I |
689
|
|
|
|
|
|
does not affect parsing. I, if non-null, provides an input stream |
690
|
|
|
|
|
|
from which code will be read to be parsed. If both are non-null, the |
691
|
|
|
|
|
|
code in I comes first and must consist of complete lines of input, |
692
|
|
|
|
|
|
and I supplies the remainder of the source. |
693
|
|
|
|
|
|
|
694
|
|
|
|
|
|
The I parameter is reserved for future use. Currently it is only |
695
|
|
|
|
|
|
used by perl internally, so extensions should always pass zero. |
696
|
|
|
|
|
|
|
697
|
|
|
|
|
|
=cut |
698
|
|
|
|
|
|
*/ |
699
|
|
|
|
|
|
|
700
|
|
|
|
|
|
/* LEX_START_SAME_FILTER indicates that this is not a new file, so it |
701
|
|
|
|
|
|
can share filters with the current parser. |
702
|
|
|
|
|
|
LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the |
703
|
|
|
|
|
|
caller, hence isn't owned by the parser, so shouldn't be closed on parser |
704
|
|
|
|
|
|
destruction. This is used to handle the case of defaulting to reading the |
705
|
|
|
|
|
|
script from the standard input because no filename was given on the command |
706
|
|
|
|
|
|
line (without getting confused by situation where STDIN has been closed, so |
707
|
|
|
|
|
|
the script handle is opened on fd 0) */ |
708
|
|
|
|
|
|
|
709
|
|
|
|
|
|
void |
710
|
4388977
|
|
|
|
|
Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags) |
711
|
|
|
|
|
|
{ |
712
|
|
|
|
|
|
dVAR; |
713
|
|
|
|
|
|
const char *s = NULL; |
714
|
|
|
|
|
|
yy_parser *parser, *oparser; |
715
|
4388977
|
100
|
|
|
|
if (flags && flags & ~LEX_START_FLAGS) |
|
|
50
|
|
|
|
|
716
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start"); |
717
|
|
|
|
|
|
|
718
|
|
|
|
|
|
/* create and initialise a parser */ |
719
|
|
|
|
|
|
|
720
|
4388977
|
|
|
|
|
Newxz(parser, 1, yy_parser); |
721
|
4388977
|
|
|
|
|
parser->old_parser = oparser = PL_parser; |
722
|
4388977
|
|
|
|
|
PL_parser = parser; |
723
|
|
|
|
|
|
|
724
|
4388977
|
|
|
|
|
parser->stack = NULL; |
725
|
4388977
|
|
|
|
|
parser->ps = NULL; |
726
|
4388977
|
|
|
|
|
parser->stack_size = 0; |
727
|
|
|
|
|
|
|
728
|
|
|
|
|
|
/* on scope exit, free this parser and restore any outer one */ |
729
|
4388977
|
|
|
|
|
SAVEPARSER(parser); |
730
|
4388977
|
|
|
|
|
parser->saved_curcop = PL_curcop; |
731
|
|
|
|
|
|
|
732
|
|
|
|
|
|
/* initialise lexer state */ |
733
|
|
|
|
|
|
|
734
|
|
|
|
|
|
#ifdef PERL_MAD |
735
|
|
|
|
|
|
parser->curforce = -1; |
736
|
|
|
|
|
|
#else |
737
|
4388977
|
|
|
|
|
parser->nexttoke = 0; |
738
|
|
|
|
|
|
#endif |
739
|
4388977
|
100
|
|
|
|
parser->error_count = oparser ? oparser->error_count : 0; |
740
|
4388977
|
|
|
|
|
parser->copline = NOLINE; |
741
|
4388977
|
|
|
|
|
parser->lex_state = LEX_NORMAL; |
742
|
4388977
|
|
|
|
|
parser->expect = XSTATE; |
743
|
4388977
|
|
|
|
|
parser->rsfp = rsfp; |
744
|
4388977
|
|
|
|
|
parser->rsfp_filters = |
745
|
4388977
|
|
|
|
|
!(flags & LEX_START_SAME_FILTER) || !oparser |
746
|
|
|
|
|
|
? NULL |
747
|
4388977
|
100
|
|
|
|
: MUTABLE_AV(SvREFCNT_inc( |
|
|
100
|
|
|
|
|
748
|
|
|
|
|
|
oparser->rsfp_filters |
749
|
|
|
|
|
|
? oparser->rsfp_filters |
750
|
|
|
|
|
|
: (oparser->rsfp_filters = newAV()) |
751
|
|
|
|
|
|
)); |
752
|
|
|
|
|
|
|
753
|
4388977
|
|
|
|
|
Newx(parser->lex_brackstack, 120, char); |
754
|
4388977
|
|
|
|
|
Newx(parser->lex_casestack, 12, char); |
755
|
4388977
|
|
|
|
|
*parser->lex_casestack = '\0'; |
756
|
4388977
|
|
|
|
|
Newxz(parser->lex_shared, 1, LEXSHARED); |
757
|
|
|
|
|
|
|
758
|
4388977
|
100
|
|
|
|
if (line) { |
759
|
|
|
|
|
|
STRLEN len; |
760
|
3759876
|
100
|
|
|
|
s = SvPV_const(line, len); |
761
|
7519752
|
|
|
|
|
parser->linestr = flags & LEX_START_COPIED |
762
|
318
|
|
|
|
|
? SvREFCNT_inc_simple_NN(line) |
763
|
5628496
|
100
|
|
|
|
: newSVpvn_flags(s, len, SvUTF8(line)); |
764
|
3759876
|
100
|
|
|
|
sv_catpvn(parser->linestr, "\n;", rsfp ? 1 : 2); |
765
|
|
|
|
|
|
} else { |
766
|
629101
|
100
|
|
|
|
parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2); |
767
|
|
|
|
|
|
} |
768
|
4388977
|
|
|
|
|
parser->oldoldbufptr = |
769
|
4388977
|
|
|
|
|
parser->oldbufptr = |
770
|
4388977
|
|
|
|
|
parser->bufptr = |
771
|
4388977
|
|
|
|
|
parser->linestart = SvPVX(parser->linestr); |
772
|
4388977
|
|
|
|
|
parser->bufend = parser->bufptr + SvCUR(parser->linestr); |
773
|
4388977
|
|
|
|
|
parser->last_lop = parser->last_uni = NULL; |
774
|
4388977
|
|
|
|
|
parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES |
775
|
|
|
|
|
|
|LEX_DONT_CLOSE_RSFP); |
776
|
|
|
|
|
|
|
777
|
4388977
|
|
|
|
|
parser->in_pod = parser->filtered = 0; |
778
|
4388977
|
|
|
|
|
} |
779
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
781
|
|
|
|
|
|
/* delete a parser object */ |
782
|
|
|
|
|
|
|
783
|
|
|
|
|
|
void |
784
|
4388977
|
|
|
|
|
Perl_parser_free(pTHX_ const yy_parser *parser) |
785
|
|
|
|
|
|
{ |
786
|
|
|
|
|
|
PERL_ARGS_ASSERT_PARSER_FREE; |
787
|
|
|
|
|
|
|
788
|
4388977
|
|
|
|
|
PL_curcop = parser->saved_curcop; |
789
|
4388977
|
|
|
|
|
SvREFCNT_dec(parser->linestr); |
790
|
|
|
|
|
|
|
791
|
4388977
|
100
|
|
|
|
if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP) |
792
|
44
|
|
|
|
|
PerlIO_clearerr(parser->rsfp); |
793
|
4389224
|
100
|
|
|
|
else if (parser->rsfp && (!parser->old_parser || |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
794
|
582
|
|
|
|
|
(parser->old_parser && parser->rsfp != parser->old_parser->rsfp))) |
795
|
1454
|
|
|
|
|
PerlIO_close(parser->rsfp); |
796
|
4388977
|
|
|
|
|
SvREFCNT_dec(parser->rsfp_filters); |
797
|
4388977
|
|
|
|
|
SvREFCNT_dec(parser->lex_stuff); |
798
|
4388977
|
|
|
|
|
SvREFCNT_dec(parser->sublex_info.repl); |
799
|
|
|
|
|
|
|
800
|
4388977
|
|
|
|
|
Safefree(parser->lex_brackstack); |
801
|
4388977
|
|
|
|
|
Safefree(parser->lex_casestack); |
802
|
4388977
|
|
|
|
|
Safefree(parser->lex_shared); |
803
|
4388977
|
|
|
|
|
PL_parser = parser->old_parser; |
804
|
4388977
|
|
|
|
|
Safefree(parser); |
805
|
4388977
|
|
|
|
|
} |
806
|
|
|
|
|
|
|
807
|
|
|
|
|
|
void |
808
|
237692
|
|
|
|
|
Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab) |
809
|
|
|
|
|
|
{ |
810
|
|
|
|
|
|
#ifdef PERL_MAD |
811
|
|
|
|
|
|
I32 nexttoke = parser->lasttoke; |
812
|
|
|
|
|
|
#else |
813
|
237692
|
|
|
|
|
I32 nexttoke = parser->nexttoke; |
814
|
|
|
|
|
|
#endif |
815
|
|
|
|
|
|
PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS; |
816
|
352762
|
100
|
|
|
|
while (nexttoke--) { |
817
|
|
|
|
|
|
#ifdef PERL_MAD |
818
|
|
|
|
|
|
if (S_is_opval_token(parser->nexttoke[nexttoke].next_type |
819
|
|
|
|
|
|
& 0xffff) |
820
|
|
|
|
|
|
&& parser->nexttoke[nexttoke].next_val.opval |
821
|
|
|
|
|
|
&& parser->nexttoke[nexttoke].next_val.opval->op_slabbed |
822
|
|
|
|
|
|
&& OpSLAB(parser->nexttoke[nexttoke].next_val.opval) == slab) { |
823
|
|
|
|
|
|
op_free(parser->nexttoke[nexttoke].next_val.opval); |
824
|
|
|
|
|
|
parser->nexttoke[nexttoke].next_val.opval = NULL; |
825
|
|
|
|
|
|
} |
826
|
|
|
|
|
|
#else |
827
|
6
|
50
|
|
|
|
if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff) |
828
|
4
|
50
|
|
|
|
&& parser->nextval[nexttoke].opval |
829
|
4
|
50
|
|
|
|
&& parser->nextval[nexttoke].opval->op_slabbed |
830
|
4
|
50
|
|
|
|
&& OpSLAB(parser->nextval[nexttoke].opval) == slab) { |
831
|
4
|
|
|
|
|
op_free(parser->nextval[nexttoke].opval); |
832
|
4
|
|
|
|
|
parser->nextval[nexttoke].opval = NULL; |
833
|
|
|
|
|
|
} |
834
|
|
|
|
|
|
#endif |
835
|
|
|
|
|
|
} |
836
|
237692
|
|
|
|
|
} |
837
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
839
|
|
|
|
|
|
/* |
840
|
|
|
|
|
|
=for apidoc AmxU|SV *|PL_parser-Elinestr |
841
|
|
|
|
|
|
|
842
|
|
|
|
|
|
Buffer scalar containing the chunk currently under consideration of the |
843
|
|
|
|
|
|
text currently being lexed. This is always a plain string scalar (for |
844
|
|
|
|
|
|
which C is true). It is not intended to be used as a scalar by |
845
|
|
|
|
|
|
normal scalar means; instead refer to the buffer directly by the pointer |
846
|
|
|
|
|
|
variables described below. |
847
|
|
|
|
|
|
|
848
|
|
|
|
|
|
The lexer maintains various C pointers to things in the |
849
|
|
|
|
|
|
Clinestr> buffer. If Clinestr> is ever |
850
|
|
|
|
|
|
reallocated, all of these pointers must be updated. Don't attempt to |
851
|
|
|
|
|
|
do this manually, but rather use L if you need to |
852
|
|
|
|
|
|
reallocate the buffer. |
853
|
|
|
|
|
|
|
854
|
|
|
|
|
|
The content of the text chunk in the buffer is commonly exactly one |
855
|
|
|
|
|
|
complete line of input, up to and including a newline terminator, |
856
|
|
|
|
|
|
but there are situations where it is otherwise. The octets of the |
857
|
|
|
|
|
|
buffer may be intended to be interpreted as either UTF-8 or Latin-1. |
858
|
|
|
|
|
|
The function L tells you which. Do not use the C |
859
|
|
|
|
|
|
flag on this scalar, which may disagree with it. |
860
|
|
|
|
|
|
|
861
|
|
|
|
|
|
For direct examination of the buffer, the variable |
862
|
|
|
|
|
|
Lbufend> points to the end of the buffer. The current |
863
|
|
|
|
|
|
lexing position is pointed to by Lbufptr>. Direct use |
864
|
|
|
|
|
|
of these pointers is usually preferable to examination of the scalar |
865
|
|
|
|
|
|
through normal scalar means. |
866
|
|
|
|
|
|
|
867
|
|
|
|
|
|
=for apidoc AmxU|char *|PL_parser-Ebufend |
868
|
|
|
|
|
|
|
869
|
|
|
|
|
|
Direct pointer to the end of the chunk of text currently being lexed, the |
870
|
|
|
|
|
|
end of the lexer buffer. This is equal to Clinestr) |
871
|
|
|
|
|
|
+ SvCUR(PL_parser-Elinestr)>. A NUL character (zero octet) is |
872
|
|
|
|
|
|
always located at the end of the buffer, and does not count as part of |
873
|
|
|
|
|
|
the buffer's contents. |
874
|
|
|
|
|
|
|
875
|
|
|
|
|
|
=for apidoc AmxU|char *|PL_parser-Ebufptr |
876
|
|
|
|
|
|
|
877
|
|
|
|
|
|
Points to the current position of lexing inside the lexer buffer. |
878
|
|
|
|
|
|
Characters around this point may be freely examined, within |
879
|
|
|
|
|
|
the range delimited by Clinestr>)> and |
880
|
|
|
|
|
|
Lbufend>. The octets of the buffer may be intended to be |
881
|
|
|
|
|
|
interpreted as either UTF-8 or Latin-1, as indicated by L. |
882
|
|
|
|
|
|
|
883
|
|
|
|
|
|
Lexing code (whether in the Perl core or not) moves this pointer past |
884
|
|
|
|
|
|
the characters that it consumes. It is also expected to perform some |
885
|
|
|
|
|
|
bookkeeping whenever a newline character is consumed. This movement |
886
|
|
|
|
|
|
can be more conveniently performed by the function L, |
887
|
|
|
|
|
|
which handles newlines appropriately. |
888
|
|
|
|
|
|
|
889
|
|
|
|
|
|
Interpretation of the buffer's octets can be abstracted out by |
890
|
|
|
|
|
|
using the slightly higher-level functions L and |
891
|
|
|
|
|
|
L. |
892
|
|
|
|
|
|
|
893
|
|
|
|
|
|
=for apidoc AmxU|char *|PL_parser-Elinestart |
894
|
|
|
|
|
|
|
895
|
|
|
|
|
|
Points to the start of the current line inside the lexer buffer. |
896
|
|
|
|
|
|
This is useful for indicating at which column an error occurred, and |
897
|
|
|
|
|
|
not much else. This must be updated by any lexing code that consumes |
898
|
|
|
|
|
|
a newline; the function L handles this detail. |
899
|
|
|
|
|
|
|
900
|
|
|
|
|
|
=cut |
901
|
|
|
|
|
|
*/ |
902
|
|
|
|
|
|
|
903
|
|
|
|
|
|
/* |
904
|
|
|
|
|
|
=for apidoc Amx|bool|lex_bufutf8 |
905
|
|
|
|
|
|
|
906
|
|
|
|
|
|
Indicates whether the octets in the lexer buffer |
907
|
|
|
|
|
|
(Llinestr>) should be interpreted as the UTF-8 encoding |
908
|
|
|
|
|
|
of Unicode characters. If not, they should be interpreted as Latin-1 |
909
|
|
|
|
|
|
characters. This is analogous to the C flag for scalars. |
910
|
|
|
|
|
|
|
911
|
|
|
|
|
|
In UTF-8 mode, it is not guaranteed that the lexer buffer actually |
912
|
|
|
|
|
|
contains valid UTF-8. Lexing code must be robust in the face of invalid |
913
|
|
|
|
|
|
encoding. |
914
|
|
|
|
|
|
|
915
|
|
|
|
|
|
The actual C flag of the Llinestr> scalar |
916
|
|
|
|
|
|
is significant, but not the whole story regarding the input character |
917
|
|
|
|
|
|
encoding. Normally, when a file is being read, the scalar contains octets |
918
|
|
|
|
|
|
and its C flag is off, but the octets should be interpreted as |
919
|
|
|
|
|
|
UTF-8 if the C |
920
|
|
|
|
|
|
however, the scalar may have the C flag on, and in this case its |
921
|
|
|
|
|
|
octets should be interpreted as UTF-8 unless the C |
922
|
|
|
|
|
|
is in effect. This logic may change in the future; use this function |
923
|
|
|
|
|
|
instead of implementing the logic yourself. |
924
|
|
|
|
|
|
|
925
|
|
|
|
|
|
=cut |
926
|
|
|
|
|
|
*/ |
927
|
|
|
|
|
|
|
928
|
|
|
|
|
|
bool |
929
|
0
|
|
|
|
|
Perl_lex_bufutf8(pTHX) |
930
|
|
|
|
|
|
{ |
931
|
0
|
0
|
|
|
|
return UTF; |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
932
|
|
|
|
|
|
} |
933
|
|
|
|
|
|
|
934
|
|
|
|
|
|
/* |
935
|
|
|
|
|
|
=for apidoc Amx|char *|lex_grow_linestr|STRLEN len |
936
|
|
|
|
|
|
|
937
|
|
|
|
|
|
Reallocates the lexer buffer (Llinestr>) to accommodate |
938
|
|
|
|
|
|
at least I octets (including terminating NUL). Returns a |
939
|
|
|
|
|
|
pointer to the reallocated buffer. This is necessary before making |
940
|
|
|
|
|
|
any direct modification of the buffer that would increase its length. |
941
|
|
|
|
|
|
L provides a more convenient way to insert text into |
942
|
|
|
|
|
|
the buffer. |
943
|
|
|
|
|
|
|
944
|
|
|
|
|
|
Do not use C or C directly on Clinestr>; |
945
|
|
|
|
|
|
this function updates all of the lexer's variables that point directly |
946
|
|
|
|
|
|
into the buffer. |
947
|
|
|
|
|
|
|
948
|
|
|
|
|
|
=cut |
949
|
|
|
|
|
|
*/ |
950
|
|
|
|
|
|
|
951
|
|
|
|
|
|
char * |
952
|
76
|
|
|
|
|
Perl_lex_grow_linestr(pTHX_ STRLEN len) |
953
|
|
|
|
|
|
{ |
954
|
|
|
|
|
|
SV *linestr; |
955
|
|
|
|
|
|
char *buf; |
956
|
|
|
|
|
|
STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos; |
957
|
|
|
|
|
|
STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos; |
958
|
76
|
|
|
|
|
linestr = PL_parser->linestr; |
959
|
76
|
|
|
|
|
buf = SvPVX(linestr); |
960
|
76
|
100
|
|
|
|
if (len <= SvLEN(linestr)) |
961
|
|
|
|
|
|
return buf; |
962
|
72
|
|
|
|
|
bufend_pos = PL_parser->bufend - buf; |
963
|
72
|
|
|
|
|
bufptr_pos = PL_parser->bufptr - buf; |
964
|
72
|
|
|
|
|
oldbufptr_pos = PL_parser->oldbufptr - buf; |
965
|
72
|
|
|
|
|
oldoldbufptr_pos = PL_parser->oldoldbufptr - buf; |
966
|
72
|
|
|
|
|
linestart_pos = PL_parser->linestart - buf; |
967
|
72
|
50
|
|
|
|
last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0; |
968
|
72
|
50
|
|
|
|
last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0; |
969
|
72
|
50
|
|
|
|
re_eval_start_pos = PL_parser->lex_shared->re_eval_start ? |
970
|
0
|
|
|
|
|
PL_parser->lex_shared->re_eval_start - buf : 0; |
971
|
|
|
|
|
|
|
972
|
72
|
|
|
|
|
buf = sv_grow(linestr, len); |
973
|
|
|
|
|
|
|
974
|
72
|
|
|
|
|
PL_parser->bufend = buf + bufend_pos; |
975
|
72
|
|
|
|
|
PL_parser->bufptr = buf + bufptr_pos; |
976
|
72
|
|
|
|
|
PL_parser->oldbufptr = buf + oldbufptr_pos; |
977
|
72
|
|
|
|
|
PL_parser->oldoldbufptr = buf + oldoldbufptr_pos; |
978
|
72
|
|
|
|
|
PL_parser->linestart = buf + linestart_pos; |
979
|
72
|
50
|
|
|
|
if (PL_parser->last_uni) |
980
|
0
|
|
|
|
|
PL_parser->last_uni = buf + last_uni_pos; |
981
|
72
|
50
|
|
|
|
if (PL_parser->last_lop) |
982
|
0
|
|
|
|
|
PL_parser->last_lop = buf + last_lop_pos; |
983
|
72
|
50
|
|
|
|
if (PL_parser->lex_shared->re_eval_start) |
984
|
38
|
|
|
|
|
PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos; |
985
|
|
|
|
|
|
return buf; |
986
|
|
|
|
|
|
} |
987
|
|
|
|
|
|
|
988
|
|
|
|
|
|
/* |
989
|
|
|
|
|
|
=for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags |
990
|
|
|
|
|
|
|
991
|
|
|
|
|
|
Insert characters into the lexer buffer (Llinestr>), |
992
|
|
|
|
|
|
immediately after the current lexing point (Lbufptr>), |
993
|
|
|
|
|
|
reallocating the buffer if necessary. This means that lexing code that |
994
|
|
|
|
|
|
runs later will see the characters as if they had appeared in the input. |
995
|
|
|
|
|
|
It is not recommended to do this as part of normal parsing, and most |
996
|
|
|
|
|
|
uses of this facility run the risk of the inserted characters being |
997
|
|
|
|
|
|
interpreted in an unintended manner. |
998
|
|
|
|
|
|
|
999
|
|
|
|
|
|
The string to be inserted is represented by I octets starting |
1000
|
|
|
|
|
|
at I. These octets are interpreted as either UTF-8 or Latin-1, |
1001
|
|
|
|
|
|
according to whether the C flag is set in I. |
1002
|
|
|
|
|
|
The characters are recoded for the lexer buffer, according to how the |
1003
|
|
|
|
|
|
buffer is currently being interpreted (L). If a string |
1004
|
|
|
|
|
|
to be inserted is available as a Perl scalar, the L |
1005
|
|
|
|
|
|
function is more convenient. |
1006
|
|
|
|
|
|
|
1007
|
|
|
|
|
|
=cut |
1008
|
|
|
|
|
|
*/ |
1009
|
|
|
|
|
|
|
1010
|
|
|
|
|
|
void |
1011
|
4
|
|
|
|
|
Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags) |
1012
|
|
|
|
|
|
{ |
1013
|
|
|
|
|
|
dVAR; |
1014
|
|
|
|
|
|
char *bufptr; |
1015
|
|
|
|
|
|
PERL_ARGS_ASSERT_LEX_STUFF_PVN; |
1016
|
4
|
50
|
|
|
|
if (flags & ~(LEX_STUFF_UTF8)) |
1017
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn"); |
1018
|
4
|
50
|
|
|
|
if (UTF) { |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1019
|
0
|
0
|
|
|
|
if (flags & LEX_STUFF_UTF8) { |
1020
|
|
|
|
|
|
goto plain_copy; |
1021
|
|
|
|
|
|
} else { |
1022
|
|
|
|
|
|
STRLEN highhalf = 0; /* Count of variants */ |
1023
|
0
|
|
|
|
|
const char *p, *e = pv+len; |
1024
|
0
|
0
|
|
|
|
for (p = pv; p != e; p++) { |
1025
|
0
|
0
|
|
|
|
if (! UTF8_IS_INVARIANT(*p)) { |
1026
|
0
|
|
|
|
|
highhalf++; |
1027
|
|
|
|
|
|
} |
1028
|
|
|
|
|
|
} |
1029
|
0
|
0
|
|
|
|
if (!highhalf) |
1030
|
|
|
|
|
|
goto plain_copy; |
1031
|
0
|
|
|
|
|
lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf); |
1032
|
0
|
|
|
|
|
bufptr = PL_parser->bufptr; |
1033
|
0
|
|
|
|
|
Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char); |
1034
|
0
|
|
|
|
|
SvCUR_set(PL_parser->linestr, |
1035
|
|
|
|
|
|
SvCUR(PL_parser->linestr) + len+highhalf); |
1036
|
0
|
|
|
|
|
PL_parser->bufend += len+highhalf; |
1037
|
0
|
0
|
|
|
|
for (p = pv; p != e; p++) { |
1038
|
0
|
|
|
|
|
U8 c = (U8)*p; |
1039
|
0
|
0
|
|
|
|
if (! UTF8_IS_INVARIANT(c)) { |
1040
|
0
|
|
|
|
|
*bufptr++ = UTF8_TWO_BYTE_HI(c); |
1041
|
0
|
|
|
|
|
*bufptr++ = UTF8_TWO_BYTE_LO(c); |
1042
|
|
|
|
|
|
} else { |
1043
|
0
|
|
|
|
|
*bufptr++ = (char)c; |
1044
|
|
|
|
|
|
} |
1045
|
|
|
|
|
|
} |
1046
|
|
|
|
|
|
} |
1047
|
|
|
|
|
|
} else { |
1048
|
4
|
50
|
|
|
|
if (flags & LEX_STUFF_UTF8) { |
1049
|
|
|
|
|
|
STRLEN highhalf = 0; |
1050
|
0
|
|
|
|
|
const char *p, *e = pv+len; |
1051
|
0
|
0
|
|
|
|
for (p = pv; p != e; p++) { |
1052
|
0
|
|
|
|
|
U8 c = (U8)*p; |
1053
|
0
|
0
|
|
|
|
if (UTF8_IS_ABOVE_LATIN1(c)) { |
1054
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Lexing code attempted to stuff " |
1055
|
|
|
|
|
|
"non-Latin-1 character into Latin-1 input"); |
1056
|
0
|
0
|
|
|
|
} else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) { |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
1057
|
0
|
|
|
|
|
p++; |
1058
|
0
|
|
|
|
|
highhalf++; |
1059
|
0
|
0
|
|
|
|
} else if (! UTF8_IS_INVARIANT(c)) { |
1060
|
|
|
|
|
|
/* malformed UTF-8 */ |
1061
|
0
|
|
|
|
|
ENTER; |
1062
|
0
|
|
|
|
|
SAVESPTR(PL_warnhook); |
1063
|
0
|
|
|
|
|
PL_warnhook = PERL_WARNHOOK_FATAL; |
1064
|
0
|
|
|
|
|
utf8n_to_uvchr((U8*)p, e-p, NULL, 0); |
1065
|
0
|
|
|
|
|
LEAVE; |
1066
|
|
|
|
|
|
} |
1067
|
|
|
|
|
|
} |
1068
|
0
|
0
|
|
|
|
if (!highhalf) |
1069
|
|
|
|
|
|
goto plain_copy; |
1070
|
0
|
|
|
|
|
lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf); |
1071
|
0
|
|
|
|
|
bufptr = PL_parser->bufptr; |
1072
|
0
|
|
|
|
|
Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char); |
1073
|
0
|
|
|
|
|
SvCUR_set(PL_parser->linestr, |
1074
|
|
|
|
|
|
SvCUR(PL_parser->linestr) + len-highhalf); |
1075
|
0
|
|
|
|
|
PL_parser->bufend += len-highhalf; |
1076
|
|
|
|
|
|
p = pv; |
1077
|
0
|
0
|
|
|
|
while (p < e) { |
1078
|
0
|
0
|
|
|
|
if (UTF8_IS_INVARIANT(*p)) { |
1079
|
0
|
|
|
|
|
*bufptr++ = *p; |
1080
|
0
|
|
|
|
|
p++; |
1081
|
|
|
|
|
|
} |
1082
|
|
|
|
|
|
else { |
1083
|
|
|
|
|
|
assert(p < e -1 ); |
1084
|
0
|
|
|
|
|
*bufptr++ = TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1)); |
1085
|
0
|
|
|
|
|
p += 2; |
1086
|
|
|
|
|
|
} |
1087
|
|
|
|
|
|
} |
1088
|
|
|
|
|
|
} else { |
1089
|
|
|
|
|
|
plain_copy: |
1090
|
4
|
|
|
|
|
lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len); |
1091
|
4
|
|
|
|
|
bufptr = PL_parser->bufptr; |
1092
|
4
|
|
|
|
|
Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char); |
1093
|
4
|
|
|
|
|
SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len); |
1094
|
4
|
|
|
|
|
PL_parser->bufend += len; |
1095
|
4
|
|
|
|
|
Copy(pv, bufptr, len, char); |
1096
|
|
|
|
|
|
} |
1097
|
|
|
|
|
|
} |
1098
|
4
|
|
|
|
|
} |
1099
|
|
|
|
|
|
|
1100
|
|
|
|
|
|
/* |
1101
|
|
|
|
|
|
=for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags |
1102
|
|
|
|
|
|
|
1103
|
|
|
|
|
|
Insert characters into the lexer buffer (Llinestr>), |
1104
|
|
|
|
|
|
immediately after the current lexing point (Lbufptr>), |
1105
|
|
|
|
|
|
reallocating the buffer if necessary. This means that lexing code that |
1106
|
|
|
|
|
|
runs later will see the characters as if they had appeared in the input. |
1107
|
|
|
|
|
|
It is not recommended to do this as part of normal parsing, and most |
1108
|
|
|
|
|
|
uses of this facility run the risk of the inserted characters being |
1109
|
|
|
|
|
|
interpreted in an unintended manner. |
1110
|
|
|
|
|
|
|
1111
|
|
|
|
|
|
The string to be inserted is represented by octets starting at I |
1112
|
|
|
|
|
|
and continuing to the first nul. These octets are interpreted as either |
1113
|
|
|
|
|
|
UTF-8 or Latin-1, according to whether the C flag is set |
1114
|
|
|
|
|
|
in I. The characters are recoded for the lexer buffer, according |
1115
|
|
|
|
|
|
to how the buffer is currently being interpreted (L). |
1116
|
|
|
|
|
|
If it is not convenient to nul-terminate a string to be inserted, the |
1117
|
|
|
|
|
|
L function is more appropriate. |
1118
|
|
|
|
|
|
|
1119
|
|
|
|
|
|
=cut |
1120
|
|
|
|
|
|
*/ |
1121
|
|
|
|
|
|
|
1122
|
|
|
|
|
|
void |
1123
|
0
|
|
|
|
|
Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags) |
1124
|
|
|
|
|
|
{ |
1125
|
|
|
|
|
|
PERL_ARGS_ASSERT_LEX_STUFF_PV; |
1126
|
0
|
|
|
|
|
lex_stuff_pvn(pv, strlen(pv), flags); |
1127
|
0
|
|
|
|
|
} |
1128
|
|
|
|
|
|
|
1129
|
|
|
|
|
|
/* |
1130
|
|
|
|
|
|
=for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags |
1131
|
|
|
|
|
|
|
1132
|
|
|
|
|
|
Insert characters into the lexer buffer (Llinestr>), |
1133
|
|
|
|
|
|
immediately after the current lexing point (Lbufptr>), |
1134
|
|
|
|
|
|
reallocating the buffer if necessary. This means that lexing code that |
1135
|
|
|
|
|
|
runs later will see the characters as if they had appeared in the input. |
1136
|
|
|
|
|
|
It is not recommended to do this as part of normal parsing, and most |
1137
|
|
|
|
|
|
uses of this facility run the risk of the inserted characters being |
1138
|
|
|
|
|
|
interpreted in an unintended manner. |
1139
|
|
|
|
|
|
|
1140
|
|
|
|
|
|
The string to be inserted is the string value of I. The characters |
1141
|
|
|
|
|
|
are recoded for the lexer buffer, according to how the buffer is currently |
1142
|
|
|
|
|
|
being interpreted (L). If a string to be inserted is |
1143
|
|
|
|
|
|
not already a Perl scalar, the L function avoids the |
1144
|
|
|
|
|
|
need to construct a scalar. |
1145
|
|
|
|
|
|
|
1146
|
|
|
|
|
|
=cut |
1147
|
|
|
|
|
|
*/ |
1148
|
|
|
|
|
|
|
1149
|
|
|
|
|
|
void |
1150
|
0
|
|
|
|
|
Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags) |
1151
|
|
|
|
|
|
{ |
1152
|
|
|
|
|
|
char *pv; |
1153
|
|
|
|
|
|
STRLEN len; |
1154
|
|
|
|
|
|
PERL_ARGS_ASSERT_LEX_STUFF_SV; |
1155
|
0
|
0
|
|
|
|
if (flags) |
1156
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv"); |
1157
|
0
|
0
|
|
|
|
pv = SvPV(sv, len); |
1158
|
0
|
0
|
|
|
|
lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0)); |
1159
|
0
|
|
|
|
|
} |
1160
|
|
|
|
|
|
|
1161
|
|
|
|
|
|
/* |
1162
|
|
|
|
|
|
=for apidoc Amx|void|lex_unstuff|char *ptr |
1163
|
|
|
|
|
|
|
1164
|
|
|
|
|
|
Discards text about to be lexed, from Lbufptr> up to |
1165
|
|
|
|
|
|
I. Text following I will be moved, and the buffer shortened. |
1166
|
|
|
|
|
|
This hides the discarded text from any lexing code that runs later, |
1167
|
|
|
|
|
|
as if the text had never appeared. |
1168
|
|
|
|
|
|
|
1169
|
|
|
|
|
|
This is not the normal way to consume lexed text. For that, use |
1170
|
|
|
|
|
|
L. |
1171
|
|
|
|
|
|
|
1172
|
|
|
|
|
|
=cut |
1173
|
|
|
|
|
|
*/ |
1174
|
|
|
|
|
|
|
1175
|
|
|
|
|
|
void |
1176
|
0
|
|
|
|
|
Perl_lex_unstuff(pTHX_ char *ptr) |
1177
|
|
|
|
|
|
{ |
1178
|
|
|
|
|
|
char *buf, *bufend; |
1179
|
|
|
|
|
|
STRLEN unstuff_len; |
1180
|
|
|
|
|
|
PERL_ARGS_ASSERT_LEX_UNSTUFF; |
1181
|
0
|
|
|
|
|
buf = PL_parser->bufptr; |
1182
|
0
|
0
|
|
|
|
if (ptr < buf) |
1183
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff"); |
1184
|
0
|
0
|
|
|
|
if (ptr == buf) |
1185
|
0
|
|
|
|
|
return; |
1186
|
0
|
|
|
|
|
bufend = PL_parser->bufend; |
1187
|
0
|
0
|
|
|
|
if (ptr > bufend) |
1188
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff"); |
1189
|
0
|
|
|
|
|
unstuff_len = ptr - buf; |
1190
|
0
|
|
|
|
|
Move(ptr, buf, bufend+1-ptr, char); |
1191
|
0
|
|
|
|
|
SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len); |
1192
|
0
|
|
|
|
|
PL_parser->bufend = bufend - unstuff_len; |
1193
|
|
|
|
|
|
} |
1194
|
|
|
|
|
|
|
1195
|
|
|
|
|
|
/* |
1196
|
|
|
|
|
|
=for apidoc Amx|void|lex_read_to|char *ptr |
1197
|
|
|
|
|
|
|
1198
|
|
|
|
|
|
Consume text in the lexer buffer, from Lbufptr> up |
1199
|
|
|
|
|
|
to I. This advances Lbufptr> to match I, |
1200
|
|
|
|
|
|
performing the correct bookkeeping whenever a newline character is passed. |
1201
|
|
|
|
|
|
This is the normal way to consume lexed text. |
1202
|
|
|
|
|
|
|
1203
|
|
|
|
|
|
Interpretation of the buffer's octets can be abstracted out by |
1204
|
|
|
|
|
|
using the slightly higher-level functions L and |
1205
|
|
|
|
|
|
L. |
1206
|
|
|
|
|
|
|
1207
|
|
|
|
|
|
=cut |
1208
|
|
|
|
|
|
*/ |
1209
|
|
|
|
|
|
|
1210
|
|
|
|
|
|
void |
1211
|
40
|
|
|
|
|
Perl_lex_read_to(pTHX_ char *ptr) |
1212
|
|
|
|
|
|
{ |
1213
|
|
|
|
|
|
char *s; |
1214
|
|
|
|
|
|
PERL_ARGS_ASSERT_LEX_READ_TO; |
1215
|
40
|
|
|
|
|
s = PL_parser->bufptr; |
1216
|
40
|
50
|
|
|
|
if (ptr < s || ptr > PL_parser->bufend) |
|
|
50
|
|
|
|
|
1217
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to"); |
1218
|
184
|
100
|
|
|
|
for (; s != ptr; s++) |
1219
|
164
|
50
|
|
|
|
if (*s == '\n') { |
1220
|
0
|
0
|
|
|
|
COPLINE_INC_WITH_HERELINES; |
1221
|
0
|
|
|
|
|
PL_parser->linestart = s+1; |
1222
|
|
|
|
|
|
} |
1223
|
40
|
|
|
|
|
PL_parser->bufptr = ptr; |
1224
|
40
|
|
|
|
|
} |
1225
|
|
|
|
|
|
|
1226
|
|
|
|
|
|
/* |
1227
|
|
|
|
|
|
=for apidoc Amx|void|lex_discard_to|char *ptr |
1228
|
|
|
|
|
|
|
1229
|
|
|
|
|
|
Discards the first part of the Llinestr> buffer, |
1230
|
|
|
|
|
|
up to I. The remaining content of the buffer will be moved, and |
1231
|
|
|
|
|
|
all pointers into the buffer updated appropriately. I must not |
1232
|
|
|
|
|
|
be later in the buffer than the position of Lbufptr>: |
1233
|
|
|
|
|
|
it is not permitted to discard text that has yet to be lexed. |
1234
|
|
|
|
|
|
|
1235
|
|
|
|
|
|
Normally it is not necessarily to do this directly, because it suffices to |
1236
|
|
|
|
|
|
use the implicit discarding behaviour of L and things |
1237
|
|
|
|
|
|
based on it. However, if a token stretches across multiple lines, |
1238
|
|
|
|
|
|
and the lexing code has kept multiple lines of text in the buffer for |
1239
|
|
|
|
|
|
that purpose, then after completion of the token it would be wise to |
1240
|
|
|
|
|
|
explicitly discard the now-unneeded earlier lines, to avoid future |
1241
|
|
|
|
|
|
multi-line tokens growing the buffer without bound. |
1242
|
|
|
|
|
|
|
1243
|
|
|
|
|
|
=cut |
1244
|
|
|
|
|
|
*/ |
1245
|
|
|
|
|
|
|
1246
|
|
|
|
|
|
void |
1247
|
0
|
|
|
|
|
Perl_lex_discard_to(pTHX_ char *ptr) |
1248
|
|
|
|
|
|
{ |
1249
|
|
|
|
|
|
char *buf; |
1250
|
|
|
|
|
|
STRLEN discard_len; |
1251
|
|
|
|
|
|
PERL_ARGS_ASSERT_LEX_DISCARD_TO; |
1252
|
0
|
|
|
|
|
buf = SvPVX(PL_parser->linestr); |
1253
|
0
|
0
|
|
|
|
if (ptr < buf) |
1254
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to"); |
1255
|
0
|
0
|
|
|
|
if (ptr == buf) |
1256
|
0
|
|
|
|
|
return; |
1257
|
0
|
0
|
|
|
|
if (ptr > PL_parser->bufptr) |
1258
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to"); |
1259
|
0
|
|
|
|
|
discard_len = ptr - buf; |
1260
|
0
|
0
|
|
|
|
if (PL_parser->oldbufptr < ptr) |
1261
|
0
|
|
|
|
|
PL_parser->oldbufptr = ptr; |
1262
|
0
|
0
|
|
|
|
if (PL_parser->oldoldbufptr < ptr) |
1263
|
0
|
|
|
|
|
PL_parser->oldoldbufptr = ptr; |
1264
|
0
|
0
|
|
|
|
if (PL_parser->last_uni && PL_parser->last_uni < ptr) |
|
|
0
|
|
|
|
|
1265
|
0
|
|
|
|
|
PL_parser->last_uni = NULL; |
1266
|
0
|
0
|
|
|
|
if (PL_parser->last_lop && PL_parser->last_lop < ptr) |
|
|
0
|
|
|
|
|
1267
|
0
|
|
|
|
|
PL_parser->last_lop = NULL; |
1268
|
0
|
|
|
|
|
Move(ptr, buf, PL_parser->bufend+1-ptr, char); |
1269
|
0
|
|
|
|
|
SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len); |
1270
|
0
|
|
|
|
|
PL_parser->bufend -= discard_len; |
1271
|
0
|
|
|
|
|
PL_parser->bufptr -= discard_len; |
1272
|
0
|
|
|
|
|
PL_parser->oldbufptr -= discard_len; |
1273
|
0
|
|
|
|
|
PL_parser->oldoldbufptr -= discard_len; |
1274
|
0
|
0
|
|
|
|
if (PL_parser->last_uni) |
1275
|
0
|
|
|
|
|
PL_parser->last_uni -= discard_len; |
1276
|
0
|
0
|
|
|
|
if (PL_parser->last_lop) |
1277
|
0
|
|
|
|
|
PL_parser->last_lop -= discard_len; |
1278
|
|
|
|
|
|
} |
1279
|
|
|
|
|
|
|
1280
|
|
|
|
|
|
/* |
1281
|
|
|
|
|
|
=for apidoc Amx|bool|lex_next_chunk|U32 flags |
1282
|
|
|
|
|
|
|
1283
|
|
|
|
|
|
Reads in the next chunk of text to be lexed, appending it to |
1284
|
|
|
|
|
|
Llinestr>. This should be called when lexing code has |
1285
|
|
|
|
|
|
looked to the end of the current chunk and wants to know more. It is |
1286
|
|
|
|
|
|
usual, but not necessary, for lexing to have consumed the entirety of |
1287
|
|
|
|
|
|
the current chunk at this time. |
1288
|
|
|
|
|
|
|
1289
|
|
|
|
|
|
If Lbufptr> is pointing to the very end of the current |
1290
|
|
|
|
|
|
chunk (i.e., the current chunk has been entirely consumed), normally the |
1291
|
|
|
|
|
|
current chunk will be discarded at the same time that the new chunk is |
1292
|
|
|
|
|
|
read in. If I includes C, the current chunk |
1293
|
|
|
|
|
|
will not be discarded. If the current chunk has not been entirely |
1294
|
|
|
|
|
|
consumed, then it will not be discarded regardless of the flag. |
1295
|
|
|
|
|
|
|
1296
|
|
|
|
|
|
Returns true if some new text was added to the buffer, or false if the |
1297
|
|
|
|
|
|
buffer has reached the end of the input text. |
1298
|
|
|
|
|
|
|
1299
|
|
|
|
|
|
=cut |
1300
|
|
|
|
|
|
*/ |
1301
|
|
|
|
|
|
|
1302
|
|
|
|
|
|
#define LEX_FAKE_EOF 0x80000000 |
1303
|
|
|
|
|
|
#define LEX_NO_TERM 0x40000000 |
1304
|
|
|
|
|
|
|
1305
|
|
|
|
|
|
bool |
1306
|
215833189
|
|
|
|
|
Perl_lex_next_chunk(pTHX_ U32 flags) |
1307
|
|
|
|
|
|
{ |
1308
|
|
|
|
|
|
SV *linestr; |
1309
|
|
|
|
|
|
char *buf; |
1310
|
|
|
|
|
|
STRLEN old_bufend_pos, new_bufend_pos; |
1311
|
|
|
|
|
|
STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos; |
1312
|
|
|
|
|
|
STRLEN linestart_pos, last_uni_pos, last_lop_pos; |
1313
|
|
|
|
|
|
bool got_some_for_debugger = 0; |
1314
|
|
|
|
|
|
bool got_some; |
1315
|
215833189
|
50
|
|
|
|
if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM)) |
1316
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk"); |
1317
|
215833189
|
|
|
|
|
linestr = PL_parser->linestr; |
1318
|
215833189
|
|
|
|
|
buf = SvPVX(linestr); |
1319
|
317086085
|
100
|
|
|
|
if (!(flags & LEX_KEEP_PREVIOUS) && |
|
|
50
|
|
|
|
|
1320
|
209530253
|
|
|
|
|
PL_parser->bufptr == PL_parser->bufend) { |
1321
|
|
|
|
|
|
old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0; |
1322
|
|
|
|
|
|
linestart_pos = 0; |
1323
|
209530253
|
50
|
|
|
|
if (PL_parser->last_uni != PL_parser->bufend) |
1324
|
209530253
|
|
|
|
|
PL_parser->last_uni = NULL; |
1325
|
209530253
|
50
|
|
|
|
if (PL_parser->last_lop != PL_parser->bufend) |
1326
|
209530253
|
|
|
|
|
PL_parser->last_lop = NULL; |
1327
|
|
|
|
|
|
last_uni_pos = last_lop_pos = 0; |
1328
|
209530253
|
|
|
|
|
*buf = 0; |
1329
|
209530253
|
|
|
|
|
SvCUR(linestr) = 0; |
1330
|
|
|
|
|
|
} else { |
1331
|
6302936
|
|
|
|
|
old_bufend_pos = PL_parser->bufend - buf; |
1332
|
6302936
|
|
|
|
|
bufptr_pos = PL_parser->bufptr - buf; |
1333
|
6302936
|
|
|
|
|
oldbufptr_pos = PL_parser->oldbufptr - buf; |
1334
|
6302936
|
|
|
|
|
oldoldbufptr_pos = PL_parser->oldoldbufptr - buf; |
1335
|
6302936
|
|
|
|
|
linestart_pos = PL_parser->linestart - buf; |
1336
|
6302936
|
100
|
|
|
|
last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0; |
1337
|
6302936
|
100
|
|
|
|
last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0; |
1338
|
|
|
|
|
|
} |
1339
|
215833189
|
100
|
|
|
|
if (flags & LEX_FAKE_EOF) { |
1340
|
|
|
|
|
|
goto eof; |
1341
|
215443259
|
100
|
|
|
|
} else if (!PL_parser->rsfp && !PL_parser->filtered) { |
|
|
100
|
|
|
|
|
1342
|
|
|
|
|
|
got_some = 0; |
1343
|
215443149
|
100
|
|
|
|
} else if (filter_gets(linestr, old_bufend_pos)) { |
1344
|
|
|
|
|
|
got_some = 1; |
1345
|
|
|
|
|
|
got_some_for_debugger = 1; |
1346
|
224157
|
100
|
|
|
|
} else if (flags & LEX_NO_TERM) { |
1347
|
|
|
|
|
|
got_some = 0; |
1348
|
|
|
|
|
|
} else { |
1349
|
223977
|
100
|
|
|
|
if (!SvPOK(linestr)) /* can get undefined by filter_gets */ |
1350
|
14
|
|
|
|
|
sv_setpvs(linestr, ""); |
1351
|
|
|
|
|
|
eof: |
1352
|
|
|
|
|
|
/* End of real input. Close filehandle (unless it was STDIN), |
1353
|
|
|
|
|
|
* then add implicit termination. |
1354
|
|
|
|
|
|
*/ |
1355
|
613907
|
100
|
|
|
|
if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP) |
1356
|
40
|
|
|
|
|
PerlIO_clearerr(PL_parser->rsfp); |
1357
|
613867
|
100
|
|
|
|
else if (PL_parser->rsfp) |
1358
|
611619
|
|
|
|
|
(void)PerlIO_close(PL_parser->rsfp); |
1359
|
613907
|
|
|
|
|
PL_parser->rsfp = NULL; |
1360
|
613907
|
|
|
|
|
PL_parser->in_pod = PL_parser->filtered = 0; |
1361
|
|
|
|
|
|
#ifdef PERL_MAD |
1362
|
|
|
|
|
|
if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n)) |
1363
|
|
|
|
|
|
PL_faketokens = 1; |
1364
|
|
|
|
|
|
#endif |
1365
|
613907
|
100
|
|
|
|
if (!PL_in_eval && PL_minus_p) { |
|
|
100
|
|
|
|
|
1366
|
26
|
|
|
|
|
sv_catpvs(linestr, |
1367
|
|
|
|
|
|
/*{*/";}continue{print or die qq(-p destination: $!\\n);}"); |
1368
|
26
|
|
|
|
|
PL_minus_n = PL_minus_p = 0; |
1369
|
613881
|
100
|
|
|
|
} else if (!PL_in_eval && PL_minus_n) { |
|
|
100
|
|
|
|
|
1370
|
90
|
|
|
|
|
sv_catpvs(linestr, /*{*/";}"); |
1371
|
90
|
|
|
|
|
PL_minus_n = 0; |
1372
|
|
|
|
|
|
} else |
1373
|
613791
|
|
|
|
|
sv_catpvs(linestr, ";"); |
1374
|
|
|
|
|
|
got_some = 1; |
1375
|
|
|
|
|
|
} |
1376
|
215833179
|
|
|
|
|
buf = SvPVX(linestr); |
1377
|
215833179
|
|
|
|
|
new_bufend_pos = SvCUR(linestr); |
1378
|
215833179
|
|
|
|
|
PL_parser->bufend = buf + new_bufend_pos; |
1379
|
215833179
|
|
|
|
|
PL_parser->bufptr = buf + bufptr_pos; |
1380
|
215833179
|
|
|
|
|
PL_parser->oldbufptr = buf + oldbufptr_pos; |
1381
|
215833179
|
|
|
|
|
PL_parser->oldoldbufptr = buf + oldoldbufptr_pos; |
1382
|
215833179
|
|
|
|
|
PL_parser->linestart = buf + linestart_pos; |
1383
|
215833179
|
100
|
|
|
|
if (PL_parser->last_uni) |
1384
|
825798
|
|
|
|
|
PL_parser->last_uni = buf + last_uni_pos; |
1385
|
215833179
|
100
|
|
|
|
if (PL_parser->last_lop) |
1386
|
571803
|
|
|
|
|
PL_parser->last_lop = buf + last_lop_pos; |
1387
|
217243210
|
100
|
|
|
|
if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) && |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1388
|
2820062
|
|
|
|
|
PL_curstash != PL_debstash) { |
1389
|
|
|
|
|
|
/* debugger active and we're not compiling the debugger code, |
1390
|
|
|
|
|
|
* so store the line into the debugger's array of lines |
1391
|
|
|
|
|
|
*/ |
1392
|
1041768
|
|
|
|
|
update_debugger_info(NULL, buf+old_bufend_pos, |
1393
|
|
|
|
|
|
new_bufend_pos-old_bufend_pos); |
1394
|
|
|
|
|
|
} |
1395
|
215833179
|
|
|
|
|
return got_some; |
1396
|
|
|
|
|
|
} |
1397
|
|
|
|
|
|
|
1398
|
|
|
|
|
|
/* |
1399
|
|
|
|
|
|
=for apidoc Amx|I32|lex_peek_unichar|U32 flags |
1400
|
|
|
|
|
|
|
1401
|
|
|
|
|
|
Looks ahead one (Unicode) character in the text currently being lexed. |
1402
|
|
|
|
|
|
Returns the codepoint (unsigned integer value) of the next character, |
1403
|
|
|
|
|
|
or -1 if lexing has reached the end of the input text. To consume the |
1404
|
|
|
|
|
|
peeked character, use L. |
1405
|
|
|
|
|
|
|
1406
|
|
|
|
|
|
If the next character is in (or extends into) the next chunk of input |
1407
|
|
|
|
|
|
text, the next chunk will be read in. Normally the current chunk will be |
1408
|
|
|
|
|
|
discarded at the same time, but if I includes C |
1409
|
|
|
|
|
|
then the current chunk will not be discarded. |
1410
|
|
|
|
|
|
|
1411
|
|
|
|
|
|
If the input is being interpreted as UTF-8 and a UTF-8 encoding error |
1412
|
|
|
|
|
|
is encountered, an exception is generated. |
1413
|
|
|
|
|
|
|
1414
|
|
|
|
|
|
=cut |
1415
|
|
|
|
|
|
*/ |
1416
|
|
|
|
|
|
|
1417
|
|
|
|
|
|
I32 |
1418
|
536
|
|
|
|
|
Perl_lex_peek_unichar(pTHX_ U32 flags) |
1419
|
|
|
|
|
|
{ |
1420
|
|
|
|
|
|
dVAR; |
1421
|
|
|
|
|
|
char *s, *bufend; |
1422
|
536
|
50
|
|
|
|
if (flags & ~(LEX_KEEP_PREVIOUS)) |
1423
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar"); |
1424
|
536
|
|
|
|
|
s = PL_parser->bufptr; |
1425
|
536
|
|
|
|
|
bufend = PL_parser->bufend; |
1426
|
536
|
50
|
|
|
|
if (UTF) { |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1427
|
|
|
|
|
|
U8 head; |
1428
|
|
|
|
|
|
I32 unichar; |
1429
|
|
|
|
|
|
STRLEN len, retlen; |
1430
|
0
|
0
|
|
|
|
if (s == bufend) { |
1431
|
0
|
0
|
|
|
|
if (!lex_next_chunk(flags)) |
1432
|
|
|
|
|
|
return -1; |
1433
|
0
|
|
|
|
|
s = PL_parser->bufptr; |
1434
|
0
|
|
|
|
|
bufend = PL_parser->bufend; |
1435
|
|
|
|
|
|
} |
1436
|
0
|
|
|
|
|
head = (U8)*s; |
1437
|
0
|
0
|
|
|
|
if (UTF8_IS_INVARIANT(head)) |
1438
|
0
|
|
|
|
|
return head; |
1439
|
0
|
0
|
|
|
|
if (UTF8_IS_START(head)) { |
1440
|
0
|
|
|
|
|
len = UTF8SKIP(&head); |
1441
|
0
|
0
|
|
|
|
while ((STRLEN)(bufend-s) < len) { |
1442
|
0
|
0
|
|
|
|
if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS)) |
1443
|
|
|
|
|
|
break; |
1444
|
0
|
|
|
|
|
s = PL_parser->bufptr; |
1445
|
0
|
|
|
|
|
bufend = PL_parser->bufend; |
1446
|
|
|
|
|
|
} |
1447
|
|
|
|
|
|
} |
1448
|
0
|
|
|
|
|
unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY); |
1449
|
0
|
0
|
|
|
|
if (retlen == (STRLEN)-1) { |
1450
|
|
|
|
|
|
/* malformed UTF-8 */ |
1451
|
0
|
|
|
|
|
ENTER; |
1452
|
0
|
|
|
|
|
SAVESPTR(PL_warnhook); |
1453
|
0
|
|
|
|
|
PL_warnhook = PERL_WARNHOOK_FATAL; |
1454
|
0
|
|
|
|
|
utf8n_to_uvchr((U8*)s, bufend-s, NULL, 0); |
1455
|
0
|
|
|
|
|
LEAVE; |
1456
|
|
|
|
|
|
} |
1457
|
|
|
|
|
|
return unichar; |
1458
|
|
|
|
|
|
} else { |
1459
|
536
|
100
|
|
|
|
if (s == bufend) { |
1460
|
6
|
50
|
|
|
|
if (!lex_next_chunk(flags)) |
1461
|
|
|
|
|
|
return -1; |
1462
|
0
|
|
|
|
|
s = PL_parser->bufptr; |
1463
|
|
|
|
|
|
} |
1464
|
533
|
|
|
|
|
return (U8)*s; |
1465
|
|
|
|
|
|
} |
1466
|
|
|
|
|
|
} |
1467
|
|
|
|
|
|
|
1468
|
|
|
|
|
|
/* |
1469
|
|
|
|
|
|
=for apidoc Amx|I32|lex_read_unichar|U32 flags |
1470
|
|
|
|
|
|
|
1471
|
|
|
|
|
|
Reads the next (Unicode) character in the text currently being lexed. |
1472
|
|
|
|
|
|
Returns the codepoint (unsigned integer value) of the character read, |
1473
|
|
|
|
|
|
and moves Lbufptr> past the character, or returns -1 |
1474
|
|
|
|
|
|
if lexing has reached the end of the input text. To non-destructively |
1475
|
|
|
|
|
|
examine the next character, use L instead. |
1476
|
|
|
|
|
|
|
1477
|
|
|
|
|
|
If the next character is in (or extends into) the next chunk of input |
1478
|
|
|
|
|
|
text, the next chunk will be read in. Normally the current chunk will be |
1479
|
|
|
|
|
|
discarded at the same time, but if I includes C |
1480
|
|
|
|
|
|
then the current chunk will not be discarded. |
1481
|
|
|
|
|
|
|
1482
|
|
|
|
|
|
If the input is being interpreted as UTF-8 and a UTF-8 encoding error |
1483
|
|
|
|
|
|
is encountered, an exception is generated. |
1484
|
|
|
|
|
|
|
1485
|
|
|
|
|
|
=cut |
1486
|
|
|
|
|
|
*/ |
1487
|
|
|
|
|
|
|
1488
|
|
|
|
|
|
I32 |
1489
|
202
|
|
|
|
|
Perl_lex_read_unichar(pTHX_ U32 flags) |
1490
|
|
|
|
|
|
{ |
1491
|
|
|
|
|
|
I32 c; |
1492
|
202
|
50
|
|
|
|
if (flags & ~(LEX_KEEP_PREVIOUS)) |
1493
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar"); |
1494
|
202
|
|
|
|
|
c = lex_peek_unichar(flags); |
1495
|
202
|
50
|
|
|
|
if (c != -1) { |
1496
|
202
|
50
|
|
|
|
if (c == '\n') |
1497
|
0
|
0
|
|
|
|
COPLINE_INC_WITH_HERELINES; |
1498
|
202
|
50
|
|
|
|
if (UTF) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1499
|
0
|
|
|
|
|
PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr); |
1500
|
|
|
|
|
|
else |
1501
|
202
|
|
|
|
|
++(PL_parser->bufptr); |
1502
|
|
|
|
|
|
} |
1503
|
202
|
|
|
|
|
return c; |
1504
|
|
|
|
|
|
} |
1505
|
|
|
|
|
|
|
1506
|
|
|
|
|
|
/* |
1507
|
|
|
|
|
|
=for apidoc Amx|void|lex_read_space|U32 flags |
1508
|
|
|
|
|
|
|
1509
|
|
|
|
|
|
Reads optional spaces, in Perl style, in the text currently being |
1510
|
|
|
|
|
|
lexed. The spaces may include ordinary whitespace characters and |
1511
|
|
|
|
|
|
Perl-style comments. C<#line> directives are processed if encountered. |
1512
|
|
|
|
|
|
Lbufptr> is moved past the spaces, so that it points |
1513
|
|
|
|
|
|
at a non-space character (or the end of the input text). |
1514
|
|
|
|
|
|
|
1515
|
|
|
|
|
|
If spaces extend into the next chunk of input text, the next chunk will |
1516
|
|
|
|
|
|
be read in. Normally the current chunk will be discarded at the same |
1517
|
|
|
|
|
|
time, but if I includes C then the current |
1518
|
|
|
|
|
|
chunk will not be discarded. |
1519
|
|
|
|
|
|
|
1520
|
|
|
|
|
|
=cut |
1521
|
|
|
|
|
|
*/ |
1522
|
|
|
|
|
|
|
1523
|
|
|
|
|
|
#define LEX_NO_INCLINE 0x40000000 |
1524
|
|
|
|
|
|
#define LEX_NO_NEXT_CHUNK 0x80000000 |
1525
|
|
|
|
|
|
|
1526
|
|
|
|
|
|
void |
1527
|
470855641
|
|
|
|
|
Perl_lex_read_space(pTHX_ U32 flags) |
1528
|
|
|
|
|
|
{ |
1529
|
|
|
|
|
|
char *s, *bufend; |
1530
|
470855641
|
|
|
|
|
const bool can_incline = !(flags & LEX_NO_INCLINE); |
1531
|
|
|
|
|
|
bool need_incline = 0; |
1532
|
470855641
|
50
|
|
|
|
if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE)) |
1533
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space"); |
1534
|
|
|
|
|
|
#ifdef PERL_MAD |
1535
|
|
|
|
|
|
if (PL_skipwhite) { |
1536
|
|
|
|
|
|
sv_free(PL_skipwhite); |
1537
|
|
|
|
|
|
PL_skipwhite = NULL; |
1538
|
|
|
|
|
|
} |
1539
|
|
|
|
|
|
if (PL_madskills) |
1540
|
|
|
|
|
|
PL_skipwhite = newSVpvs(""); |
1541
|
|
|
|
|
|
#endif /* PERL_MAD */ |
1542
|
470855641
|
|
|
|
|
s = PL_parser->bufptr; |
1543
|
616830542
|
|
|
|
|
bufend = PL_parser->bufend; |
1544
|
|
|
|
|
|
while (1) { |
1545
|
753100338
|
|
|
|
|
char c = *s; |
1546
|
753100338
|
100
|
|
|
|
if (c == '#') { |
1547
|
|
|
|
|
|
do { |
1548
|
15208990
|
|
|
|
|
c = *++s; |
1549
|
15208990
|
100
|
|
|
|
} while (!(c == '\n' || (c == 0 && s == bufend))); |
|
|
100
|
|
|
|
|
1550
|
752663352
|
100
|
|
|
|
} else if (c == '\n') { |
1551
|
6828186
|
|
|
|
|
s++; |
1552
|
6828186
|
100
|
|
|
|
if (can_incline) { |
1553
|
6015990
|
|
|
|
|
PL_parser->linestart = s; |
1554
|
6015990
|
100
|
|
|
|
if (s == bufend) |
1555
|
|
|
|
|
|
need_incline = 1; |
1556
|
|
|
|
|
|
else |
1557
|
523464
|
|
|
|
|
incline(s); |
1558
|
|
|
|
|
|
} |
1559
|
745835166
|
100
|
|
|
|
} else if (isSPACE(c)) { |
1560
|
268676675
|
|
|
|
|
s++; |
1561
|
477158491
|
100
|
|
|
|
} else if (c == 0 && s == bufend) { |
1562
|
|
|
|
|
|
bool got_more; |
1563
|
|
|
|
|
|
#ifdef PERL_MAD |
1564
|
|
|
|
|
|
if (PL_madskills) |
1565
|
|
|
|
|
|
sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr); |
1566
|
|
|
|
|
|
#endif /* PERL_MAD */ |
1567
|
6302958
|
100
|
|
|
|
if (flags & LEX_NO_NEXT_CHUNK) |
1568
|
|
|
|
|
|
break; |
1569
|
6302956
|
|
|
|
|
PL_parser->bufptr = s; |
1570
|
6302956
|
100
|
|
|
|
if (can_incline) COPLINE_INC_WITH_HERELINES; |
|
|
100
|
|
|
|
|
1571
|
6302956
|
|
|
|
|
got_more = lex_next_chunk(flags); |
1572
|
6302956
|
100
|
|
|
|
if (can_incline) CopLINE_dec(PL_curcop); |
1573
|
6302956
|
|
|
|
|
s = PL_parser->bufptr; |
1574
|
6302956
|
|
|
|
|
bufend = PL_parser->bufend; |
1575
|
6302956
|
100
|
|
|
|
if (!got_more) |
1576
|
|
|
|
|
|
break; |
1577
|
6302850
|
100
|
|
|
|
if (can_incline && need_incline && PL_parser->rsfp) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1578
|
5483412
|
|
|
|
|
incline(s); |
1579
|
|
|
|
|
|
need_incline = 0; |
1580
|
|
|
|
|
|
} |
1581
|
|
|
|
|
|
} else { |
1582
|
|
|
|
|
|
break; |
1583
|
|
|
|
|
|
} |
1584
|
|
|
|
|
|
} |
1585
|
|
|
|
|
|
#ifdef PERL_MAD |
1586
|
|
|
|
|
|
if (PL_madskills) |
1587
|
|
|
|
|
|
sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr); |
1588
|
|
|
|
|
|
#endif /* PERL_MAD */ |
1589
|
470855641
|
|
|
|
|
PL_parser->bufptr = s; |
1590
|
470855641
|
|
|
|
|
} |
1591
|
|
|
|
|
|
|
1592
|
|
|
|
|
|
/* |
1593
|
|
|
|
|
|
|
1594
|
|
|
|
|
|
=for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn |
1595
|
|
|
|
|
|
|
1596
|
|
|
|
|
|
This function performs syntax checking on a prototype, C. |
1597
|
|
|
|
|
|
If C is true, any illegal characters or mismatched brackets |
1598
|
|
|
|
|
|
will trigger illegalproto warnings, declaring that they were |
1599
|
|
|
|
|
|
detected in the prototype for C. |
1600
|
|
|
|
|
|
|
1601
|
|
|
|
|
|
The return value is C if this is a valid prototype, and |
1602
|
|
|
|
|
|
C if it is not, regardless of whether C was C or |
1603
|
|
|
|
|
|
C. |
1604
|
|
|
|
|
|
|
1605
|
|
|
|
|
|
Note that C is a valid C and will always return C. |
1606
|
|
|
|
|
|
|
1607
|
|
|
|
|
|
=cut |
1608
|
|
|
|
|
|
|
1609
|
|
|
|
|
|
*/ |
1610
|
|
|
|
|
|
|
1611
|
|
|
|
|
|
bool |
1612
|
519944
|
|
|
|
|
Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn) |
1613
|
|
|
|
|
|
{ |
1614
|
|
|
|
|
|
STRLEN len, origlen; |
1615
|
519944
|
50
|
|
|
|
char *p = proto ? SvPV(proto, len) : NULL; |
|
|
50
|
|
|
|
|
1616
|
|
|
|
|
|
bool bad_proto = FALSE; |
1617
|
|
|
|
|
|
bool in_brackets = FALSE; |
1618
|
|
|
|
|
|
bool after_slash = FALSE; |
1619
|
|
|
|
|
|
char greedy_proto = ' '; |
1620
|
|
|
|
|
|
bool proto_after_greedy_proto = FALSE; |
1621
|
|
|
|
|
|
bool must_be_last = FALSE; |
1622
|
|
|
|
|
|
bool underscore = FALSE; |
1623
|
|
|
|
|
|
bool bad_proto_after_underscore = FALSE; |
1624
|
|
|
|
|
|
|
1625
|
|
|
|
|
|
PERL_ARGS_ASSERT_VALIDATE_PROTO; |
1626
|
|
|
|
|
|
|
1627
|
519944
|
50
|
|
|
|
if (!proto) |
1628
|
|
|
|
|
|
return TRUE; |
1629
|
|
|
|
|
|
|
1630
|
519944
|
|
|
|
|
origlen = len; |
1631
|
1014054
|
100
|
|
|
|
for (; len--; p++) { |
1632
|
494110
|
100
|
|
|
|
if (!isSPACE(*p)) { |
1633
|
494058
|
100
|
|
|
|
if (must_be_last) |
1634
|
|
|
|
|
|
proto_after_greedy_proto = TRUE; |
1635
|
494058
|
100
|
|
|
|
if (underscore) { |
1636
|
78
|
100
|
|
|
|
if (!strchr(";@%", *p)) |
1637
|
|
|
|
|
|
bad_proto_after_underscore = TRUE; |
1638
|
|
|
|
|
|
underscore = FALSE; |
1639
|
|
|
|
|
|
} |
1640
|
494058
|
100
|
|
|
|
if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') { |
|
|
100
|
|
|
|
|
1641
|
|
|
|
|
|
bad_proto = TRUE; |
1642
|
|
|
|
|
|
} |
1643
|
|
|
|
|
|
else { |
1644
|
493976
|
100
|
|
|
|
if (*p == '[') |
1645
|
|
|
|
|
|
in_brackets = TRUE; |
1646
|
491036
|
100
|
|
|
|
else if (*p == ']') |
1647
|
|
|
|
|
|
in_brackets = FALSE; |
1648
|
488098
|
100
|
|
|
|
else if ((*p == '@' || *p == '%') && |
|
|
100
|
|
|
|
|
1649
|
34816
|
100
|
|
|
|
!after_slash && |
1650
|
|
|
|
|
|
!in_brackets ) { |
1651
|
|
|
|
|
|
must_be_last = TRUE; |
1652
|
28962
|
|
|
|
|
greedy_proto = *p; |
1653
|
|
|
|
|
|
} |
1654
|
459136
|
100
|
|
|
|
else if (*p == '_') |
1655
|
|
|
|
|
|
underscore = TRUE; |
1656
|
|
|
|
|
|
} |
1657
|
494058
|
100
|
|
|
|
if (*p == '\\') |
1658
|
|
|
|
|
|
after_slash = TRUE; |
1659
|
|
|
|
|
|
else |
1660
|
|
|
|
|
|
after_slash = FALSE; |
1661
|
|
|
|
|
|
} |
1662
|
|
|
|
|
|
} |
1663
|
|
|
|
|
|
|
1664
|
519944
|
100
|
|
|
|
if (warn) { |
1665
|
147014
|
|
|
|
|
SV *tmpsv = newSVpvs_flags("", SVs_TEMP); |
1666
|
147014
|
|
|
|
|
p -= origlen; |
1667
|
147014
|
|
|
|
|
p = SvUTF8(proto) |
1668
|
4
|
|
|
|
|
? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8), |
1669
|
|
|
|
|
|
origlen, UNI_DISPLAY_ISPRINT) |
1670
|
147018
|
100
|
|
|
|
: pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII); |
1671
|
|
|
|
|
|
|
1672
|
147014
|
100
|
|
|
|
if (proto_after_greedy_proto) |
1673
|
38
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO), |
1674
|
|
|
|
|
|
"Prototype after '%c' for %"SVf" : %s", |
1675
|
|
|
|
|
|
greedy_proto, SVfARG(name), p); |
1676
|
147014
|
100
|
|
|
|
if (in_brackets) |
1677
|
2
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO), |
1678
|
|
|
|
|
|
"Missing ']' in prototype for %"SVf" : %s", |
1679
|
|
|
|
|
|
SVfARG(name), p); |
1680
|
147014
|
100
|
|
|
|
if (bad_proto) |
1681
|
30
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO), |
1682
|
|
|
|
|
|
"Illegal character in prototype for %"SVf" : %s", |
1683
|
|
|
|
|
|
SVfARG(name), p); |
1684
|
147014
|
100
|
|
|
|
if (bad_proto_after_underscore) |
1685
|
8
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO), |
1686
|
|
|
|
|
|
"Illegal character after '_' in prototype for %"SVf" : %s", |
1687
|
|
|
|
|
|
SVfARG(name), p); |
1688
|
|
|
|
|
|
} |
1689
|
|
|
|
|
|
|
1690
|
519944
|
100
|
|
|
|
return (! (proto_after_greedy_proto || bad_proto) ); |
|
|
100
|
|
|
|
|
1691
|
|
|
|
|
|
} |
1692
|
|
|
|
|
|
|
1693
|
|
|
|
|
|
/* |
1694
|
|
|
|
|
|
* S_incline |
1695
|
|
|
|
|
|
* This subroutine has nothing to do with tilting, whether at windmills |
1696
|
|
|
|
|
|
* or pinball tables. Its name is short for "increment line". It |
1697
|
|
|
|
|
|
* increments the current line number in CopLINE(PL_curcop) and checks |
1698
|
|
|
|
|
|
* to see whether the line starts with a comment of the form |
1699
|
|
|
|
|
|
* # line 500 "foo.pm" |
1700
|
|
|
|
|
|
* If so, it sets the current line number and file to the values in the comment. |
1701
|
|
|
|
|
|
*/ |
1702
|
|
|
|
|
|
|
1703
|
|
|
|
|
|
STATIC void |
1704
|
202428658
|
|
|
|
|
S_incline(pTHX_ const char *s) |
1705
|
|
|
|
|
|
{ |
1706
|
|
|
|
|
|
dVAR; |
1707
|
|
|
|
|
|
const char *t; |
1708
|
|
|
|
|
|
const char *n; |
1709
|
|
|
|
|
|
const char *e; |
1710
|
|
|
|
|
|
line_t line_num; |
1711
|
|
|
|
|
|
|
1712
|
|
|
|
|
|
PERL_ARGS_ASSERT_INCLINE; |
1713
|
|
|
|
|
|
|
1714
|
202428658
|
100
|
|
|
|
COPLINE_INC_WITH_HERELINES; |
1715
|
202428658
|
100
|
|
|
|
if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1716
|
7378420
|
100
|
|
|
|
&& s+1 == PL_bufend && *s == ';') { |
|
|
50
|
|
|
|
|
1717
|
|
|
|
|
|
/* fake newline in string eval */ |
1718
|
3626370
|
|
|
|
|
CopLINE_dec(PL_curcop); |
1719
|
3626370
|
|
|
|
|
return; |
1720
|
|
|
|
|
|
} |
1721
|
198802288
|
100
|
|
|
|
if (*s++ != '#') |
1722
|
|
|
|
|
|
return; |
1723
|
17709658
|
100
|
|
|
|
while (SPACE_OR_TAB(*s)) |
1724
|
9237789
|
|
|
|
|
s++; |
1725
|
8471869
|
100
|
|
|
|
if (strnEQ(s, "line", 4)) |
1726
|
|
|
|
|
|
s += 4; |
1727
|
|
|
|
|
|
else |
1728
|
|
|
|
|
|
return; |
1729
|
315040
|
100
|
|
|
|
if (SPACE_OR_TAB(*s)) |
1730
|
310300
|
|
|
|
|
s++; |
1731
|
|
|
|
|
|
else |
1732
|
|
|
|
|
|
return; |
1733
|
465592
|
100
|
|
|
|
while (SPACE_OR_TAB(*s)) |
1734
|
142
|
|
|
|
|
s++; |
1735
|
310300
|
100
|
|
|
|
if (!isDIGIT(*s)) |
1736
|
|
|
|
|
|
return; |
1737
|
|
|
|
|
|
|
1738
|
|
|
|
|
|
n = s; |
1739
|
1153442
|
100
|
|
|
|
while (isDIGIT(*s)) |
1740
|
844318
|
|
|
|
|
s++; |
1741
|
309124
|
100
|
|
|
|
if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0') |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
1742
|
|
|
|
|
|
return; |
1743
|
615496
|
100
|
|
|
|
while (SPACE_OR_TAB(*s)) |
1744
|
306374
|
|
|
|
|
s++; |
1745
|
309122
|
100
|
|
|
|
if (*s == '"' && (t = strchr(s+1, '"'))) { |
|
|
100
|
|
|
|
|
1746
|
291766
|
|
|
|
|
s++; |
1747
|
300444
|
|
|
|
|
e = t + 1; |
1748
|
|
|
|
|
|
} |
1749
|
|
|
|
|
|
else { |
1750
|
|
|
|
|
|
t = s; |
1751
|
259114
|
100
|
|
|
|
while (!isSPACE(*t)) |
1752
|
241758
|
|
|
|
|
t++; |
1753
|
|
|
|
|
|
e = t; |
1754
|
|
|
|
|
|
} |
1755
|
309130
|
100
|
|
|
|
while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f') |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1756
|
8
|
|
|
|
|
e++; |
1757
|
309122
|
100
|
|
|
|
if (*e != '\n' && *e != '\0') |
1758
|
|
|
|
|
|
return; /* false alarm */ |
1759
|
|
|
|
|
|
|
1760
|
309116
|
|
|
|
|
line_num = atoi(n)-1; |
1761
|
|
|
|
|
|
|
1762
|
309116
|
100
|
|
|
|
if (t - s > 0) { |
1763
|
306364
|
|
|
|
|
const STRLEN len = t - s; |
1764
|
|
|
|
|
|
|
1765
|
306364
|
100
|
|
|
|
if (!PL_rsfp && !PL_parser->filtered) { |
|
|
50
|
|
|
|
|
1766
|
|
|
|
|
|
/* must copy *{"::_<(eval N)[oldfilename:L]"} |
1767
|
|
|
|
|
|
* to *{"::_
|
1768
|
|
|
|
|
|
/* However, the long form of evals is only turned on by the |
1769
|
|
|
|
|
|
debugger - usually they're "(eval %lu)" */ |
1770
|
284802
|
|
|
|
|
GV * const cfgv = CopFILEGV(PL_curcop); |
1771
|
284802
|
50
|
|
|
|
if (cfgv) { |
1772
|
|
|
|
|
|
char smallbuf[128]; |
1773
|
|
|
|
|
|
STRLEN tmplen2 = len; |
1774
|
|
|
|
|
|
char *tmpbuf2; |
1775
|
|
|
|
|
|
GV *gv2; |
1776
|
|
|
|
|
|
|
1777
|
284802
|
100
|
|
|
|
if (tmplen2 + 2 <= sizeof smallbuf) |
1778
|
|
|
|
|
|
tmpbuf2 = smallbuf; |
1779
|
|
|
|
|
|
else |
1780
|
4
|
|
|
|
|
Newx(tmpbuf2, tmplen2 + 2, char); |
1781
|
|
|
|
|
|
|
1782
|
284802
|
|
|
|
|
tmpbuf2[0] = '_'; |
1783
|
284802
|
|
|
|
|
tmpbuf2[1] = '<'; |
1784
|
|
|
|
|
|
|
1785
|
284802
|
|
|
|
|
memcpy(tmpbuf2 + 2, s, tmplen2); |
1786
|
284802
|
|
|
|
|
tmplen2 += 2; |
1787
|
|
|
|
|
|
|
1788
|
284802
|
|
|
|
|
gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE); |
1789
|
284802
|
100
|
|
|
|
if (!isGV(gv2)) { |
1790
|
2146
|
|
|
|
|
gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE); |
1791
|
|
|
|
|
|
/* adjust ${"::_
|
1792
|
2146
|
|
|
|
|
GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2); |
1793
|
|
|
|
|
|
/* The line number may differ. If that is the case, |
1794
|
|
|
|
|
|
alias the saved lines that are in the array. |
1795
|
|
|
|
|
|
Otherwise alias the whole array. */ |
1796
|
2146
|
100
|
|
|
|
if (CopLINE(PL_curcop) == line_num) { |
1797
|
20
|
|
|
|
|
GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv))); |
1798
|
15
|
|
|
|
|
GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv))); |
1799
|
|
|
|
|
|
} |
1800
|
2136
|
100
|
|
|
|
else if (GvAV(cfgv)) { |
1801
|
22
|
|
|
|
|
AV * const av = GvAV(cfgv); |
1802
|
22
|
|
|
|
|
const I32 start = CopLINE(PL_curcop)+1; |
1803
|
22
|
|
|
|
|
I32 items = AvFILLp(av) - start; |
1804
|
22
|
50
|
|
|
|
if (items > 0) { |
1805
|
22
|
50
|
|
|
|
AV * const av2 = GvAVn(gv2); |
1806
|
22
|
|
|
|
|
SV **svp = AvARRAY(av) + start; |
1807
|
22
|
|
|
|
|
I32 l = (I32)line_num+1; |
1808
|
79
|
100
|
|
|
|
while (items--) |
1809
|
69
|
|
|
|
|
av_store(av2, l++, SvREFCNT_inc(*svp++)); |
1810
|
|
|
|
|
|
} |
1811
|
|
|
|
|
|
} |
1812
|
|
|
|
|
|
} |
1813
|
|
|
|
|
|
|
1814
|
284802
|
100
|
|
|
|
if (tmpbuf2 != smallbuf) Safefree(tmpbuf2); |
1815
|
|
|
|
|
|
} |
1816
|
|
|
|
|
|
} |
1817
|
306364
|
|
|
|
|
CopFILE_free(PL_curcop); |
1818
|
612728
|
|
|
|
|
CopFILE_setn(PL_curcop, s, len); |
1819
|
|
|
|
|
|
} |
1820
|
104779884
|
|
|
|
|
CopLINE_set(PL_curcop, line_num); |
1821
|
|
|
|
|
|
} |
1822
|
|
|
|
|
|
|
1823
|
|
|
|
|
|
#define skipspace(s) skipspace_flags(s, 0) |
1824
|
|
|
|
|
|
|
1825
|
|
|
|
|
|
#ifdef PERL_MAD |
1826
|
|
|
|
|
|
/* skip space before PL_thistoken */ |
1827
|
|
|
|
|
|
|
1828
|
|
|
|
|
|
STATIC char * |
1829
|
|
|
|
|
|
S_skipspace0(pTHX_ char *s) |
1830
|
|
|
|
|
|
{ |
1831
|
|
|
|
|
|
PERL_ARGS_ASSERT_SKIPSPACE0; |
1832
|
|
|
|
|
|
|
1833
|
|
|
|
|
|
s = skipspace(s); |
1834
|
|
|
|
|
|
if (!PL_madskills) |
1835
|
|
|
|
|
|
return s; |
1836
|
|
|
|
|
|
if (PL_skipwhite) { |
1837
|
|
|
|
|
|
if (!PL_thiswhite) |
1838
|
|
|
|
|
|
PL_thiswhite = newSVpvs(""); |
1839
|
|
|
|
|
|
sv_catsv(PL_thiswhite, PL_skipwhite); |
1840
|
|
|
|
|
|
sv_free(PL_skipwhite); |
1841
|
|
|
|
|
|
PL_skipwhite = 0; |
1842
|
|
|
|
|
|
} |
1843
|
|
|
|
|
|
PL_realtokenstart = s - SvPVX(PL_linestr); |
1844
|
|
|
|
|
|
return s; |
1845
|
|
|
|
|
|
} |
1846
|
|
|
|
|
|
|
1847
|
|
|
|
|
|
/* skip space after PL_thistoken */ |
1848
|
|
|
|
|
|
|
1849
|
|
|
|
|
|
STATIC char * |
1850
|
|
|
|
|
|
S_skipspace1(pTHX_ char *s) |
1851
|
|
|
|
|
|
{ |
1852
|
|
|
|
|
|
const char *start = s; |
1853
|
|
|
|
|
|
I32 startoff = start - SvPVX(PL_linestr); |
1854
|
|
|
|
|
|
|
1855
|
|
|
|
|
|
PERL_ARGS_ASSERT_SKIPSPACE1; |
1856
|
|
|
|
|
|
|
1857
|
|
|
|
|
|
s = skipspace(s); |
1858
|
|
|
|
|
|
if (!PL_madskills) |
1859
|
|
|
|
|
|
return s; |
1860
|
|
|
|
|
|
start = SvPVX(PL_linestr) + startoff; |
1861
|
|
|
|
|
|
if (!PL_thistoken && PL_realtokenstart >= 0) { |
1862
|
|
|
|
|
|
const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart; |
1863
|
|
|
|
|
|
PL_thistoken = newSVpvn(tstart, start - tstart); |
1864
|
|
|
|
|
|
} |
1865
|
|
|
|
|
|
PL_realtokenstart = -1; |
1866
|
|
|
|
|
|
if (PL_skipwhite) { |
1867
|
|
|
|
|
|
if (!PL_nextwhite) |
1868
|
|
|
|
|
|
PL_nextwhite = newSVpvs(""); |
1869
|
|
|
|
|
|
sv_catsv(PL_nextwhite, PL_skipwhite); |
1870
|
|
|
|
|
|
sv_free(PL_skipwhite); |
1871
|
|
|
|
|
|
PL_skipwhite = 0; |
1872
|
|
|
|
|
|
} |
1873
|
|
|
|
|
|
return s; |
1874
|
|
|
|
|
|
} |
1875
|
|
|
|
|
|
|
1876
|
|
|
|
|
|
STATIC char * |
1877
|
|
|
|
|
|
S_skipspace2(pTHX_ char *s, SV **svp) |
1878
|
|
|
|
|
|
{ |
1879
|
|
|
|
|
|
char *start; |
1880
|
|
|
|
|
|
const I32 startoff = s - SvPVX(PL_linestr); |
1881
|
|
|
|
|
|
|
1882
|
|
|
|
|
|
PERL_ARGS_ASSERT_SKIPSPACE2; |
1883
|
|
|
|
|
|
|
1884
|
|
|
|
|
|
s = skipspace(s); |
1885
|
|
|
|
|
|
if (!PL_madskills || !svp) |
1886
|
|
|
|
|
|
return s; |
1887
|
|
|
|
|
|
start = SvPVX(PL_linestr) + startoff; |
1888
|
|
|
|
|
|
if (!PL_thistoken && PL_realtokenstart >= 0) { |
1889
|
|
|
|
|
|
char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart; |
1890
|
|
|
|
|
|
PL_thistoken = newSVpvn(tstart, start - tstart); |
1891
|
|
|
|
|
|
PL_realtokenstart = -1; |
1892
|
|
|
|
|
|
} |
1893
|
|
|
|
|
|
if (PL_skipwhite) { |
1894
|
|
|
|
|
|
if (!*svp) |
1895
|
|
|
|
|
|
*svp = newSVpvs(""); |
1896
|
|
|
|
|
|
sv_setsv(*svp, PL_skipwhite); |
1897
|
|
|
|
|
|
sv_free(PL_skipwhite); |
1898
|
|
|
|
|
|
PL_skipwhite = 0; |
1899
|
|
|
|
|
|
} |
1900
|
|
|
|
|
|
|
1901
|
|
|
|
|
|
return s; |
1902
|
|
|
|
|
|
} |
1903
|
|
|
|
|
|
#endif |
1904
|
|
|
|
|
|
|
1905
|
|
|
|
|
|
STATIC void |
1906
|
1041982
|
|
|
|
|
S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len) |
1907
|
|
|
|
|
|
{ |
1908
|
1041982
|
|
|
|
|
AV *av = CopFILEAVx(PL_curcop); |
1909
|
1041982
|
100
|
|
|
|
if (av) { |
1910
|
1041900
|
|
|
|
|
SV * const sv = newSV_type(SVt_PVMG); |
1911
|
1041900
|
100
|
|
|
|
if (orig_sv) |
1912
|
214
|
|
|
|
|
sv_setsv_flags(sv, orig_sv, 0); /* no cow */ |
1913
|
|
|
|
|
|
else |
1914
|
1041686
|
|
|
|
|
sv_setpvn(sv, buf, len); |
1915
|
1041900
|
|
|
|
|
(void)SvIOK_on(sv); |
1916
|
1041900
|
|
|
|
|
SvIV_set(sv, 0); |
1917
|
1041900
|
|
|
|
|
av_store(av, CopLINE(PL_curcop), sv); |
1918
|
|
|
|
|
|
} |
1919
|
1041982
|
|
|
|
|
} |
1920
|
|
|
|
|
|
|
1921
|
|
|
|
|
|
/* |
1922
|
|
|
|
|
|
* S_skipspace |
1923
|
|
|
|
|
|
* Called to gobble the appropriate amount and type of whitespace. |
1924
|
|
|
|
|
|
* Skips comments as well. |
1925
|
|
|
|
|
|
*/ |
1926
|
|
|
|
|
|
|
1927
|
|
|
|
|
|
STATIC char * |
1928
|
470855659
|
|
|
|
|
S_skipspace_flags(pTHX_ char *s, U32 flags) |
1929
|
|
|
|
|
|
{ |
1930
|
|
|
|
|
|
#ifdef PERL_MAD |
1931
|
|
|
|
|
|
char *start = s; |
1932
|
|
|
|
|
|
#endif /* PERL_MAD */ |
1933
|
|
|
|
|
|
PERL_ARGS_ASSERT_SKIPSPACE_FLAGS; |
1934
|
|
|
|
|
|
#ifdef PERL_MAD |
1935
|
|
|
|
|
|
if (PL_skipwhite) { |
1936
|
|
|
|
|
|
sv_free(PL_skipwhite); |
1937
|
|
|
|
|
|
PL_skipwhite = NULL; |
1938
|
|
|
|
|
|
} |
1939
|
|
|
|
|
|
#endif /* PERL_MAD */ |
1940
|
470855659
|
100
|
|
|
|
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { |
|
|
100
|
|
|
|
|
1941
|
562
|
50
|
|
|
|
while (s < PL_bufend && SPACE_OR_TAB(*s)) |
|
|
100
|
|
|
|
|
1942
|
144
|
|
|
|
|
s++; |
1943
|
|
|
|
|
|
} else { |
1944
|
470855241
|
|
|
|
|
STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr); |
1945
|
470855241
|
|
|
|
|
PL_bufptr = s; |
1946
|
470855241
|
100
|
|
|
|
lex_read_space(flags | LEX_KEEP_PREVIOUS | |
|
|
50
|
|
|
|
|
1947
|
|
|
|
|
|
(PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ? |
1948
|
|
|
|
|
|
LEX_NO_NEXT_CHUNK : 0)); |
1949
|
470855241
|
|
|
|
|
s = PL_bufptr; |
1950
|
470855241
|
|
|
|
|
PL_bufptr = SvPVX(PL_linestr) + bufptr_pos; |
1951
|
470855241
|
100
|
|
|
|
if (PL_linestart > PL_bufptr) |
1952
|
245610822
|
|
|
|
|
PL_bufptr = PL_linestart; |
1953
|
|
|
|
|
|
return s; |
1954
|
|
|
|
|
|
} |
1955
|
|
|
|
|
|
#ifdef PERL_MAD |
1956
|
|
|
|
|
|
if (PL_madskills) |
1957
|
|
|
|
|
|
PL_skipwhite = newSVpvn(start, s-start); |
1958
|
|
|
|
|
|
#endif /* PERL_MAD */ |
1959
|
|
|
|
|
|
return s; |
1960
|
|
|
|
|
|
} |
1961
|
|
|
|
|
|
|
1962
|
|
|
|
|
|
/* |
1963
|
|
|
|
|
|
* S_check_uni |
1964
|
|
|
|
|
|
* Check the unary operators to ensure there's no ambiguity in how they're |
1965
|
|
|
|
|
|
* used. An ambiguous piece of code would be: |
1966
|
|
|
|
|
|
* rand + 5 |
1967
|
|
|
|
|
|
* This doesn't mean rand() + 5. Because rand() is a unary operator, |
1968
|
|
|
|
|
|
* the +5 is its argument. |
1969
|
|
|
|
|
|
*/ |
1970
|
|
|
|
|
|
|
1971
|
|
|
|
|
|
STATIC void |
1972
|
304762
|
|
|
|
|
S_check_uni(pTHX) |
1973
|
|
|
|
|
|
{ |
1974
|
|
|
|
|
|
dVAR; |
1975
|
|
|
|
|
|
const char *s; |
1976
|
|
|
|
|
|
const char *t; |
1977
|
|
|
|
|
|
|
1978
|
304762
|
100
|
|
|
|
if (PL_oldoldbufptr != PL_last_uni) |
1979
|
|
|
|
|
|
return; |
1980
|
162
|
100
|
|
|
|
while (isSPACE(*PL_last_uni)) |
1981
|
66
|
|
|
|
|
PL_last_uni++; |
1982
|
96
|
|
|
|
|
s = PL_last_uni; |
1983
|
492
|
100
|
|
|
|
while (isWORDCHAR_lazy_if(s,UTF) || *s == '-') |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
1984
|
348
|
|
|
|
|
s++; |
1985
|
96
|
100
|
|
|
|
if ((t = strchr(s, '(')) && t < PL_bufptr) |
|
|
50
|
|
|
|
|
1986
|
|
|
|
|
|
return; |
1987
|
|
|
|
|
|
|
1988
|
173087
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS), |
1989
|
|
|
|
|
|
"Warning: Use of \"%.*s\" without parentheses is ambiguous", |
1990
|
12
|
|
|
|
|
(int)(s - PL_last_uni), PL_last_uni); |
1991
|
|
|
|
|
|
} |
1992
|
|
|
|
|
|
|
1993
|
|
|
|
|
|
/* |
1994
|
|
|
|
|
|
* LOP : macro to build a list operator. Its behaviour has been replaced |
1995
|
|
|
|
|
|
* with a subroutine, S_lop() for which LOP is just another name. |
1996
|
|
|
|
|
|
*/ |
1997
|
|
|
|
|
|
|
1998
|
|
|
|
|
|
#define LOP(f,x) return lop(f,x,s) |
1999
|
|
|
|
|
|
|
2000
|
|
|
|
|
|
/* |
2001
|
|
|
|
|
|
* S_lop |
2002
|
|
|
|
|
|
* Build a list operator (or something that might be one). The rules: |
2003
|
|
|
|
|
|
* - if we have a next token, then it's a list operator [why?] |
2004
|
|
|
|
|
|
* - if the next thing is an opening paren, then it's a function |
2005
|
|
|
|
|
|
* - else it's a list operator |
2006
|
|
|
|
|
|
*/ |
2007
|
|
|
|
|
|
|
2008
|
|
|
|
|
|
STATIC I32 |
2009
|
8624847
|
|
|
|
|
S_lop(pTHX_ I32 f, int x, char *s) |
2010
|
|
|
|
|
|
{ |
2011
|
|
|
|
|
|
dVAR; |
2012
|
|
|
|
|
|
|
2013
|
|
|
|
|
|
PERL_ARGS_ASSERT_LOP; |
2014
|
|
|
|
|
|
|
2015
|
8624847
|
|
|
|
|
pl_yylval.ival = f; |
2016
|
8624847
|
|
|
|
|
CLINE; |
2017
|
8624847
|
|
|
|
|
PL_expect = x; |
2018
|
8624847
|
|
|
|
|
PL_bufptr = s; |
2019
|
8624847
|
|
|
|
|
PL_last_lop = PL_oldbufptr; |
2020
|
8624847
|
|
|
|
|
PL_last_lop_op = (OPCODE)f; |
2021
|
|
|
|
|
|
#ifdef PERL_MAD |
2022
|
|
|
|
|
|
if (PL_lasttoke) |
2023
|
|
|
|
|
|
goto lstop; |
2024
|
|
|
|
|
|
#else |
2025
|
8624847
|
100
|
|
|
|
if (PL_nexttoke) |
2026
|
|
|
|
|
|
goto lstop; |
2027
|
|
|
|
|
|
#endif |
2028
|
8624385
|
100
|
|
|
|
if (*s == '(') |
2029
|
|
|
|
|
|
return REPORT(FUNC); |
2030
|
5827704
|
|
|
|
|
s = PEEKSPACE(s); |
2031
|
5827704
|
100
|
|
|
|
if (*s == '(') |
2032
|
|
|
|
|
|
return REPORT(FUNC); |
2033
|
|
|
|
|
|
else { |
2034
|
|
|
|
|
|
lstop: |
2035
|
5737004
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) |
|
|
100
|
|
|
|
|
2036
|
4507879
|
|
|
|
|
PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; |
2037
|
|
|
|
|
|
return REPORT(LSTOP); |
2038
|
|
|
|
|
|
} |
2039
|
|
|
|
|
|
} |
2040
|
|
|
|
|
|
|
2041
|
|
|
|
|
|
#ifdef PERL_MAD |
2042
|
|
|
|
|
|
/* |
2043
|
|
|
|
|
|
* S_start_force |
2044
|
|
|
|
|
|
* Sets up for an eventual force_next(). start_force(0) basically does |
2045
|
|
|
|
|
|
* an unshift, while start_force(-1) does a push. yylex removes items |
2046
|
|
|
|
|
|
* on the "pop" end. |
2047
|
|
|
|
|
|
*/ |
2048
|
|
|
|
|
|
|
2049
|
|
|
|
|
|
STATIC void |
2050
|
|
|
|
|
|
S_start_force(pTHX_ int where) |
2051
|
|
|
|
|
|
{ |
2052
|
|
|
|
|
|
int i; |
2053
|
|
|
|
|
|
|
2054
|
|
|
|
|
|
if (where < 0) /* so people can duplicate start_force(PL_curforce) */ |
2055
|
|
|
|
|
|
where = PL_lasttoke; |
2056
|
|
|
|
|
|
assert(PL_curforce < 0 || PL_curforce == where); |
2057
|
|
|
|
|
|
if (PL_curforce != where) { |
2058
|
|
|
|
|
|
for (i = PL_lasttoke; i > where; --i) { |
2059
|
|
|
|
|
|
PL_nexttoke[i] = PL_nexttoke[i-1]; |
2060
|
|
|
|
|
|
} |
2061
|
|
|
|
|
|
PL_lasttoke++; |
2062
|
|
|
|
|
|
} |
2063
|
|
|
|
|
|
if (PL_curforce < 0) /* in case of duplicate start_force() */ |
2064
|
|
|
|
|
|
Zero(&PL_nexttoke[where], 1, NEXTTOKE); |
2065
|
|
|
|
|
|
PL_curforce = where; |
2066
|
|
|
|
|
|
if (PL_nextwhite) { |
2067
|
|
|
|
|
|
if (PL_madskills) |
2068
|
|
|
|
|
|
curmad('^', newSVpvs("")); |
2069
|
|
|
|
|
|
CURMAD('_', PL_nextwhite); |
2070
|
|
|
|
|
|
} |
2071
|
|
|
|
|
|
} |
2072
|
|
|
|
|
|
|
2073
|
|
|
|
|
|
STATIC void |
2074
|
|
|
|
|
|
S_curmad(pTHX_ char slot, SV *sv) |
2075
|
|
|
|
|
|
{ |
2076
|
|
|
|
|
|
MADPROP **where; |
2077
|
|
|
|
|
|
|
2078
|
|
|
|
|
|
if (!sv) |
2079
|
|
|
|
|
|
return; |
2080
|
|
|
|
|
|
if (PL_curforce < 0) |
2081
|
|
|
|
|
|
where = &PL_thismad; |
2082
|
|
|
|
|
|
else |
2083
|
|
|
|
|
|
where = &PL_nexttoke[PL_curforce].next_mad; |
2084
|
|
|
|
|
|
|
2085
|
|
|
|
|
|
if (PL_faketokens) |
2086
|
|
|
|
|
|
sv_setpvs(sv, ""); |
2087
|
|
|
|
|
|
else { |
2088
|
|
|
|
|
|
if (!IN_BYTES) { |
2089
|
|
|
|
|
|
if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv))) |
2090
|
|
|
|
|
|
SvUTF8_on(sv); |
2091
|
|
|
|
|
|
else if (PL_encoding) { |
2092
|
|
|
|
|
|
sv_recode_to_utf8(sv, PL_encoding); |
2093
|
|
|
|
|
|
} |
2094
|
|
|
|
|
|
} |
2095
|
|
|
|
|
|
} |
2096
|
|
|
|
|
|
|
2097
|
|
|
|
|
|
/* keep a slot open for the head of the list? */ |
2098
|
|
|
|
|
|
if (slot != '_' && *where && (*where)->mad_key == '^') { |
2099
|
|
|
|
|
|
(*where)->mad_key = slot; |
2100
|
|
|
|
|
|
sv_free(MUTABLE_SV(((*where)->mad_val))); |
2101
|
|
|
|
|
|
(*where)->mad_val = (void*)sv; |
2102
|
|
|
|
|
|
} |
2103
|
|
|
|
|
|
else |
2104
|
|
|
|
|
|
addmad(newMADsv(slot, sv), where, 0); |
2105
|
|
|
|
|
|
} |
2106
|
|
|
|
|
|
#else |
2107
|
|
|
|
|
|
# define start_force(where) NOOP |
2108
|
|
|
|
|
|
# define curmad(slot, sv) NOOP |
2109
|
|
|
|
|
|
#endif |
2110
|
|
|
|
|
|
|
2111
|
|
|
|
|
|
/* |
2112
|
|
|
|
|
|
* S_force_next |
2113
|
|
|
|
|
|
* When the lexer realizes it knows the next token (for instance, |
2114
|
|
|
|
|
|
* it is reordering tokens for the parser) then it can call S_force_next |
2115
|
|
|
|
|
|
* to know what token to return the next time the lexer is called. Caller |
2116
|
|
|
|
|
|
* will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD), |
2117
|
|
|
|
|
|
* and possibly PL_expect to ensure the lexer handles the token correctly. |
2118
|
|
|
|
|
|
*/ |
2119
|
|
|
|
|
|
|
2120
|
|
|
|
|
|
STATIC void |
2121
|
253471872
|
|
|
|
|
S_force_next(pTHX_ I32 type) |
2122
|
|
|
|
|
|
{ |
2123
|
|
|
|
|
|
dVAR; |
2124
|
|
|
|
|
|
#ifdef DEBUGGING |
2125
|
|
|
|
|
|
if (DEBUG_T_TEST) { |
2126
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "### forced token:\n"); |
2127
|
|
|
|
|
|
tokereport(type, &NEXTVAL_NEXTTOKE); |
2128
|
|
|
|
|
|
} |
2129
|
|
|
|
|
|
#endif |
2130
|
|
|
|
|
|
#ifdef PERL_MAD |
2131
|
|
|
|
|
|
if (PL_curforce < 0) |
2132
|
|
|
|
|
|
start_force(PL_lasttoke); |
2133
|
|
|
|
|
|
PL_nexttoke[PL_curforce].next_type = type; |
2134
|
|
|
|
|
|
if (PL_lex_state != LEX_KNOWNEXT) |
2135
|
|
|
|
|
|
PL_lex_defer = PL_lex_state; |
2136
|
|
|
|
|
|
PL_lex_state = LEX_KNOWNEXT; |
2137
|
|
|
|
|
|
PL_lex_expect = PL_expect; |
2138
|
|
|
|
|
|
PL_curforce = -1; |
2139
|
|
|
|
|
|
#else |
2140
|
253471872
|
|
|
|
|
PL_nexttype[PL_nexttoke] = type; |
2141
|
253471872
|
|
|
|
|
PL_nexttoke++; |
2142
|
253471872
|
100
|
|
|
|
if (PL_lex_state != LEX_KNOWNEXT) { |
2143
|
246791240
|
|
|
|
|
PL_lex_defer = PL_lex_state; |
2144
|
246791240
|
|
|
|
|
PL_lex_expect = PL_expect; |
2145
|
246791240
|
|
|
|
|
PL_lex_state = LEX_KNOWNEXT; |
2146
|
|
|
|
|
|
} |
2147
|
|
|
|
|
|
#endif |
2148
|
253471872
|
|
|
|
|
} |
2149
|
|
|
|
|
|
|
2150
|
|
|
|
|
|
void |
2151
|
214
|
|
|
|
|
Perl_yyunlex(pTHX) |
2152
|
|
|
|
|
|
{ |
2153
|
214
|
|
|
|
|
int yyc = PL_parser->yychar; |
2154
|
214
|
100
|
|
|
|
if (yyc != YYEMPTY) { |
2155
|
78
|
50
|
|
|
|
if (yyc) { |
2156
|
|
|
|
|
|
start_force(-1); |
2157
|
78
|
|
|
|
|
NEXTVAL_NEXTTOKE = PL_parser->yylval; |
2158
|
78
|
100
|
|
|
|
if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) { |
|
|
100
|
|
|
|
|
2159
|
8
|
|
|
|
|
PL_lex_allbrackets--; |
2160
|
8
|
|
|
|
|
PL_lex_brackets--; |
2161
|
8
|
|
|
|
|
yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16); |
2162
|
70
|
50
|
|
|
|
} else if (yyc == '('/*)*/) { |
2163
|
0
|
|
|
|
|
PL_lex_allbrackets--; |
2164
|
0
|
|
|
|
|
yyc |= (2<<24); |
2165
|
|
|
|
|
|
} |
2166
|
78
|
|
|
|
|
force_next(yyc); |
2167
|
|
|
|
|
|
} |
2168
|
78
|
|
|
|
|
PL_parser->yychar = YYEMPTY; |
2169
|
|
|
|
|
|
} |
2170
|
214
|
|
|
|
|
} |
2171
|
|
|
|
|
|
|
2172
|
|
|
|
|
|
STATIC SV * |
2173
|
46609495
|
|
|
|
|
S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len) |
2174
|
|
|
|
|
|
{ |
2175
|
|
|
|
|
|
dVAR; |
2176
|
46609495
|
100
|
|
|
|
SV * const sv = newSVpvn_utf8(start, len, |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
2177
|
|
|
|
|
|
!IN_BYTES |
2178
|
|
|
|
|
|
&& UTF |
2179
|
|
|
|
|
|
&& !is_ascii_string((const U8*)start, len) |
2180
|
|
|
|
|
|
&& is_utf8_string((const U8*)start, len)); |
2181
|
46609495
|
|
|
|
|
return sv; |
2182
|
|
|
|
|
|
} |
2183
|
|
|
|
|
|
|
2184
|
|
|
|
|
|
/* |
2185
|
|
|
|
|
|
* S_force_word |
2186
|
|
|
|
|
|
* When the lexer knows the next thing is a word (for instance, it has |
2187
|
|
|
|
|
|
* just seen -> and it knows that the next char is a word char, then |
2188
|
|
|
|
|
|
* it calls S_force_word to stick the next word into the PL_nexttoke/val |
2189
|
|
|
|
|
|
* lookahead. |
2190
|
|
|
|
|
|
* |
2191
|
|
|
|
|
|
* Arguments: |
2192
|
|
|
|
|
|
* char *start : buffer position (must be within PL_linestr) |
2193
|
|
|
|
|
|
* int token : PL_next* will be this type of bare word (e.g., METHOD,WORD) |
2194
|
|
|
|
|
|
* int check_keyword : if true, Perl checks to make sure the word isn't |
2195
|
|
|
|
|
|
* a keyword (do this if the word is a label, e.g. goto FOO) |
2196
|
|
|
|
|
|
* int allow_pack : if true, : characters will also be allowed (require, |
2197
|
|
|
|
|
|
* use, etc. do this) |
2198
|
|
|
|
|
|
* int allow_initial_tick : used by the "sub" lexer only. |
2199
|
|
|
|
|
|
*/ |
2200
|
|
|
|
|
|
|
2201
|
|
|
|
|
|
STATIC char * |
2202
|
29956093
|
|
|
|
|
S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack) |
2203
|
|
|
|
|
|
{ |
2204
|
|
|
|
|
|
dVAR; |
2205
|
|
|
|
|
|
char *s; |
2206
|
|
|
|
|
|
STRLEN len; |
2207
|
|
|
|
|
|
|
2208
|
|
|
|
|
|
PERL_ARGS_ASSERT_FORCE_WORD; |
2209
|
|
|
|
|
|
|
2210
|
29956093
|
|
|
|
|
start = SKIPSPACE1(start); |
2211
|
|
|
|
|
|
s = start; |
2212
|
29956093
|
100
|
|
|
|
if (isIDFIRST_lazy_if(s,UTF) || |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2213
|
125237
|
100
|
|
|
|
(allow_pack && *s == ':') ) |
2214
|
|
|
|
|
|
{ |
2215
|
28983389
|
|
|
|
|
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len); |
2216
|
28983389
|
100
|
|
|
|
if (check_keyword) { |
2217
|
2490986
|
|
|
|
|
char *s2 = PL_tokenbuf; |
2218
|
2490986
|
100
|
|
|
|
if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6)) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2219
|
4
|
|
|
|
|
s2 += 6, len -= 6; |
2220
|
2490986
|
100
|
|
|
|
if (keyword(s2, len, 0)) |
2221
|
|
|
|
|
|
return start; |
2222
|
|
|
|
|
|
} |
2223
|
|
|
|
|
|
start_force(PL_curforce); |
2224
|
|
|
|
|
|
if (PL_madskills) |
2225
|
|
|
|
|
|
curmad('X', newSVpvn(start,s-start)); |
2226
|
28004531
|
100
|
|
|
|
if (token == METHOD) { |
2227
|
12627485
|
|
|
|
|
s = SKIPSPACE1(s); |
2228
|
12627485
|
100
|
|
|
|
if (*s == '(') |
2229
|
6208113
|
|
|
|
|
PL_expect = XTERM; |
2230
|
|
|
|
|
|
else { |
2231
|
6419372
|
|
|
|
|
PL_expect = XOPERATOR; |
2232
|
|
|
|
|
|
} |
2233
|
|
|
|
|
|
} |
2234
|
|
|
|
|
|
if (PL_madskills) |
2235
|
|
|
|
|
|
curmad('g', newSVpvs( "forced" )); |
2236
|
28004531
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval |
2237
|
28004531
|
|
|
|
|
= (OP*)newSVOP(OP_CONST,0, |
2238
|
|
|
|
|
|
S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len)); |
2239
|
28004531
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE; |
2240
|
28004531
|
|
|
|
|
force_next(token); |
2241
|
|
|
|
|
|
} |
2242
|
29484303
|
|
|
|
|
return s; |
2243
|
|
|
|
|
|
} |
2244
|
|
|
|
|
|
|
2245
|
|
|
|
|
|
/* |
2246
|
|
|
|
|
|
* S_force_ident |
2247
|
|
|
|
|
|
* Called when the lexer wants $foo *foo &foo etc, but the program |
2248
|
|
|
|
|
|
* text only contains the "foo" portion. The first argument is a pointer |
2249
|
|
|
|
|
|
* to the "foo", and the second argument is the type symbol to prefix. |
2250
|
|
|
|
|
|
* Forces the next token to be a "WORD". |
2251
|
|
|
|
|
|
* Creates the symbol if it didn't already exist (via gv_fetchpv()). |
2252
|
|
|
|
|
|
*/ |
2253
|
|
|
|
|
|
|
2254
|
|
|
|
|
|
STATIC void |
2255
|
1802178
|
|
|
|
|
S_force_ident(pTHX_ const char *s, int kind) |
2256
|
|
|
|
|
|
{ |
2257
|
|
|
|
|
|
dVAR; |
2258
|
|
|
|
|
|
|
2259
|
|
|
|
|
|
PERL_ARGS_ASSERT_FORCE_IDENT; |
2260
|
|
|
|
|
|
|
2261
|
1802178
|
100
|
|
|
|
if (s[0]) { |
2262
|
1080726
|
100
|
|
|
|
const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */ |
2263
|
1080726
|
50
|
|
|
|
OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len, |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2264
|
|
|
|
|
|
UTF ? SVf_UTF8 : 0)); |
2265
|
|
|
|
|
|
start_force(PL_curforce); |
2266
|
1080726
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval = o; |
2267
|
1080726
|
|
|
|
|
force_next(WORD); |
2268
|
1080726
|
50
|
|
|
|
if (kind) { |
2269
|
1080726
|
|
|
|
|
o->op_private = OPpCONST_ENTERED; |
2270
|
|
|
|
|
|
/* XXX see note in pp_entereval() for why we forgo typo |
2271
|
|
|
|
|
|
warnings if the symbol must be introduced in an eval. |
2272
|
|
|
|
|
|
GSAR 96-10-12 */ |
2273
|
1080726
|
100
|
|
|
|
gv_fetchpvn_flags(s, len, |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2274
|
|
|
|
|
|
(PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) |
2275
|
|
|
|
|
|
: GV_ADD) | ( UTF ? SVf_UTF8 : 0 ), |
2276
|
|
|
|
|
|
kind == '$' ? SVt_PV : |
2277
|
|
|
|
|
|
kind == '@' ? SVt_PVAV : |
2278
|
|
|
|
|
|
kind == '%' ? SVt_PVHV : |
2279
|
|
|
|
|
|
SVt_PVGV |
2280
|
|
|
|
|
|
); |
2281
|
|
|
|
|
|
} |
2282
|
|
|
|
|
|
} |
2283
|
1802178
|
|
|
|
|
} |
2284
|
|
|
|
|
|
|
2285
|
|
|
|
|
|
static void |
2286
|
142444391
|
|
|
|
|
S_force_ident_maybe_lex(pTHX_ char pit) |
2287
|
|
|
|
|
|
{ |
2288
|
|
|
|
|
|
start_force(PL_curforce); |
2289
|
142444391
|
|
|
|
|
NEXTVAL_NEXTTOKE.ival = pit; |
2290
|
142444391
|
|
|
|
|
force_next('p'); |
2291
|
142444391
|
|
|
|
|
} |
2292
|
|
|
|
|
|
|
2293
|
|
|
|
|
|
NV |
2294
|
552
|
|
|
|
|
Perl_str_to_version(pTHX_ SV *sv) |
2295
|
|
|
|
|
|
{ |
2296
|
|
|
|
|
|
NV retval = 0.0; |
2297
|
|
|
|
|
|
NV nshift = 1.0; |
2298
|
|
|
|
|
|
STRLEN len; |
2299
|
552
|
50
|
|
|
|
const char *start = SvPV_const(sv,len); |
2300
|
552
|
|
|
|
|
const char * const end = start + len; |
2301
|
552
|
|
|
|
|
const bool utf = SvUTF8(sv) ? TRUE : FALSE; |
2302
|
|
|
|
|
|
|
2303
|
|
|
|
|
|
PERL_ARGS_ASSERT_STR_TO_VERSION; |
2304
|
|
|
|
|
|
|
2305
|
2270
|
100
|
|
|
|
while (start < end) { |
2306
|
|
|
|
|
|
STRLEN skip; |
2307
|
|
|
|
|
|
UV n; |
2308
|
1622
|
100
|
|
|
|
if (utf) |
2309
|
36
|
|
|
|
|
n = utf8n_to_uvchr((U8*)start, len, &skip, 0); |
2310
|
|
|
|
|
|
else { |
2311
|
1586
|
|
|
|
|
n = *(U8*)start; |
2312
|
1586
|
|
|
|
|
skip = 1; |
2313
|
|
|
|
|
|
} |
2314
|
1622
|
|
|
|
|
retval += ((NV)n)/nshift; |
2315
|
1622
|
|
|
|
|
start += skip; |
2316
|
1622
|
|
|
|
|
nshift *= 1000; |
2317
|
|
|
|
|
|
} |
2318
|
552
|
|
|
|
|
return retval; |
2319
|
|
|
|
|
|
} |
2320
|
|
|
|
|
|
|
2321
|
|
|
|
|
|
/* |
2322
|
|
|
|
|
|
* S_force_version |
2323
|
|
|
|
|
|
* Forces the next token to be a version number. |
2324
|
|
|
|
|
|
* If the next token appears to be an invalid version number, (e.g. "v2b"), |
2325
|
|
|
|
|
|
* and if "guessing" is TRUE, then no new token is created (and the caller |
2326
|
|
|
|
|
|
* must use an alternative parsing method). |
2327
|
|
|
|
|
|
*/ |
2328
|
|
|
|
|
|
|
2329
|
|
|
|
|
|
STATIC char * |
2330
|
4697200
|
|
|
|
|
S_force_version(pTHX_ char *s, int guessing) |
2331
|
|
|
|
|
|
{ |
2332
|
|
|
|
|
|
dVAR; |
2333
|
|
|
|
|
|
OP *version = NULL; |
2334
|
|
|
|
|
|
char *d; |
2335
|
|
|
|
|
|
#ifdef PERL_MAD |
2336
|
|
|
|
|
|
I32 startoff = s - SvPVX(PL_linestr); |
2337
|
|
|
|
|
|
#endif |
2338
|
|
|
|
|
|
|
2339
|
|
|
|
|
|
PERL_ARGS_ASSERT_FORCE_VERSION; |
2340
|
|
|
|
|
|
|
2341
|
4697200
|
|
|
|
|
s = SKIPSPACE1(s); |
2342
|
|
|
|
|
|
|
2343
|
|
|
|
|
|
d = s; |
2344
|
4697200
|
100
|
|
|
|
if (*d == 'v') |
2345
|
148
|
|
|
|
|
d++; |
2346
|
4697200
|
100
|
|
|
|
if (isDIGIT(*d)) { |
2347
|
1218624
|
100
|
|
|
|
while (isDIGIT(*d) || *d == '_' || *d == '.') |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2348
|
1030870
|
|
|
|
|
d++; |
2349
|
|
|
|
|
|
#ifdef PERL_MAD |
2350
|
|
|
|
|
|
if (PL_madskills) { |
2351
|
|
|
|
|
|
start_force(PL_curforce); |
2352
|
|
|
|
|
|
curmad('X', newSVpvn(s,d-s)); |
2353
|
|
|
|
|
|
} |
2354
|
|
|
|
|
|
#endif |
2355
|
187754
|
100
|
|
|
|
if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
2356
|
|
|
|
|
|
SV *ver; |
2357
|
|
|
|
|
|
#ifdef USE_LOCALE_NUMERIC |
2358
|
187720
|
|
|
|
|
char *loc = savepv(setlocale(LC_NUMERIC, NULL)); |
2359
|
187720
|
|
|
|
|
setlocale(LC_NUMERIC, "C"); |
2360
|
|
|
|
|
|
#endif |
2361
|
187720
|
|
|
|
|
s = scan_num(s, &pl_yylval); |
2362
|
|
|
|
|
|
#ifdef USE_LOCALE_NUMERIC |
2363
|
187720
|
|
|
|
|
setlocale(LC_NUMERIC, loc); |
2364
|
187720
|
|
|
|
|
Safefree(loc); |
2365
|
|
|
|
|
|
#endif |
2366
|
187720
|
|
|
|
|
version = pl_yylval.opval; |
2367
|
187720
|
|
|
|
|
ver = cSVOPx(version)->op_sv; |
2368
|
187816
|
100
|
|
|
|
if (SvPOK(ver) && !SvNIOK(ver)) { |
|
|
50
|
|
|
|
|
2369
|
96
|
|
|
|
|
SvUPGRADE(ver, SVt_PVNV); |
2370
|
552
|
|
|
|
|
SvNV_set(ver, str_to_version(ver)); |
2371
|
552
|
|
|
|
|
SvNOK_on(ver); /* hint that it is a version */ |
2372
|
|
|
|
|
|
} |
2373
|
|
|
|
|
|
} |
2374
|
34
|
50
|
|
|
|
else if (guessing) { |
2375
|
|
|
|
|
|
#ifdef PERL_MAD |
2376
|
|
|
|
|
|
if (PL_madskills) { |
2377
|
|
|
|
|
|
sv_free(PL_nextwhite); /* let next token collect whitespace */ |
2378
|
|
|
|
|
|
PL_nextwhite = 0; |
2379
|
|
|
|
|
|
s = SvPVX(PL_linestr) + startoff; |
2380
|
|
|
|
|
|
} |
2381
|
|
|
|
|
|
#endif |
2382
|
|
|
|
|
|
return s; |
2383
|
|
|
|
|
|
} |
2384
|
|
|
|
|
|
} |
2385
|
|
|
|
|
|
|
2386
|
|
|
|
|
|
#ifdef PERL_MAD |
2387
|
|
|
|
|
|
if (PL_madskills && !version) { |
2388
|
|
|
|
|
|
sv_free(PL_nextwhite); /* let next token collect whitespace */ |
2389
|
|
|
|
|
|
PL_nextwhite = 0; |
2390
|
|
|
|
|
|
s = SvPVX(PL_linestr) + startoff; |
2391
|
|
|
|
|
|
} |
2392
|
|
|
|
|
|
#endif |
2393
|
|
|
|
|
|
/* NOTE: The parser sees the package name and the VERSION swapped */ |
2394
|
|
|
|
|
|
start_force(PL_curforce); |
2395
|
4697200
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval = version; |
2396
|
4697200
|
|
|
|
|
force_next(WORD); |
2397
|
|
|
|
|
|
|
2398
|
4697200
|
|
|
|
|
return s; |
2399
|
|
|
|
|
|
} |
2400
|
|
|
|
|
|
|
2401
|
|
|
|
|
|
/* |
2402
|
|
|
|
|
|
* S_force_strict_version |
2403
|
|
|
|
|
|
* Forces the next token to be a version number using strict syntax rules. |
2404
|
|
|
|
|
|
*/ |
2405
|
|
|
|
|
|
|
2406
|
|
|
|
|
|
STATIC char * |
2407
|
700686
|
|
|
|
|
S_force_strict_version(pTHX_ char *s) |
2408
|
|
|
|
|
|
{ |
2409
|
|
|
|
|
|
dVAR; |
2410
|
|
|
|
|
|
OP *version = NULL; |
2411
|
|
|
|
|
|
#ifdef PERL_MAD |
2412
|
|
|
|
|
|
I32 startoff = s - SvPVX(PL_linestr); |
2413
|
|
|
|
|
|
#endif |
2414
|
700686
|
|
|
|
|
const char *errstr = NULL; |
2415
|
|
|
|
|
|
|
2416
|
|
|
|
|
|
PERL_ARGS_ASSERT_FORCE_STRICT_VERSION; |
2417
|
|
|
|
|
|
|
2418
|
1037351
|
50
|
|
|
|
while (isSPACE(*s)) /* leading whitespace */ |
2419
|
0
|
|
|
|
|
s++; |
2420
|
|
|
|
|
|
|
2421
|
700686
|
100
|
|
|
|
if (is_STRICT_VERSION(s,&errstr)) { |
2422
|
88
|
|
|
|
|
SV *ver = newSV(0); |
2423
|
88
|
|
|
|
|
s = (char *)scan_version(s, ver, 0); |
2424
|
88
|
|
|
|
|
version = newSVOP(OP_CONST, 0, ver); |
2425
|
|
|
|
|
|
} |
2426
|
700854
|
100
|
|
|
|
else if ( (*s != ';' && *s != '{' && *s != '}' ) && |
|
|
50
|
|
|
|
|
2427
|
256
|
50
|
|
|
|
(s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' ))) |
2428
|
|
|
|
|
|
{ |
2429
|
128
|
|
|
|
|
PL_bufptr = s; |
2430
|
128
|
50
|
|
|
|
if (errstr) |
2431
|
128
|
|
|
|
|
yyerror(errstr); /* version required */ |
2432
|
|
|
|
|
|
return s; |
2433
|
|
|
|
|
|
} |
2434
|
|
|
|
|
|
|
2435
|
|
|
|
|
|
#ifdef PERL_MAD |
2436
|
|
|
|
|
|
if (PL_madskills && !version) { |
2437
|
|
|
|
|
|
sv_free(PL_nextwhite); /* let next token collect whitespace */ |
2438
|
|
|
|
|
|
PL_nextwhite = 0; |
2439
|
|
|
|
|
|
s = SvPVX(PL_linestr) + startoff; |
2440
|
|
|
|
|
|
} |
2441
|
|
|
|
|
|
#endif |
2442
|
|
|
|
|
|
/* NOTE: The parser sees the package name and the VERSION swapped */ |
2443
|
|
|
|
|
|
start_force(PL_curforce); |
2444
|
700558
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval = version; |
2445
|
700558
|
|
|
|
|
force_next(WORD); |
2446
|
|
|
|
|
|
|
2447
|
700622
|
|
|
|
|
return s; |
2448
|
|
|
|
|
|
} |
2449
|
|
|
|
|
|
|
2450
|
|
|
|
|
|
/* |
2451
|
|
|
|
|
|
* S_tokeq |
2452
|
|
|
|
|
|
* Tokenize a quoted string passed in as an SV. It finds the next |
2453
|
|
|
|
|
|
* chunk, up to end of string or a backslash. It may make a new |
2454
|
|
|
|
|
|
* SV containing that chunk (if HINT_NEW_STRING is on). It also |
2455
|
|
|
|
|
|
* turns \\ into \. |
2456
|
|
|
|
|
|
*/ |
2457
|
|
|
|
|
|
|
2458
|
|
|
|
|
|
STATIC SV * |
2459
|
46589553
|
|
|
|
|
S_tokeq(pTHX_ SV *sv) |
2460
|
|
|
|
|
|
{ |
2461
|
|
|
|
|
|
dVAR; |
2462
|
|
|
|
|
|
char *s; |
2463
|
|
|
|
|
|
char *send; |
2464
|
|
|
|
|
|
char *d; |
2465
|
46589553
|
|
|
|
|
STRLEN len = 0; |
2466
|
|
|
|
|
|
SV *pv = sv; |
2467
|
|
|
|
|
|
|
2468
|
|
|
|
|
|
PERL_ARGS_ASSERT_TOKEQ; |
2469
|
|
|
|
|
|
|
2470
|
46589553
|
50
|
|
|
|
if (!SvLEN(sv)) |
2471
|
|
|
|
|
|
goto finish; |
2472
|
|
|
|
|
|
|
2473
|
46589553
|
50
|
|
|
|
s = SvPV_force(sv, len); |
2474
|
46589553
|
100
|
|
|
|
if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) |
|
|
100
|
|
|
|
|
2475
|
|
|
|
|
|
goto finish; |
2476
|
46367387
|
|
|
|
|
send = s + len; |
2477
|
|
|
|
|
|
/* This is relying on the SV being "well formed" with a trailing '\0' */ |
2478
|
443066293
|
100
|
|
|
|
while (s < send && !(*s == '\\' && s[1] == '\\')) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2479
|
374216179
|
|
|
|
|
s++; |
2480
|
46367387
|
100
|
|
|
|
if (s == send) |
2481
|
|
|
|
|
|
goto finish; |
2482
|
|
|
|
|
|
d = s; |
2483
|
208390
|
50
|
|
|
|
if ( PL_hints & HINT_NEW_STRING ) { |
2484
|
107255
|
|
|
|
|
pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv)); |
2485
|
|
|
|
|
|
} |
2486
|
1425704
|
100
|
|
|
|
while (s < send) { |
2487
|
1217314
|
100
|
|
|
|
if (*s == '\\') { |
2488
|
253070
|
50
|
|
|
|
if (s + 1 < send && (s[1] == '\\')) |
|
|
100
|
|
|
|
|
2489
|
231280
|
|
|
|
|
s++; /* all that, just for this */ |
2490
|
|
|
|
|
|
} |
2491
|
1217314
|
|
|
|
|
*d++ = *s++; |
2492
|
|
|
|
|
|
} |
2493
|
208390
|
|
|
|
|
*d = '\0'; |
2494
|
208390
|
|
|
|
|
SvCUR_set(sv, d - SvPVX_const(sv)); |
2495
|
|
|
|
|
|
finish: |
2496
|
46589553
|
100
|
|
|
|
if ( PL_hints & HINT_NEW_STRING ) |
2497
|
23996463
|
|
|
|
|
return new_constant(NULL, 0, "q", sv, pv, "q", 1); |
2498
|
|
|
|
|
|
return sv; |
2499
|
|
|
|
|
|
} |
2500
|
|
|
|
|
|
|
2501
|
|
|
|
|
|
/* |
2502
|
|
|
|
|
|
* Now come three functions related to double-quote context, |
2503
|
|
|
|
|
|
* S_sublex_start, S_sublex_push, and S_sublex_done. They're used when |
2504
|
|
|
|
|
|
* converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They |
2505
|
|
|
|
|
|
* interact with PL_lex_state, and create fake ( ... ) argument lists |
2506
|
|
|
|
|
|
* to handle functions and concatenation. |
2507
|
|
|
|
|
|
* For example, |
2508
|
|
|
|
|
|
* "foo\lbar" |
2509
|
|
|
|
|
|
* is tokenised as |
2510
|
|
|
|
|
|
* stringify ( const[foo] concat lcfirst ( const[bar] ) ) |
2511
|
|
|
|
|
|
*/ |
2512
|
|
|
|
|
|
|
2513
|
|
|
|
|
|
/* |
2514
|
|
|
|
|
|
* S_sublex_start |
2515
|
|
|
|
|
|
* Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST). |
2516
|
|
|
|
|
|
* |
2517
|
|
|
|
|
|
* Pattern matching will set PL_lex_op to the pattern-matching op to |
2518
|
|
|
|
|
|
* make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise). |
2519
|
|
|
|
|
|
* |
2520
|
|
|
|
|
|
* OP_CONST and OP_READLINE are easy--just make the new op and return. |
2521
|
|
|
|
|
|
* |
2522
|
|
|
|
|
|
* Everything else becomes a FUNC. |
2523
|
|
|
|
|
|
* |
2524
|
|
|
|
|
|
* Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we |
2525
|
|
|
|
|
|
* had an OP_CONST or OP_READLINE). This just sets us up for a |
2526
|
|
|
|
|
|
* call to S_sublex_push(). |
2527
|
|
|
|
|
|
*/ |
2528
|
|
|
|
|
|
|
2529
|
|
|
|
|
|
STATIC I32 |
2530
|
53038691
|
|
|
|
|
S_sublex_start(pTHX) |
2531
|
|
|
|
|
|
{ |
2532
|
|
|
|
|
|
dVAR; |
2533
|
53038691
|
|
|
|
|
const I32 op_type = pl_yylval.ival; |
2534
|
|
|
|
|
|
|
2535
|
53038691
|
100
|
|
|
|
if (op_type == OP_NULL) { |
2536
|
90680
|
|
|
|
|
pl_yylval.opval = PL_lex_op; |
2537
|
90680
|
|
|
|
|
PL_lex_op = NULL; |
2538
|
90680
|
|
|
|
|
return THING; |
2539
|
|
|
|
|
|
} |
2540
|
52948011
|
100
|
|
|
|
if (op_type == OP_CONST || op_type == OP_READLINE) { |
2541
|
37751218
|
|
|
|
|
SV *sv = tokeq(PL_lex_stuff); |
2542
|
|
|
|
|
|
|
2543
|
37751218
|
100
|
|
|
|
if (SvTYPE(sv) == SVt_PVIV) { |
2544
|
|
|
|
|
|
/* Overloaded constants, nothing fancy: Convert to SVt_PV: */ |
2545
|
|
|
|
|
|
STRLEN len; |
2546
|
37751216
|
50
|
|
|
|
const char * const p = SvPV_const(sv, len); |
2547
|
37751216
|
|
|
|
|
SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv)); |
2548
|
37751216
|
|
|
|
|
SvREFCNT_dec(sv); |
2549
|
|
|
|
|
|
sv = nsv; |
2550
|
|
|
|
|
|
} |
2551
|
37751218
|
|
|
|
|
pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv); |
2552
|
37751218
|
|
|
|
|
PL_lex_stuff = NULL; |
2553
|
|
|
|
|
|
/* Allow // "foo" */ |
2554
|
37751218
|
50
|
|
|
|
if (op_type == OP_READLINE) |
2555
|
0
|
|
|
|
|
PL_expect = XTERMORDORDOR; |
2556
|
|
|
|
|
|
return THING; |
2557
|
|
|
|
|
|
} |
2558
|
15196793
|
100
|
|
|
|
else if (op_type == OP_BACKTICK && PL_lex_op) { |
|
|
100
|
|
|
|
|
2559
|
|
|
|
|
|
/* readpipe() was overridden */ |
2560
|
8
|
|
|
|
|
cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff); |
2561
|
8
|
|
|
|
|
pl_yylval.opval = PL_lex_op; |
2562
|
8
|
|
|
|
|
PL_lex_op = NULL; |
2563
|
8
|
|
|
|
|
PL_lex_stuff = NULL; |
2564
|
8
|
|
|
|
|
return THING; |
2565
|
|
|
|
|
|
} |
2566
|
|
|
|
|
|
|
2567
|
15196785
|
|
|
|
|
PL_sublex_info.super_state = PL_lex_state; |
2568
|
15196785
|
|
|
|
|
PL_sublex_info.sub_inwhat = (U16)op_type; |
2569
|
15196785
|
|
|
|
|
PL_sublex_info.sub_op = PL_lex_op; |
2570
|
15196785
|
|
|
|
|
PL_lex_state = LEX_INTERPPUSH; |
2571
|
|
|
|
|
|
|
2572
|
15196785
|
|
|
|
|
PL_expect = XTERM; |
2573
|
15196785
|
100
|
|
|
|
if (PL_lex_op) { |
2574
|
4846039
|
|
|
|
|
pl_yylval.opval = PL_lex_op; |
2575
|
4846039
|
|
|
|
|
PL_lex_op = NULL; |
2576
|
29691837
|
|
|
|
|
return PMFUNC; |
2577
|
|
|
|
|
|
} |
2578
|
|
|
|
|
|
else |
2579
|
|
|
|
|
|
return FUNC; |
2580
|
|
|
|
|
|
} |
2581
|
|
|
|
|
|
|
2582
|
|
|
|
|
|
/* |
2583
|
|
|
|
|
|
* S_sublex_push |
2584
|
|
|
|
|
|
* Create a new scope to save the lexing state. The scope will be |
2585
|
|
|
|
|
|
* ended in S_sublex_done. Returns a '(', starting the function arguments |
2586
|
|
|
|
|
|
* to the uc, lc, etc. found before. |
2587
|
|
|
|
|
|
* Sets PL_lex_state to LEX_INTERPCONCAT. |
2588
|
|
|
|
|
|
*/ |
2589
|
|
|
|
|
|
|
2590
|
|
|
|
|
|
STATIC I32 |
2591
|
15196785
|
|
|
|
|
S_sublex_push(pTHX) |
2592
|
|
|
|
|
|
{ |
2593
|
|
|
|
|
|
dVAR; |
2594
|
|
|
|
|
|
LEXSHARED *shared; |
2595
|
15196785
|
|
|
|
|
const bool is_heredoc = |
2596
|
15196785
|
|
|
|
|
CopLINE(PL_curcop) == (line_t)PL_multi_start - 1; |
2597
|
15196785
|
|
|
|
|
ENTER; |
2598
|
|
|
|
|
|
|
2599
|
|
|
|
|
|
assert(CopLINE(PL_curcop) == (line_t)PL_multi_start |
2600
|
|
|
|
|
|
|| CopLINE(PL_curcop) == (line_t)PL_multi_start - 1); |
2601
|
|
|
|
|
|
|
2602
|
15196785
|
|
|
|
|
PL_lex_state = PL_sublex_info.super_state; |
2603
|
15196785
|
|
|
|
|
SAVEBOOL(PL_lex_dojoin); |
2604
|
15196785
|
|
|
|
|
SAVEI32(PL_lex_brackets); |
2605
|
15196785
|
|
|
|
|
SAVEI32(PL_lex_allbrackets); |
2606
|
15196785
|
|
|
|
|
SAVEI32(PL_lex_formbrack); |
2607
|
15196785
|
|
|
|
|
SAVEI8(PL_lex_fakeeof); |
2608
|
15196785
|
|
|
|
|
SAVEI32(PL_lex_casemods); |
2609
|
15196785
|
|
|
|
|
SAVEI32(PL_lex_starts); |
2610
|
15196785
|
|
|
|
|
SAVEI8(PL_lex_state); |
2611
|
15196785
|
|
|
|
|
SAVESPTR(PL_lex_repl); |
2612
|
15196785
|
|
|
|
|
SAVEVPTR(PL_lex_inpat); |
2613
|
15196785
|
|
|
|
|
SAVEI16(PL_lex_inwhat); |
2614
|
15196785
|
100
|
|
|
|
if (is_heredoc) |
2615
|
134157
|
|
|
|
|
SAVECOPLINE(PL_curcop); |
2616
|
15196785
|
|
|
|
|
SAVEPPTR(PL_bufptr); |
2617
|
15196785
|
|
|
|
|
SAVEPPTR(PL_bufend); |
2618
|
15196785
|
|
|
|
|
SAVEPPTR(PL_oldbufptr); |
2619
|
15196785
|
|
|
|
|
SAVEPPTR(PL_oldoldbufptr); |
2620
|
15196785
|
|
|
|
|
SAVEPPTR(PL_last_lop); |
2621
|
15196785
|
|
|
|
|
SAVEPPTR(PL_last_uni); |
2622
|
15196785
|
|
|
|
|
SAVEPPTR(PL_linestart); |
2623
|
15196785
|
|
|
|
|
SAVESPTR(PL_linestr); |
2624
|
15196785
|
|
|
|
|
SAVEGENERICPV(PL_lex_brackstack); |
2625
|
15196785
|
|
|
|
|
SAVEGENERICPV(PL_lex_casestack); |
2626
|
15196785
|
|
|
|
|
SAVEGENERICPV(PL_parser->lex_shared); |
2627
|
15196785
|
|
|
|
|
SAVEBOOL(PL_parser->lex_re_reparsing); |
2628
|
15196785
|
|
|
|
|
SAVEI32(PL_copline); |
2629
|
|
|
|
|
|
|
2630
|
|
|
|
|
|
/* The here-doc parser needs to be able to peek into outer lexing |
2631
|
|
|
|
|
|
scopes to find the body of the here-doc. So we put PL_linestr and |
2632
|
|
|
|
|
|
PL_bufptr into lex_shared, to ‘share’ those values. |
2633
|
|
|
|
|
|
*/ |
2634
|
15196785
|
|
|
|
|
PL_parser->lex_shared->ls_linestr = PL_linestr; |
2635
|
15196785
|
|
|
|
|
PL_parser->lex_shared->ls_bufptr = PL_bufptr; |
2636
|
|
|
|
|
|
|
2637
|
15196785
|
|
|
|
|
PL_linestr = PL_lex_stuff; |
2638
|
15196785
|
|
|
|
|
PL_lex_repl = PL_sublex_info.repl; |
2639
|
15196785
|
|
|
|
|
PL_lex_stuff = NULL; |
2640
|
15196785
|
|
|
|
|
PL_sublex_info.repl = NULL; |
2641
|
|
|
|
|
|
|
2642
|
15196785
|
|
|
|
|
PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart |
2643
|
15196785
|
|
|
|
|
= SvPVX(PL_linestr); |
2644
|
15196785
|
|
|
|
|
PL_bufend += SvCUR(PL_linestr); |
2645
|
15196785
|
|
|
|
|
PL_last_lop = PL_last_uni = NULL; |
2646
|
15196785
|
|
|
|
|
SAVEFREESV(PL_linestr); |
2647
|
15196785
|
100
|
|
|
|
if (PL_lex_repl) SAVEFREESV(PL_lex_repl); |
2648
|
|
|
|
|
|
|
2649
|
15196785
|
|
|
|
|
PL_lex_dojoin = FALSE; |
2650
|
15196785
|
|
|
|
|
PL_lex_brackets = PL_lex_formbrack = 0; |
2651
|
15196785
|
|
|
|
|
PL_lex_allbrackets = 0; |
2652
|
15196785
|
|
|
|
|
PL_lex_fakeeof = LEX_FAKEEOF_NEVER; |
2653
|
15196785
|
|
|
|
|
Newx(PL_lex_brackstack, 120, char); |
2654
|
15196785
|
|
|
|
|
Newx(PL_lex_casestack, 12, char); |
2655
|
15196785
|
|
|
|
|
PL_lex_casemods = 0; |
2656
|
15196785
|
|
|
|
|
*PL_lex_casestack = '\0'; |
2657
|
15196785
|
|
|
|
|
PL_lex_starts = 0; |
2658
|
15196785
|
|
|
|
|
PL_lex_state = LEX_INTERPCONCAT; |
2659
|
15196785
|
100
|
|
|
|
if (is_heredoc) |
2660
|
134157
|
|
|
|
|
CopLINE_inc(PL_curcop); |
2661
|
15196785
|
|
|
|
|
PL_copline = NOLINE; |
2662
|
|
|
|
|
|
|
2663
|
15196785
|
|
|
|
|
Newxz(shared, 1, LEXSHARED); |
2664
|
15196785
|
|
|
|
|
shared->ls_prev = PL_parser->lex_shared; |
2665
|
15196785
|
|
|
|
|
PL_parser->lex_shared = shared; |
2666
|
15196785
|
100
|
|
|
|
if (!is_heredoc && PL_multi_start != PL_multi_end) { |
|
|
100
|
|
|
|
|
2667
|
282217
|
|
|
|
|
shared->herelines = shared->ls_prev->herelines; |
2668
|
282217
|
|
|
|
|
shared->ls_prev->herelines = 0; |
2669
|
|
|
|
|
|
} |
2670
|
|
|
|
|
|
|
2671
|
15196785
|
|
|
|
|
PL_lex_inwhat = PL_sublex_info.sub_inwhat; |
2672
|
15196785
|
100
|
|
|
|
if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS; |
2673
|
15196785
|
100
|
|
|
|
if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST) |
2674
|
4736789
|
|
|
|
|
PL_lex_inpat = PL_sublex_info.sub_op; |
2675
|
|
|
|
|
|
else |
2676
|
10459996
|
|
|
|
|
PL_lex_inpat = NULL; |
2677
|
|
|
|
|
|
|
2678
|
15196785
|
|
|
|
|
PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING); |
2679
|
15196785
|
|
|
|
|
PL_in_eval &= ~EVAL_RE_REPARSING; |
2680
|
|
|
|
|
|
|
2681
|
15196785
|
|
|
|
|
return '('; |
2682
|
|
|
|
|
|
} |
2683
|
|
|
|
|
|
|
2684
|
|
|
|
|
|
/* |
2685
|
|
|
|
|
|
* S_sublex_done |
2686
|
|
|
|
|
|
* Restores lexer state after a S_sublex_push. |
2687
|
|
|
|
|
|
*/ |
2688
|
|
|
|
|
|
|
2689
|
|
|
|
|
|
STATIC I32 |
2690
|
17555602
|
|
|
|
|
S_sublex_done(pTHX) |
2691
|
|
|
|
|
|
{ |
2692
|
|
|
|
|
|
dVAR; |
2693
|
17555602
|
100
|
|
|
|
if (!PL_lex_starts++) { |
2694
|
730414
|
|
|
|
|
SV * const sv = newSVpvs(""); |
2695
|
730414
|
100
|
|
|
|
if (SvUTF8(PL_linestr)) |
2696
|
2
|
|
|
|
|
SvUTF8_on(sv); |
2697
|
730414
|
|
|
|
|
PL_expect = XOPERATOR; |
2698
|
730414
|
|
|
|
|
pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); |
2699
|
730414
|
|
|
|
|
return THING; |
2700
|
|
|
|
|
|
} |
2701
|
|
|
|
|
|
|
2702
|
16825188
|
100
|
|
|
|
if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */ |
2703
|
31382
|
|
|
|
|
PL_lex_state = LEX_INTERPCASEMOD; |
2704
|
31382
|
|
|
|
|
return yylex(); |
2705
|
|
|
|
|
|
} |
2706
|
|
|
|
|
|
|
2707
|
|
|
|
|
|
/* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */ |
2708
|
|
|
|
|
|
assert(PL_lex_inwhat != OP_TRANSR); |
2709
|
16793806
|
100
|
|
|
|
if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) { |
|
|
50
|
|
|
|
|
2710
|
1597241
|
|
|
|
|
PL_linestr = PL_lex_repl; |
2711
|
1597241
|
|
|
|
|
PL_lex_inpat = 0; |
2712
|
1597241
|
|
|
|
|
PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); |
2713
|
1597241
|
|
|
|
|
PL_bufend += SvCUR(PL_linestr); |
2714
|
1597241
|
|
|
|
|
PL_last_lop = PL_last_uni = NULL; |
2715
|
1597241
|
|
|
|
|
PL_lex_dojoin = FALSE; |
2716
|
1597241
|
|
|
|
|
PL_lex_brackets = 0; |
2717
|
1597241
|
|
|
|
|
PL_lex_allbrackets = 0; |
2718
|
1597241
|
|
|
|
|
PL_lex_fakeeof = LEX_FAKEEOF_NEVER; |
2719
|
1597241
|
|
|
|
|
PL_lex_casemods = 0; |
2720
|
1597241
|
|
|
|
|
*PL_lex_casestack = '\0'; |
2721
|
1597241
|
|
|
|
|
PL_lex_starts = 0; |
2722
|
1597241
|
100
|
|
|
|
if (SvEVALED(PL_lex_repl)) { |
2723
|
175369
|
|
|
|
|
PL_lex_state = LEX_INTERPNORMAL; |
2724
|
175369
|
|
|
|
|
PL_lex_starts++; |
2725
|
|
|
|
|
|
/* we don't clear PL_lex_repl here, so that we can check later |
2726
|
|
|
|
|
|
whether this is an evalled subst; that means we rely on the |
2727
|
|
|
|
|
|
logic to ensure sublex_done() is called again only via the |
2728
|
|
|
|
|
|
branch (in yylex()) that clears PL_lex_repl, else we'll loop */ |
2729
|
|
|
|
|
|
} |
2730
|
|
|
|
|
|
else { |
2731
|
1421872
|
|
|
|
|
PL_lex_state = LEX_INTERPCONCAT; |
2732
|
1421872
|
|
|
|
|
PL_lex_repl = NULL; |
2733
|
|
|
|
|
|
} |
2734
|
1597241
|
100
|
|
|
|
if (SvTYPE(PL_linestr) >= SVt_PVNV) { |
2735
|
56570
|
|
|
|
|
CopLINE(PL_curcop) += |
2736
|
28285
|
|
|
|
|
((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow |
2737
|
28285
|
|
|
|
|
+ PL_parser->lex_shared->herelines; |
2738
|
28285
|
|
|
|
|
PL_parser->lex_shared->herelines = 0; |
2739
|
|
|
|
|
|
} |
2740
|
|
|
|
|
|
return ','; |
2741
|
|
|
|
|
|
} |
2742
|
|
|
|
|
|
else { |
2743
|
|
|
|
|
|
#ifdef PERL_MAD |
2744
|
|
|
|
|
|
if (PL_madskills) { |
2745
|
|
|
|
|
|
if (PL_thiswhite) { |
2746
|
|
|
|
|
|
if (!PL_endwhite) |
2747
|
|
|
|
|
|
PL_endwhite = newSVpvs(""); |
2748
|
|
|
|
|
|
sv_catsv(PL_endwhite, PL_thiswhite); |
2749
|
|
|
|
|
|
PL_thiswhite = 0; |
2750
|
|
|
|
|
|
} |
2751
|
|
|
|
|
|
if (PL_thistoken) |
2752
|
|
|
|
|
|
sv_setpvs(PL_thistoken,""); |
2753
|
|
|
|
|
|
else |
2754
|
|
|
|
|
|
PL_realtokenstart = -1; |
2755
|
|
|
|
|
|
} |
2756
|
|
|
|
|
|
#endif |
2757
|
15196565
|
|
|
|
|
LEAVE; |
2758
|
15196565
|
|
|
|
|
PL_bufend = SvPVX(PL_linestr); |
2759
|
15196565
|
|
|
|
|
PL_bufend += SvCUR(PL_linestr); |
2760
|
15196565
|
|
|
|
|
PL_expect = XOPERATOR; |
2761
|
15196565
|
|
|
|
|
PL_sublex_info.sub_inwhat = 0; |
2762
|
16420353
|
|
|
|
|
return ')'; |
2763
|
|
|
|
|
|
} |
2764
|
|
|
|
|
|
} |
2765
|
|
|
|
|
|
|
2766
|
|
|
|
|
|
PERL_STATIC_INLINE SV* |
2767
|
2578
|
|
|
|
|
S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) |
2768
|
|
|
|
|
|
{ |
2769
|
|
|
|
|
|
/* points to first character of interior of \N{}, to one beyond the |
2770
|
|
|
|
|
|
* interior, hence to the "}". Finds what the name resolves to, returning |
2771
|
|
|
|
|
|
* an SV* containing it; NULL if no valid one found */ |
2772
|
|
|
|
|
|
|
2773
|
2578
|
50
|
|
|
|
SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2774
|
|
|
|
|
|
|
2775
|
|
|
|
|
|
HV * table; |
2776
|
|
|
|
|
|
SV **cvp; |
2777
|
|
|
|
|
|
SV *cv; |
2778
|
|
|
|
|
|
SV *rv; |
2779
|
|
|
|
|
|
HV *stash; |
2780
|
|
|
|
|
|
const U8* first_bad_char_loc; |
2781
|
2578
|
|
|
|
|
const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */ |
2782
|
|
|
|
|
|
|
2783
|
|
|
|
|
|
PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME; |
2784
|
|
|
|
|
|
|
2785
|
2578
|
50
|
|
|
|
if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr, |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2786
|
|
|
|
|
|
e - backslash_ptr, |
2787
|
|
|
|
|
|
&first_bad_char_loc)) |
2788
|
|
|
|
|
|
{ |
2789
|
|
|
|
|
|
/* If warnings are on, this will print a more detailed analysis of what |
2790
|
|
|
|
|
|
* is wrong than the error message below */ |
2791
|
2
|
|
|
|
|
utf8n_to_uvchr(first_bad_char_loc, |
2792
|
|
|
|
|
|
e - ((char *) first_bad_char_loc), |
2793
|
|
|
|
|
|
NULL, 0); |
2794
|
|
|
|
|
|
|
2795
|
|
|
|
|
|
/* We deliberately don't try to print the malformed character, which |
2796
|
|
|
|
|
|
* might not print very well; it also may be just the first of many |
2797
|
|
|
|
|
|
* malformations, so don't print what comes after it */ |
2798
|
2
|
|
|
|
|
yyerror(Perl_form(aTHX_ |
2799
|
|
|
|
|
|
"Malformed UTF-8 character immediately after '%.*s'", |
2800
|
|
|
|
|
|
(int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr)); |
2801
|
2
|
|
|
|
|
return NULL; |
2802
|
|
|
|
|
|
} |
2803
|
|
|
|
|
|
|
2804
|
2576
|
|
|
|
|
res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr, |
2805
|
|
|
|
|
|
/* include the <}> */ |
2806
|
|
|
|
|
|
e - backslash_ptr + 1); |
2807
|
2572
|
100
|
|
|
|
if (! SvPOK(res)) { |
2808
|
|
|
|
|
|
SvREFCNT_dec_NN(res); |
2809
|
|
|
|
|
|
return NULL; |
2810
|
|
|
|
|
|
} |
2811
|
|
|
|
|
|
|
2812
|
|
|
|
|
|
/* See if the charnames handler is the Perl core's, and if so, we can skip |
2813
|
|
|
|
|
|
* the validation needed for a user-supplied one, as Perl's does its own |
2814
|
|
|
|
|
|
* validation. */ |
2815
|
2462
|
|
|
|
|
table = GvHV(PL_hintgv); /* ^H */ |
2816
|
2462
|
|
|
|
|
cvp = hv_fetchs(table, "charnames", FALSE); |
2817
|
2462
|
100
|
|
|
|
if (cvp && (cv = *cvp) && SvROK(cv) && ((rv = SvRV(cv)) != NULL) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
2818
|
2456
|
100
|
|
|
|
&& SvTYPE(rv) == SVt_PVCV && ((stash = CvSTASH(rv)) != NULL)) |
|
|
50
|
|
|
|
|
2819
|
|
|
|
|
|
{ |
2820
|
2454
|
50
|
|
|
|
const char * const name = HvNAME(stash); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2821
|
2454
|
100
|
|
|
|
if strEQ(name, "_charnames") { |
2822
|
|
|
|
|
|
return res; |
2823
|
|
|
|
|
|
} |
2824
|
|
|
|
|
|
} |
2825
|
|
|
|
|
|
|
2826
|
|
|
|
|
|
/* Here, it isn't Perl's charname handler. We can't rely on a |
2827
|
|
|
|
|
|
* user-supplied handler to validate the input name. For non-ut8 input, |
2828
|
|
|
|
|
|
* look to see that the first character is legal. Then loop through the |
2829
|
|
|
|
|
|
* rest checking that each is a continuation */ |
2830
|
|
|
|
|
|
|
2831
|
|
|
|
|
|
/* This code needs to be sync'ed with a regex in _charnames.pm which does |
2832
|
|
|
|
|
|
* the same thing */ |
2833
|
|
|
|
|
|
|
2834
|
100
|
50
|
|
|
|
if (! UTF) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2835
|
72
|
100
|
|
|
|
if (! isALPHAU(*s)) { |
2836
|
|
|
|
|
|
goto bad_charname; |
2837
|
|
|
|
|
|
} |
2838
|
70
|
|
|
|
|
s++; |
2839
|
561
|
100
|
|
|
|
while (s < e) { |
2840
|
462
|
100
|
|
|
|
if (! isCHARNAME_CONT(*s)) { |
2841
|
|
|
|
|
|
goto bad_charname; |
2842
|
|
|
|
|
|
} |
2843
|
458
|
100
|
|
|
|
if (*s == ' ' && *(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2844
|
6
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), |
2845
|
|
|
|
|
|
"A sequence of multiple spaces in a charnames " |
2846
|
|
|
|
|
|
"alias definition is deprecated"); |
2847
|
|
|
|
|
|
} |
2848
|
456
|
|
|
|
|
s++; |
2849
|
|
|
|
|
|
} |
2850
|
64
|
100
|
|
|
|
if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) { |
|
|
100
|
|
|
|
|
2851
|
6
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), |
2852
|
|
|
|
|
|
"Trailing white-space in a charnames alias " |
2853
|
|
|
|
|
|
"definition is deprecated"); |
2854
|
|
|
|
|
|
} |
2855
|
|
|
|
|
|
} |
2856
|
|
|
|
|
|
else { |
2857
|
|
|
|
|
|
/* Similarly for utf8. For invariants can check directly; for other |
2858
|
|
|
|
|
|
* Latin1, can calculate their code point and check; otherwise use a |
2859
|
|
|
|
|
|
* swash */ |
2860
|
28
|
100
|
|
|
|
if (UTF8_IS_INVARIANT(*s)) { |
2861
|
24
|
100
|
|
|
|
if (! isALPHAU(*s)) { |
2862
|
|
|
|
|
|
goto bad_charname; |
2863
|
|
|
|
|
|
} |
2864
|
23
|
|
|
|
|
s++; |
2865
|
4
|
50
|
|
|
|
} else if (UTF8_IS_DOWNGRADEABLE_START(*s)) { |
2866
|
0
|
0
|
|
|
|
if (! isALPHAU(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)))) { |
|
|
0
|
|
|
|
|
2867
|
|
|
|
|
|
goto bad_charname; |
2868
|
|
|
|
|
|
} |
2869
|
0
|
|
|
|
|
s += 2; |
2870
|
|
|
|
|
|
} |
2871
|
|
|
|
|
|
else { |
2872
|
4
|
100
|
|
|
|
if (! PL_utf8_charname_begin) { |
2873
|
2
|
|
|
|
|
U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST; |
2874
|
2
|
|
|
|
|
PL_utf8_charname_begin = _core_swash_init("utf8", |
2875
|
|
|
|
|
|
"_Perl_Charname_Begin", |
2876
|
|
|
|
|
|
&PL_sv_undef, |
2877
|
|
|
|
|
|
1, 0, NULL, &flags); |
2878
|
|
|
|
|
|
} |
2879
|
4
|
100
|
|
|
|
if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) { |
2880
|
|
|
|
|
|
goto bad_charname; |
2881
|
|
|
|
|
|
} |
2882
|
2
|
|
|
|
|
s += UTF8SKIP(s); |
2883
|
|
|
|
|
|
} |
2884
|
|
|
|
|
|
|
2885
|
260
|
100
|
|
|
|
while (s < e) { |
2886
|
244
|
100
|
|
|
|
if (UTF8_IS_INVARIANT(*s)) { |
2887
|
238
|
100
|
|
|
|
if (! isCHARNAME_CONT(*s)) { |
2888
|
|
|
|
|
|
goto bad_charname; |
2889
|
|
|
|
|
|
} |
2890
|
236
|
100
|
|
|
|
if (*s == ' ' && *(s-1) == ' ' |
|
|
100
|
|
|
|
|
2891
|
8
|
100
|
|
|
|
&& ckWARN_d(WARN_DEPRECATED)) { |
2892
|
6
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), |
2893
|
|
|
|
|
|
"A sequence of multiple spaces in a charnam" |
2894
|
|
|
|
|
|
"es alias definition is deprecated"); |
2895
|
|
|
|
|
|
} |
2896
|
234
|
|
|
|
|
s++; |
2897
|
|
|
|
|
|
} |
2898
|
6
|
100
|
|
|
|
else if (UTF8_IS_DOWNGRADEABLE_START(*s)) { |
2899
|
2
|
50
|
|
|
|
if (! isCHARNAME_CONT(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)))) |
|
|
50
|
|
|
|
|
2900
|
|
|
|
|
|
{ |
2901
|
|
|
|
|
|
goto bad_charname; |
2902
|
|
|
|
|
|
} |
2903
|
0
|
|
|
|
|
s += 2; |
2904
|
|
|
|
|
|
} |
2905
|
|
|
|
|
|
else { |
2906
|
4
|
100
|
|
|
|
if (! PL_utf8_charname_continue) { |
2907
|
2
|
|
|
|
|
U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST; |
2908
|
2
|
|
|
|
|
PL_utf8_charname_continue = _core_swash_init("utf8", |
2909
|
|
|
|
|
|
"_Perl_Charname_Continue", |
2910
|
|
|
|
|
|
&PL_sv_undef, |
2911
|
|
|
|
|
|
1, 0, NULL, &flags); |
2912
|
|
|
|
|
|
} |
2913
|
4
|
100
|
|
|
|
if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) { |
2914
|
|
|
|
|
|
goto bad_charname; |
2915
|
|
|
|
|
|
} |
2916
|
119
|
|
|
|
|
s += UTF8SKIP(s); |
2917
|
|
|
|
|
|
} |
2918
|
|
|
|
|
|
} |
2919
|
16
|
100
|
|
|
|
if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) { |
|
|
100
|
|
|
|
|
2920
|
6
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), |
2921
|
|
|
|
|
|
"Trailing white-space in a charnames alias " |
2922
|
|
|
|
|
|
"definition is deprecated"); |
2923
|
|
|
|
|
|
} |
2924
|
|
|
|
|
|
} |
2925
|
|
|
|
|
|
|
2926
|
76
|
100
|
|
|
|
if (SvUTF8(res)) { /* Don't accept malformed input */ |
2927
|
|
|
|
|
|
const U8* first_bad_char_loc; |
2928
|
|
|
|
|
|
STRLEN len; |
2929
|
16
|
50
|
|
|
|
const char* const str = SvPV_const(res, len); |
2930
|
16
|
100
|
|
|
|
if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) { |
2931
|
|
|
|
|
|
/* If warnings are on, this will print a more detailed analysis of |
2932
|
|
|
|
|
|
* what is wrong than the error message below */ |
2933
|
2
|
|
|
|
|
utf8n_to_uvchr(first_bad_char_loc, |
2934
|
|
|
|
|
|
(char *) first_bad_char_loc - str, |
2935
|
|
|
|
|
|
NULL, 0); |
2936
|
|
|
|
|
|
|
2937
|
|
|
|
|
|
/* We deliberately don't try to print the malformed character, |
2938
|
|
|
|
|
|
* which might not print very well; it also may be just the first |
2939
|
|
|
|
|
|
* of many malformations, so don't print what comes after it */ |
2940
|
2
|
|
|
|
|
yyerror_pv( |
2941
|
|
|
|
|
|
Perl_form(aTHX_ |
2942
|
|
|
|
|
|
"Malformed UTF-8 returned by %.*s immediately after '%.*s'", |
2943
|
|
|
|
|
|
(int) (e - backslash_ptr + 1), backslash_ptr, |
2944
|
|
|
|
|
|
(int) ((char *) first_bad_char_loc - str), str |
2945
|
|
|
|
|
|
), |
2946
|
|
|
|
|
|
SVf_UTF8); |
2947
|
2
|
|
|
|
|
return NULL; |
2948
|
|
|
|
|
|
} |
2949
|
|
|
|
|
|
} |
2950
|
|
|
|
|
|
|
2951
|
|
|
|
|
|
return res; |
2952
|
|
|
|
|
|
|
2953
|
|
|
|
|
|
bad_charname: { |
2954
|
16
|
50
|
|
|
|
int bad_char_size = ((UTF) ? UTF8SKIP(s) : 1); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2955
|
|
|
|
|
|
|
2956
|
|
|
|
|
|
/* The final %.*s makes sure that should the trailing NUL be missing |
2957
|
|
|
|
|
|
* that this print won't run off the end of the string */ |
2958
|
16
|
50
|
|
|
|
yyerror_pv( |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2959
|
|
|
|
|
|
Perl_form(aTHX_ |
2960
|
|
|
|
|
|
"Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s", |
2961
|
|
|
|
|
|
(int)(s - backslash_ptr + bad_char_size), backslash_ptr, |
2962
|
|
|
|
|
|
(int)(e - s + bad_char_size), s + bad_char_size |
2963
|
|
|
|
|
|
), |
2964
|
|
|
|
|
|
UTF ? SVf_UTF8 : 0); |
2965
|
1291
|
|
|
|
|
return NULL; |
2966
|
|
|
|
|
|
} |
2967
|
|
|
|
|
|
} |
2968
|
|
|
|
|
|
|
2969
|
|
|
|
|
|
/* |
2970
|
|
|
|
|
|
scan_const |
2971
|
|
|
|
|
|
|
2972
|
|
|
|
|
|
Extracts the next constant part of a pattern, double-quoted string, |
2973
|
|
|
|
|
|
or transliteration. This is terrifying code. |
2974
|
|
|
|
|
|
|
2975
|
|
|
|
|
|
For example, in parsing the double-quoted string "ab\x63$d", it would |
2976
|
|
|
|
|
|
stop at the '$' and return an OP_CONST containing 'abc'. |
2977
|
|
|
|
|
|
|
2978
|
|
|
|
|
|
It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's |
2979
|
|
|
|
|
|
processing a pattern (PL_lex_inpat is true), a transliteration |
2980
|
|
|
|
|
|
(PL_lex_inwhat == OP_TRANS is true), or a double-quoted string. |
2981
|
|
|
|
|
|
|
2982
|
|
|
|
|
|
Returns a pointer to the character scanned up to. If this is |
2983
|
|
|
|
|
|
advanced from the start pointer supplied (i.e. if anything was |
2984
|
|
|
|
|
|
successfully parsed), will leave an OP_CONST for the substring scanned |
2985
|
|
|
|
|
|
in pl_yylval. Caller must intuit reason for not parsing further |
2986
|
|
|
|
|
|
by looking at the next characters herself. |
2987
|
|
|
|
|
|
|
2988
|
|
|
|
|
|
In patterns: |
2989
|
|
|
|
|
|
expand: |
2990
|
|
|
|
|
|
\N{FOO} => \N{U+hex_for_character_FOO} |
2991
|
|
|
|
|
|
(if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...}) |
2992
|
|
|
|
|
|
|
2993
|
|
|
|
|
|
pass through: |
2994
|
|
|
|
|
|
all other \-char, including \N and \N{ apart from \N{ABC} |
2995
|
|
|
|
|
|
|
2996
|
|
|
|
|
|
stops on: |
2997
|
|
|
|
|
|
@ and $ where it appears to be a var, but not for $ as tail anchor |
2998
|
|
|
|
|
|
\l \L \u \U \Q \E |
2999
|
|
|
|
|
|
(?{ or (??{ |
3000
|
|
|
|
|
|
|
3001
|
|
|
|
|
|
|
3002
|
|
|
|
|
|
In transliterations: |
3003
|
|
|
|
|
|
characters are VERY literal, except for - not at the start or end |
3004
|
|
|
|
|
|
of the string, which indicates a range. If the range is in bytes, |
3005
|
|
|
|
|
|
scan_const expands the range to the full set of intermediate |
3006
|
|
|
|
|
|
characters. If the range is in utf8, the hyphen is replaced with |
3007
|
|
|
|
|
|
a certain range mark which will be handled by pmtrans() in op.c. |
3008
|
|
|
|
|
|
|
3009
|
|
|
|
|
|
In double-quoted strings: |
3010
|
|
|
|
|
|
backslashes: |
3011
|
|
|
|
|
|
double-quoted style: \r and \n |
3012
|
|
|
|
|
|
constants: \x31, etc. |
3013
|
|
|
|
|
|
deprecated backrefs: \1 (in substitution replacements) |
3014
|
|
|
|
|
|
case and quoting: \U \Q \E |
3015
|
|
|
|
|
|
stops on @ and $ |
3016
|
|
|
|
|
|
|
3017
|
|
|
|
|
|
scan_const does *not* construct ops to handle interpolated strings. |
3018
|
|
|
|
|
|
It stops processing as soon as it finds an embedded $ or @ variable |
3019
|
|
|
|
|
|
and leaves it to the caller to work out what's going on. |
3020
|
|
|
|
|
|
|
3021
|
|
|
|
|
|
embedded arrays (whether in pattern or not) could be: |
3022
|
|
|
|
|
|
@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-. |
3023
|
|
|
|
|
|
|
3024
|
|
|
|
|
|
$ in double-quoted strings must be the symbol of an embedded scalar. |
3025
|
|
|
|
|
|
|
3026
|
|
|
|
|
|
$ in pattern could be $foo or could be tail anchor. Assumption: |
3027
|
|
|
|
|
|
it's a tail anchor if $ is the last thing in the string, or if it's |
3028
|
|
|
|
|
|
followed by one of "()| \r\n\t" |
3029
|
|
|
|
|
|
|
3030
|
|
|
|
|
|
\1 (backreferences) are turned into $1 in substitutions |
3031
|
|
|
|
|
|
|
3032
|
|
|
|
|
|
The structure of the code is |
3033
|
|
|
|
|
|
while (there's a character to process) { |
3034
|
|
|
|
|
|
handle transliteration ranges |
3035
|
|
|
|
|
|
skip regexp comments /(?#comment)/ and codes /(?{code})/ |
3036
|
|
|
|
|
|
skip #-initiated comments in //x patterns |
3037
|
|
|
|
|
|
check for embedded arrays |
3038
|
|
|
|
|
|
check for embedded scalars |
3039
|
|
|
|
|
|
if (backslash) { |
3040
|
|
|
|
|
|
deprecate \1 in substitution replacements |
3041
|
|
|
|
|
|
handle string-changing backslashes \l \U \Q \E, etc. |
3042
|
|
|
|
|
|
switch (what was escaped) { |
3043
|
|
|
|
|
|
handle \- in a transliteration (becomes a literal -) |
3044
|
|
|
|
|
|
if a pattern and not \N{, go treat as regular character |
3045
|
|
|
|
|
|
handle \132 (octal characters) |
3046
|
|
|
|
|
|
handle \x15 and \x{1234} (hex characters) |
3047
|
|
|
|
|
|
handle \N{name} (named characters, also \N{3,5} in a pattern) |
3048
|
|
|
|
|
|
handle \cV (control characters) |
3049
|
|
|
|
|
|
handle printf-style backslashes (\f, \r, \n, etc) |
3050
|
|
|
|
|
|
} (end switch) |
3051
|
|
|
|
|
|
continue |
3052
|
|
|
|
|
|
} (end if backslash) |
3053
|
|
|
|
|
|
handle regular character |
3054
|
|
|
|
|
|
} (end while character to read) |
3055
|
|
|
|
|
|
|
3056
|
|
|
|
|
|
*/ |
3057
|
|
|
|
|
|
|
3058
|
|
|
|
|
|
STATIC char * |
3059
|
22710265
|
|
|
|
|
S_scan_const(pTHX_ char *start) |
3060
|
|
|
|
|
|
{ |
3061
|
|
|
|
|
|
dVAR; |
3062
|
22710265
|
|
|
|
|
char *send = PL_bufend; /* end of the constant */ |
3063
|
22710265
|
|
|
|
|
SV *sv = newSV(send - start); /* sv for the constant. See |
3064
|
|
|
|
|
|
note below on sizing. */ |
3065
|
22710265
|
|
|
|
|
char *s = start; /* start of the constant */ |
3066
|
22710265
|
|
|
|
|
char *d = SvPVX(sv); /* destination for copies */ |
3067
|
|
|
|
|
|
bool dorange = FALSE; /* are we in a translit range? */ |
3068
|
|
|
|
|
|
bool didrange = FALSE; /* did we just finish a range? */ |
3069
|
|
|
|
|
|
bool in_charclass = FALSE; /* within /[...]/ */ |
3070
|
|
|
|
|
|
bool has_utf8 = FALSE; /* Output constant is UTF8 */ |
3071
|
22710265
|
50
|
|
|
|
bool this_utf8 = cBOOL(UTF); /* Is the source string assumed |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3072
|
|
|
|
|
|
to be UTF8? But, this can |
3073
|
|
|
|
|
|
show as true when the source |
3074
|
|
|
|
|
|
isn't utf8, as for example |
3075
|
|
|
|
|
|
when it is entirely composed |
3076
|
|
|
|
|
|
of hex constants */ |
3077
|
|
|
|
|
|
SV *res; /* result from charnames */ |
3078
|
|
|
|
|
|
|
3079
|
|
|
|
|
|
/* Note on sizing: The scanned constant is placed into sv, which is |
3080
|
|
|
|
|
|
* initialized by newSV() assuming one byte of output for every byte of |
3081
|
|
|
|
|
|
* input. This routine expects newSV() to allocate an extra byte for a |
3082
|
|
|
|
|
|
* trailing NUL, which this routine will append if it gets to the end of |
3083
|
|
|
|
|
|
* the input. There may be more bytes of input than output (eg., \N{LATIN |
3084
|
|
|
|
|
|
* CAPITAL LETTER A}), or more output than input if the constant ends up |
3085
|
|
|
|
|
|
* recoded to utf8, but each time a construct is found that might increase |
3086
|
|
|
|
|
|
* the needed size, SvGROW() is called. Its size parameter each time is |
3087
|
|
|
|
|
|
* based on the best guess estimate at the time, namely the length used so |
3088
|
|
|
|
|
|
* far, plus the length the current construct will occupy, plus room for |
3089
|
|
|
|
|
|
* the trailing NUL, plus one byte for every input byte still unscanned */ |
3090
|
|
|
|
|
|
|
3091
|
22710265
|
|
|
|
|
UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses |
3092
|
|
|
|
|
|
before set */ |
3093
|
|
|
|
|
|
#ifdef EBCDIC |
3094
|
|
|
|
|
|
UV literal_endpoint = 0; |
3095
|
|
|
|
|
|
bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */ |
3096
|
|
|
|
|
|
#endif |
3097
|
|
|
|
|
|
|
3098
|
|
|
|
|
|
PERL_ARGS_ASSERT_SCAN_CONST; |
3099
|
|
|
|
|
|
|
3100
|
|
|
|
|
|
assert(PL_lex_inwhat != OP_TRANSR); |
3101
|
22710265
|
100
|
|
|
|
if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { |
|
|
50
|
|
|
|
|
3102
|
|
|
|
|
|
/* If we are doing a trans and we know we want UTF8 set expectation */ |
3103
|
135970
|
|
|
|
|
has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF); |
3104
|
135970
|
100
|
|
|
|
this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF); |
3105
|
|
|
|
|
|
} |
3106
|
|
|
|
|
|
|
3107
|
|
|
|
|
|
/* Protect sv from errors and fatal warnings. */ |
3108
|
22710265
|
|
|
|
|
ENTER_with_name("scan_const"); |
3109
|
22710265
|
|
|
|
|
SAVEFREESV(sv); |
3110
|
|
|
|
|
|
|
3111
|
258448946
|
100
|
|
|
|
while (s < send || dorange) { |
|
|
100
|
|
|
|
|
3112
|
|
|
|
|
|
|
3113
|
|
|
|
|
|
/* get transliterations out of the way (they're most literal) */ |
3114
|
234247528
|
100
|
|
|
|
if (PL_lex_inwhat == OP_TRANS) { |
3115
|
|
|
|
|
|
/* expand a range A-Z to the full set of characters. AIE! */ |
3116
|
327926
|
100
|
|
|
|
if (dorange) { |
3117
|
|
|
|
|
|
I32 i; /* current expanded character */ |
3118
|
|
|
|
|
|
I32 min; /* first character in range */ |
3119
|
|
|
|
|
|
I32 max; /* last character in range */ |
3120
|
|
|
|
|
|
|
3121
|
|
|
|
|
|
#ifdef EBCDIC |
3122
|
|
|
|
|
|
UV uvmax = 0; |
3123
|
|
|
|
|
|
#endif |
3124
|
|
|
|
|
|
|
3125
|
58448
|
100
|
|
|
|
if (has_utf8 |
3126
|
|
|
|
|
|
#ifdef EBCDIC |
3127
|
|
|
|
|
|
&& !native_range |
3128
|
|
|
|
|
|
#endif |
3129
|
|
|
|
|
|
) { |
3130
|
8
|
|
|
|
|
char * const c = (char*)utf8_hop((U8*)d, -1); |
3131
|
8
|
|
|
|
|
char *e = d++; |
3132
|
30
|
100
|
|
|
|
while (e-- > c) |
3133
|
18
|
|
|
|
|
*(e + 1) = *e; |
3134
|
8
|
|
|
|
|
*c = (char) ILLEGAL_UTF8_BYTE; |
3135
|
|
|
|
|
|
/* mark the range as done, and continue */ |
3136
|
|
|
|
|
|
dorange = FALSE; |
3137
|
|
|
|
|
|
didrange = TRUE; |
3138
|
8
|
|
|
|
|
continue; |
3139
|
|
|
|
|
|
} |
3140
|
|
|
|
|
|
|
3141
|
58440
|
|
|
|
|
i = d - SvPVX_const(sv); /* remember current offset */ |
3142
|
|
|
|
|
|
#ifdef EBCDIC |
3143
|
|
|
|
|
|
SvGROW(sv, |
3144
|
|
|
|
|
|
SvLEN(sv) + (has_utf8 ? |
3145
|
|
|
|
|
|
(512 - UTF_CONTINUATION_MARK + |
3146
|
|
|
|
|
|
UNISKIP(0x100)) |
3147
|
|
|
|
|
|
: 256)); |
3148
|
|
|
|
|
|
/* How many two-byte within 0..255: 128 in UTF-8, |
3149
|
|
|
|
|
|
* 96 in UTF-8-mod. */ |
3150
|
|
|
|
|
|
#else |
3151
|
58440
|
50
|
|
|
|
SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */ |
|
|
50
|
|
|
|
|
3152
|
|
|
|
|
|
#endif |
3153
|
58440
|
|
|
|
|
d = SvPVX(sv) + i; /* refresh d after realloc */ |
3154
|
|
|
|
|
|
#ifdef EBCDIC |
3155
|
|
|
|
|
|
if (has_utf8) { |
3156
|
|
|
|
|
|
int j; |
3157
|
|
|
|
|
|
for (j = 0; j <= 1; j++) { |
3158
|
|
|
|
|
|
char * const c = (char*)utf8_hop((U8*)d, -1); |
3159
|
|
|
|
|
|
const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0); |
3160
|
|
|
|
|
|
if (j) |
3161
|
|
|
|
|
|
min = (U8)uv; |
3162
|
|
|
|
|
|
else if (uv < 256) |
3163
|
|
|
|
|
|
max = (U8)uv; |
3164
|
|
|
|
|
|
else { |
3165
|
|
|
|
|
|
max = (U8)0xff; /* only to \xff */ |
3166
|
|
|
|
|
|
uvmax = uv; /* \x{100} to uvmax */ |
3167
|
|
|
|
|
|
} |
3168
|
|
|
|
|
|
d = c; /* eat endpoint chars */ |
3169
|
|
|
|
|
|
} |
3170
|
|
|
|
|
|
} |
3171
|
|
|
|
|
|
else { |
3172
|
|
|
|
|
|
#endif |
3173
|
58440
|
|
|
|
|
d -= 2; /* eat the first char and the - */ |
3174
|
58440
|
|
|
|
|
min = (U8)*d; /* first char in range */ |
3175
|
58440
|
|
|
|
|
max = (U8)d[1]; /* last char in range */ |
3176
|
|
|
|
|
|
#ifdef EBCDIC |
3177
|
|
|
|
|
|
} |
3178
|
|
|
|
|
|
#endif |
3179
|
|
|
|
|
|
|
3180
|
58440
|
100
|
|
|
|
if (min > max) { |
3181
|
9
|
|
|
|
|
Perl_croak(aTHX_ |
3182
|
|
|
|
|
|
"Invalid range \"%c-%c\" in transliteration operator", |
3183
|
12
|
|
|
|
|
(char)min, (char)max); |
3184
|
|
|
|
|
|
} |
3185
|
|
|
|
|
|
|
3186
|
|
|
|
|
|
#ifdef EBCDIC |
3187
|
|
|
|
|
|
if (literal_endpoint == 2 && |
3188
|
|
|
|
|
|
((isLOWER_A(min) && isLOWER_A(max)) || |
3189
|
|
|
|
|
|
(isUPPER_A(min) && isUPPER_A(max)))) |
3190
|
|
|
|
|
|
{ |
3191
|
|
|
|
|
|
for (i = min; i <= max; i++) { |
3192
|
|
|
|
|
|
if (isALPHA_A(i)) |
3193
|
|
|
|
|
|
*d++ = i; |
3194
|
|
|
|
|
|
} |
3195
|
|
|
|
|
|
} |
3196
|
|
|
|
|
|
else |
3197
|
|
|
|
|
|
#endif |
3198
|
2732291
|
100
|
|
|
|
for (i = min; i <= max; i++) |
3199
|
|
|
|
|
|
#ifdef EBCDIC |
3200
|
|
|
|
|
|
if (has_utf8) { |
3201
|
|
|
|
|
|
append_utf8_from_native_byte(i, &d); |
3202
|
|
|
|
|
|
} |
3203
|
|
|
|
|
|
else |
3204
|
|
|
|
|
|
#endif |
3205
|
2701994
|
|
|
|
|
*d++ = (char)i; |
3206
|
|
|
|
|
|
|
3207
|
|
|
|
|
|
#ifdef EBCDIC |
3208
|
|
|
|
|
|
if (uvmax) { |
3209
|
|
|
|
|
|
d = (char*)uvchr_to_utf8((U8*)d, 0x100); |
3210
|
|
|
|
|
|
if (uvmax > 0x101) |
3211
|
|
|
|
|
|
*d++ = (char) ILLEGAL_UTF8_BYTE; |
3212
|
|
|
|
|
|
if (uvmax > 0x100) |
3213
|
|
|
|
|
|
d = (char*)uvchr_to_utf8((U8*)d, uvmax); |
3214
|
|
|
|
|
|
} |
3215
|
|
|
|
|
|
#endif |
3216
|
|
|
|
|
|
|
3217
|
|
|
|
|
|
/* mark the range as done, and continue */ |
3218
|
|
|
|
|
|
dorange = FALSE; |
3219
|
|
|
|
|
|
didrange = TRUE; |
3220
|
|
|
|
|
|
#ifdef EBCDIC |
3221
|
|
|
|
|
|
literal_endpoint = 0; |
3222
|
|
|
|
|
|
#endif |
3223
|
58434
|
|
|
|
|
continue; |
3224
|
|
|
|
|
|
} |
3225
|
|
|
|
|
|
|
3226
|
|
|
|
|
|
/* range begins (ignore - as first or last char) */ |
3227
|
269478
|
100
|
|
|
|
else if (*s == '-' && s+1 < send && s != start) { |
|
|
100
|
|
|
|
|
3228
|
58540
|
100
|
|
|
|
if (didrange) { |
3229
|
6
|
|
|
|
|
Perl_croak(aTHX_ "Ambiguous range in transliteration operator"); |
3230
|
|
|
|
|
|
} |
3231
|
58534
|
100
|
|
|
|
if (has_utf8 |
3232
|
|
|
|
|
|
#ifdef EBCDIC |
3233
|
|
|
|
|
|
&& !native_range |
3234
|
|
|
|
|
|
#endif |
3235
|
|
|
|
|
|
) { |
3236
|
86
|
|
|
|
|
*d++ = (char) ILLEGAL_UTF8_BYTE; /* use illegal utf8 byte--see pmtrans */ |
3237
|
86
|
|
|
|
|
s++; |
3238
|
86
|
|
|
|
|
continue; |
3239
|
|
|
|
|
|
} |
3240
|
|
|
|
|
|
dorange = TRUE; |
3241
|
58448
|
|
|
|
|
s++; |
3242
|
|
|
|
|
|
} |
3243
|
|
|
|
|
|
else { |
3244
|
|
|
|
|
|
didrange = FALSE; |
3245
|
|
|
|
|
|
#ifdef EBCDIC |
3246
|
|
|
|
|
|
literal_endpoint = 0; |
3247
|
|
|
|
|
|
native_range = TRUE; |
3248
|
|
|
|
|
|
#endif |
3249
|
|
|
|
|
|
} |
3250
|
|
|
|
|
|
} |
3251
|
|
|
|
|
|
|
3252
|
|
|
|
|
|
/* if we get here, we're not doing a transliteration */ |
3253
|
|
|
|
|
|
|
3254
|
233919602
|
100
|
|
|
|
else if (*s == '[' && PL_lex_inpat && !in_charclass) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3255
|
1812839
|
|
|
|
|
char *s1 = s-1; |
3256
|
|
|
|
|
|
int esc = 0; |
3257
|
2721771
|
100
|
|
|
|
while (s1 >= start && *s1-- == '\\') |
|
|
100
|
|
|
|
|
3258
|
41752
|
|
|
|
|
esc = !esc; |
3259
|
1812839
|
100
|
|
|
|
if (!esc) |
3260
|
|
|
|
|
|
in_charclass = TRUE; |
3261
|
|
|
|
|
|
} |
3262
|
|
|
|
|
|
|
3263
|
232106763
|
100
|
|
|
|
else if (*s == ']' && PL_lex_inpat && in_charclass) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3264
|
1807945
|
|
|
|
|
char *s1 = s-1; |
3265
|
|
|
|
|
|
int esc = 0; |
3266
|
2882018
|
50
|
|
|
|
while (s1 >= start && *s1-- == '\\') |
|
|
100
|
|
|
|
|
3267
|
209340
|
|
|
|
|
esc = !esc; |
3268
|
1807945
|
100
|
|
|
|
if (!esc) |
3269
|
|
|
|
|
|
in_charclass = FALSE; |
3270
|
|
|
|
|
|
} |
3271
|
|
|
|
|
|
|
3272
|
|
|
|
|
|
/* skip for regexp comments /(?#comment)/, except for the last |
3273
|
|
|
|
|
|
* char, which will be done separately. |
3274
|
|
|
|
|
|
* Stop on (?{..}) and friends */ |
3275
|
|
|
|
|
|
|
3276
|
230298818
|
100
|
|
|
|
else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3277
|
791588
|
100
|
|
|
|
if (s[2] == '#') { |
3278
|
3048
|
100
|
|
|
|
while (s+1 < send && *s != ')') |
|
|
100
|
|
|
|
|
3279
|
2608
|
|
|
|
|
*d++ = *s++; |
3280
|
|
|
|
|
|
} |
3281
|
1173025
|
100
|
|
|
|
else if (!PL_lex_casemods && |
|
|
100
|
|
|
|
|
3282
|
791112
|
|
|
|
|
( s[2] == '{' /* This should match regcomp.c */ |
3283
|
788696
|
100
|
|
|
|
|| (s[2] == '?' && s[3] == '{'))) |
|
|
50
|
|
|
|
|
3284
|
|
|
|
|
|
{ |
3285
|
|
|
|
|
|
break; |
3286
|
|
|
|
|
|
} |
3287
|
|
|
|
|
|
} |
3288
|
|
|
|
|
|
|
3289
|
|
|
|
|
|
/* likewise skip #-initiated comments in //x patterns */ |
3290
|
229616858
|
100
|
|
|
|
else if (*s == '#' && PL_lex_inpat && !in_charclass && |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3291
|
232936
|
|
|
|
|
((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) { |
3292
|
4351078
|
100
|
|
|
|
while (s+1 < send && *s != '\n') |
|
|
100
|
|
|
|
|
3293
|
4146494
|
|
|
|
|
*d++ = *s++; |
3294
|
|
|
|
|
|
} |
3295
|
|
|
|
|
|
|
3296
|
|
|
|
|
|
/* no further processing of single-quoted regex */ |
3297
|
229302646
|
100
|
|
|
|
else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') |
|
|
100
|
|
|
|
|
3298
|
|
|
|
|
|
goto default_action; |
3299
|
|
|
|
|
|
|
3300
|
|
|
|
|
|
/* check for embedded arrays |
3301
|
|
|
|
|
|
(@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-) |
3302
|
|
|
|
|
|
*/ |
3303
|
228531966
|
100
|
|
|
|
else if (*s == '@' && s[1]) { |
|
|
100
|
|
|
|
|
3304
|
248862
|
100
|
|
|
|
if (isWORDCHAR_lazy_if(s+1,UTF)) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
3305
|
|
|
|
|
|
break; |
3306
|
64220
|
100
|
|
|
|
if (strchr(":'{$", s[1])) |
3307
|
|
|
|
|
|
break; |
3308
|
37642
|
100
|
|
|
|
if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-')) |
|
|
100
|
|
|
|
|
3309
|
|
|
|
|
|
break; /* in regexp, neither @+ nor @- are interpolated */ |
3310
|
|
|
|
|
|
} |
3311
|
|
|
|
|
|
|
3312
|
|
|
|
|
|
/* check for embedded scalars. only stop if we're sure it's a |
3313
|
|
|
|
|
|
variable. |
3314
|
|
|
|
|
|
*/ |
3315
|
228283104
|
100
|
|
|
|
else if (*s == '$') { |
3316
|
10113463
|
100
|
|
|
|
if (!PL_lex_inpat) /* not a regexp, so $ must be var */ |
3317
|
|
|
|
|
|
break; |
3318
|
1486465
|
100
|
|
|
|
if (s + 1 < send && !strchr("()| \r\n\t", s[1])) { |
|
|
100
|
|
|
|
|
3319
|
405558
|
100
|
|
|
|
if (s[1] == '\\') { |
3320
|
12
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), |
3321
|
|
|
|
|
|
"Possible unintended interpolation of $\\ in regex"); |
3322
|
|
|
|
|
|
} |
3323
|
|
|
|
|
|
break; /* in regexp, $ might be tail anchor */ |
3324
|
|
|
|
|
|
} |
3325
|
|
|
|
|
|
} |
3326
|
|
|
|
|
|
|
3327
|
|
|
|
|
|
/* End of else if chain - OP_TRANS rejoin rest */ |
3328
|
|
|
|
|
|
|
3329
|
|
|
|
|
|
/* backslashes */ |
3330
|
224163272
|
100
|
|
|
|
if (*s == '\\' && s+1 < send) { |
|
|
100
|
|
|
|
|
3331
|
|
|
|
|
|
char* e; /* Can be used for ending '}', etc. */ |
3332
|
|
|
|
|
|
|
3333
|
44060493
|
|
|
|
|
s++; |
3334
|
|
|
|
|
|
|
3335
|
|
|
|
|
|
/* warn on \1 - \9 in substitution replacements, but note that \11 |
3336
|
|
|
|
|
|
* is an octal; and \19 is \1 followed by '9' */ |
3337
|
44255036
|
100
|
|
|
|
if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat && |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3338
|
198671
|
100
|
|
|
|
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) |
|
|
100
|
|
|
|
|
3339
|
|
|
|
|
|
{ |
3340
|
10
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s); |
3341
|
6
|
|
|
|
|
*--s = '$'; |
3342
|
6
|
|
|
|
|
break; |
3343
|
|
|
|
|
|
} |
3344
|
|
|
|
|
|
|
3345
|
|
|
|
|
|
/* string-change backslash escapes */ |
3346
|
44060483
|
100
|
|
|
|
if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3347
|
200626
|
|
|
|
|
--s; |
3348
|
200626
|
|
|
|
|
break; |
3349
|
|
|
|
|
|
} |
3350
|
|
|
|
|
|
/* In a pattern, process \N, but skip any other backslash escapes. |
3351
|
|
|
|
|
|
* This is because we don't want to translate an escape sequence |
3352
|
|
|
|
|
|
* into a meta symbol and have the regex compiler use the meta |
3353
|
|
|
|
|
|
* symbol meaning, e.g. \x{2E} would be confused with a dot. But |
3354
|
|
|
|
|
|
* in spite of this, we do have to process \N here while the proper |
3355
|
|
|
|
|
|
* charnames handler is in scope. See bugs #56444 and #62056. |
3356
|
|
|
|
|
|
* There is a complication because \N in a pattern may also stand |
3357
|
|
|
|
|
|
* for 'match a non-nl', and not mean a charname, in which case its |
3358
|
|
|
|
|
|
* processing should be deferred to the regex compiler. To be a |
3359
|
|
|
|
|
|
* charname it must be followed immediately by a '{', and not look |
3360
|
|
|
|
|
|
* like \N followed by a curly quantifier, i.e., not something like |
3361
|
|
|
|
|
|
* \N{3,}. regcurly returns a boolean indicating if it is a legal |
3362
|
|
|
|
|
|
* quantifier */ |
3363
|
43859857
|
100
|
|
|
|
else if (PL_lex_inpat |
3364
|
5740825
|
100
|
|
|
|
&& (*s != 'N' |
3365
|
1068
|
100
|
|
|
|
|| s[1] != '{' |
3366
|
590
|
100
|
|
|
|
|| regcurly(s + 1, FALSE))) |
3367
|
|
|
|
|
|
{ |
3368
|
5740239
|
|
|
|
|
*d++ = '\\'; |
3369
|
5740239
|
|
|
|
|
goto default_action; |
3370
|
|
|
|
|
|
} |
3371
|
|
|
|
|
|
|
3372
|
38119618
|
|
|
|
|
switch (*s) { |
3373
|
|
|
|
|
|
|
3374
|
|
|
|
|
|
/* quoted - in transliterations */ |
3375
|
|
|
|
|
|
case '-': |
3376
|
5306
|
100
|
|
|
|
if (PL_lex_inwhat == OP_TRANS) { |
3377
|
532
|
|
|
|
|
*d++ = *s++; |
3378
|
532
|
|
|
|
|
continue; |
3379
|
|
|
|
|
|
} |
3380
|
|
|
|
|
|
/* FALL THROUGH */ |
3381
|
|
|
|
|
|
default: |
3382
|
|
|
|
|
|
{ |
3383
|
1678285
|
100
|
|
|
|
if ((isALPHANUMERIC(*s))) |
3384
|
10
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), |
3385
|
|
|
|
|
|
"Unrecognized escape \\%c passed through", |
3386
|
10
|
|
|
|
|
*s); |
3387
|
|
|
|
|
|
/* default action is to copy the quoted character */ |
3388
|
|
|
|
|
|
goto default_action; |
3389
|
|
|
|
|
|
} |
3390
|
|
|
|
|
|
|
3391
|
|
|
|
|
|
/* eg. \132 indicates the octal constant 0132 */ |
3392
|
|
|
|
|
|
case '0': case '1': case '2': case '3': |
3393
|
|
|
|
|
|
case '4': case '5': case '6': case '7': |
3394
|
|
|
|
|
|
{ |
3395
|
317094
|
|
|
|
|
I32 flags = PERL_SCAN_SILENT_ILLDIGIT; |
3396
|
317094
|
|
|
|
|
STRLEN len = 3; |
3397
|
317094
|
|
|
|
|
uv = grok_oct(s, &len, &flags, NULL); |
3398
|
317094
|
|
|
|
|
s += len; |
3399
|
317094
|
100
|
|
|
|
if (len < 3 && s < send && isDIGIT(*s) |
|
|
50
|
|
|
|
|
3400
|
0
|
0
|
|
|
|
&& ckWARN(WARN_MISC)) |
3401
|
|
|
|
|
|
{ |
3402
|
0
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_MISC), |
3403
|
|
|
|
|
|
"%s", form_short_octal_warning(s, len)); |
3404
|
|
|
|
|
|
} |
3405
|
|
|
|
|
|
} |
3406
|
|
|
|
|
|
goto NUM_ESCAPE_INSERT; |
3407
|
|
|
|
|
|
|
3408
|
|
|
|
|
|
/* eg. \o{24} indicates the octal constant \024 */ |
3409
|
|
|
|
|
|
case 'o': |
3410
|
|
|
|
|
|
{ |
3411
|
|
|
|
|
|
const char* error; |
3412
|
|
|
|
|
|
|
3413
|
64
|
50
|
|
|
|
bool valid = grok_bslash_o(&s, &uv, &error, |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
3414
|
|
|
|
|
|
TRUE, /* Output warning */ |
3415
|
|
|
|
|
|
FALSE, /* Not strict */ |
3416
|
|
|
|
|
|
TRUE, /* Output warnings for |
3417
|
|
|
|
|
|
non-portables */ |
3418
|
|
|
|
|
|
UTF); |
3419
|
60
|
100
|
|
|
|
if (! valid) { |
3420
|
50
|
|
|
|
|
yyerror(error); |
3421
|
46
|
|
|
|
|
continue; |
3422
|
|
|
|
|
|
} |
3423
|
|
|
|
|
|
goto NUM_ESCAPE_INSERT; |
3424
|
|
|
|
|
|
} |
3425
|
|
|
|
|
|
|
3426
|
|
|
|
|
|
/* eg. \x24 indicates the hex constant 0x24 */ |
3427
|
|
|
|
|
|
case 'x': |
3428
|
|
|
|
|
|
{ |
3429
|
|
|
|
|
|
const char* error; |
3430
|
|
|
|
|
|
|
3431
|
|
|
|
|
|
bool valid = grok_bslash_x(&s, &uv, &error, |
3432
|
|
|
|
|
|
TRUE, /* Output warning */ |
3433
|
|
|
|
|
|
FALSE, /* Not strict */ |
3434
|
|
|
|
|
|
TRUE, /* Output warnings for |
3435
|
|
|
|
|
|
non-portables */ |
3436
|
|
|
|
|
|
UTF); |
3437
|
32465268
|
100
|
|
|
|
if (! valid) { |
3438
|
42
|
|
|
|
|
yyerror(error); |
3439
|
38
|
|
|
|
|
continue; |
3440
|
|
|
|
|
|
} |
3441
|
|
|
|
|
|
} |
3442
|
|
|
|
|
|
|
3443
|
|
|
|
|
|
NUM_ESCAPE_INSERT: |
3444
|
|
|
|
|
|
/* Insert oct or hex escaped character. There will always be |
3445
|
|
|
|
|
|
* enough room in sv since such escapes will be longer than any |
3446
|
|
|
|
|
|
* UTF-8 sequence they can end up as, except if they force us |
3447
|
|
|
|
|
|
* to recode the rest of the string into utf8 */ |
3448
|
|
|
|
|
|
|
3449
|
|
|
|
|
|
/* Here uv is the ordinal of the next character being added */ |
3450
|
32782330
|
100
|
|
|
|
if (!NATIVE_IS_INVARIANT(uv)) { |
3451
|
1122234
|
100
|
|
|
|
if (!has_utf8 && uv > 255) { |
|
|
100
|
|
|
|
|
3452
|
|
|
|
|
|
/* Might need to recode whatever we have accumulated so |
3453
|
|
|
|
|
|
* far if it contains any chars variant in utf8 or |
3454
|
|
|
|
|
|
* utf-ebcdic. */ |
3455
|
|
|
|
|
|
|
3456
|
264432
|
|
|
|
|
SvCUR_set(sv, d - SvPVX_const(sv)); |
3457
|
264432
|
|
|
|
|
SvPOK_on(sv); |
3458
|
264432
|
|
|
|
|
*d = '\0'; |
3459
|
|
|
|
|
|
/* See Note on sizing above. */ |
3460
|
264432
|
50
|
|
|
|
sv_utf8_upgrade_flags_grow(sv, |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3461
|
|
|
|
|
|
SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, |
3462
|
|
|
|
|
|
UNISKIP(uv) + (STRLEN)(send - s) + 1); |
3463
|
264432
|
|
|
|
|
d = SvPVX(sv) + SvCUR(sv); |
3464
|
|
|
|
|
|
has_utf8 = TRUE; |
3465
|
|
|
|
|
|
} |
3466
|
|
|
|
|
|
|
3467
|
1122234
|
100
|
|
|
|
if (has_utf8) { |
3468
|
300990
|
|
|
|
|
d = (char*)uvchr_to_utf8((U8*)d, uv); |
3469
|
301066
|
100
|
|
|
|
if (PL_lex_inwhat == OP_TRANS && |
|
|
50
|
|
|
|
|
3470
|
152
|
|
|
|
|
PL_sublex_info.sub_op) { |
3471
|
228
|
100
|
|
|
|
PL_sublex_info.sub_op->op_private |= |
3472
|
152
|
|
|
|
|
(PL_lex_repl ? OPpTRANS_FROM_UTF |
3473
|
|
|
|
|
|
: OPpTRANS_TO_UTF); |
3474
|
|
|
|
|
|
} |
3475
|
|
|
|
|
|
#ifdef EBCDIC |
3476
|
|
|
|
|
|
if (uv > 255 && !dorange) |
3477
|
|
|
|
|
|
native_range = FALSE; |
3478
|
|
|
|
|
|
#endif |
3479
|
|
|
|
|
|
} |
3480
|
|
|
|
|
|
else { |
3481
|
821244
|
|
|
|
|
*d++ = (char)uv; |
3482
|
|
|
|
|
|
} |
3483
|
|
|
|
|
|
} |
3484
|
|
|
|
|
|
else { |
3485
|
31660096
|
|
|
|
|
*d++ = (char) uv; |
3486
|
|
|
|
|
|
} |
3487
|
32782330
|
|
|
|
|
continue; |
3488
|
|
|
|
|
|
|
3489
|
|
|
|
|
|
case 'N': |
3490
|
|
|
|
|
|
/* In a non-pattern \N must be a named character, like \N{LATIN |
3491
|
|
|
|
|
|
* SMALL LETTER A} or \N{U+0041}. For patterns, it also can |
3492
|
|
|
|
|
|
* mean to match a non-newline. For non-patterns, named |
3493
|
|
|
|
|
|
* characters are converted to their string equivalents. In |
3494
|
|
|
|
|
|
* patterns, named characters are not converted to their |
3495
|
|
|
|
|
|
* ultimate forms for the same reasons that other escapes |
3496
|
|
|
|
|
|
* aren't. Instead, they are converted to the \N{U+...} form |
3497
|
|
|
|
|
|
* to get the value from the charnames that is in effect right |
3498
|
|
|
|
|
|
* now, while preserving the fact that it was a named character |
3499
|
|
|
|
|
|
* so that the regex compiler knows this */ |
3500
|
|
|
|
|
|
|
3501
|
|
|
|
|
|
/* The structure of this section of code (besides checking for |
3502
|
|
|
|
|
|
* errors and upgrading to utf8) is: |
3503
|
|
|
|
|
|
* Further disambiguate between the two meanings of \N, and if |
3504
|
|
|
|
|
|
* not a charname, go process it elsewhere |
3505
|
|
|
|
|
|
* If of form \N{U+...}, pass it through if a pattern; |
3506
|
|
|
|
|
|
* otherwise convert to utf8 |
3507
|
|
|
|
|
|
* Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a |
3508
|
|
|
|
|
|
* pattern; otherwise convert to utf8 */ |
3509
|
|
|
|
|
|
|
3510
|
|
|
|
|
|
/* Here, s points to the 'N'; the test below is guaranteed to |
3511
|
|
|
|
|
|
* succeed if we are being called on a pattern as we already |
3512
|
|
|
|
|
|
* know from a test above that the next character is a '{'. |
3513
|
|
|
|
|
|
* On a non-pattern \N must mean 'named sequence, which |
3514
|
|
|
|
|
|
* requires braces */ |
3515
|
3180
|
|
|
|
|
s++; |
3516
|
3180
|
100
|
|
|
|
if (*s != '{') { |
3517
|
42
|
|
|
|
|
yyerror("Missing braces on \\N{}"); |
3518
|
38
|
|
|
|
|
continue; |
3519
|
|
|
|
|
|
} |
3520
|
3138
|
|
|
|
|
s++; |
3521
|
|
|
|
|
|
|
3522
|
|
|
|
|
|
/* If there is no matching '}', it is an error. */ |
3523
|
3138
|
100
|
|
|
|
if (! (e = strchr(s, '}'))) { |
3524
|
56
|
100
|
|
|
|
if (! PL_lex_inpat) { |
3525
|
42
|
|
|
|
|
yyerror("Missing right brace on \\N{}"); |
3526
|
|
|
|
|
|
} else { |
3527
|
14
|
|
|
|
|
yyerror("Missing right brace on \\N{} or unescaped left brace after \\N."); |
3528
|
|
|
|
|
|
} |
3529
|
52
|
|
|
|
|
continue; |
3530
|
|
|
|
|
|
} |
3531
|
|
|
|
|
|
|
3532
|
|
|
|
|
|
/* Here it looks like a named character */ |
3533
|
|
|
|
|
|
|
3534
|
3082
|
100
|
|
|
|
if (*s == 'U' && s[1] == '+') { /* \N{U+...} */ |
|
|
100
|
|
|
|
|
3535
|
504
|
|
|
|
|
I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
3536
|
|
|
|
|
|
| PERL_SCAN_DISALLOW_PREFIX; |
3537
|
|
|
|
|
|
STRLEN len; |
3538
|
|
|
|
|
|
|
3539
|
|
|
|
|
|
/* For \N{U+...}, the '...' is a unicode value even on |
3540
|
|
|
|
|
|
* EBCDIC machines */ |
3541
|
504
|
|
|
|
|
s += 2; /* Skip to next char after the 'U+' */ |
3542
|
504
|
|
|
|
|
len = e - s; |
3543
|
504
|
|
|
|
|
uv = grok_hex(s, &len, &flags, NULL); |
3544
|
448
|
100
|
|
|
|
if (len == 0 || len != (STRLEN)(e - s)) { |
|
|
50
|
|
|
|
|
3545
|
82
|
|
|
|
|
yyerror("Invalid hexadecimal number in \\N{U+...}"); |
3546
|
78
|
|
|
|
|
s = e + 1; |
3547
|
78
|
|
|
|
|
continue; |
3548
|
|
|
|
|
|
} |
3549
|
|
|
|
|
|
|
3550
|
366
|
100
|
|
|
|
if (PL_lex_inpat) { |
3551
|
|
|
|
|
|
|
3552
|
|
|
|
|
|
/* On non-EBCDIC platforms, pass through to the regex |
3553
|
|
|
|
|
|
* compiler unchanged. The reason we evaluated the |
3554
|
|
|
|
|
|
* number above is to make sure there wasn't a syntax |
3555
|
|
|
|
|
|
* error. But on EBCDIC we convert to native so |
3556
|
|
|
|
|
|
* downstream code can continue to assume it's native |
3557
|
|
|
|
|
|
*/ |
3558
|
284
|
|
|
|
|
s -= 5; /* Include the '\N{U+' */ |
3559
|
|
|
|
|
|
#ifdef EBCDIC |
3560
|
|
|
|
|
|
d += my_snprintf(d, e - s + 1 + 1, /* includes the } |
3561
|
|
|
|
|
|
and the \0 */ |
3562
|
|
|
|
|
|
"\\N{U+%X}", |
3563
|
|
|
|
|
|
(unsigned int) UNI_TO_NATIVE(uv)); |
3564
|
|
|
|
|
|
#else |
3565
|
284
|
|
|
|
|
Copy(s, d, e - s + 1, char); /* 1 = include the } */ |
3566
|
284
|
|
|
|
|
d += e - s + 1; |
3567
|
|
|
|
|
|
#endif |
3568
|
|
|
|
|
|
} |
3569
|
|
|
|
|
|
else { /* Not a pattern: convert the hex to string */ |
3570
|
|
|
|
|
|
|
3571
|
|
|
|
|
|
/* If destination is not in utf8, unconditionally |
3572
|
|
|
|
|
|
* recode it to be so. This is because \N{} implies |
3573
|
|
|
|
|
|
* Unicode semantics, and scalars have to be in utf8 |
3574
|
|
|
|
|
|
* to guarantee those semantics */ |
3575
|
82
|
100
|
|
|
|
if (! has_utf8) { |
3576
|
56
|
|
|
|
|
SvCUR_set(sv, d - SvPVX_const(sv)); |
3577
|
56
|
|
|
|
|
SvPOK_on(sv); |
3578
|
56
|
|
|
|
|
*d = '\0'; |
3579
|
|
|
|
|
|
/* See Note on sizing above. */ |
3580
|
56
|
50
|
|
|
|
sv_utf8_upgrade_flags_grow( |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3581
|
|
|
|
|
|
sv, |
3582
|
|
|
|
|
|
SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, |
3583
|
|
|
|
|
|
UNISKIP(uv) + (STRLEN)(send - e) + 1); |
3584
|
56
|
|
|
|
|
d = SvPVX(sv) + SvCUR(sv); |
3585
|
|
|
|
|
|
has_utf8 = TRUE; |
3586
|
|
|
|
|
|
} |
3587
|
|
|
|
|
|
|
3588
|
|
|
|
|
|
/* Add the (Unicode) code point to the output. */ |
3589
|
82
|
100
|
|
|
|
if (UNI_IS_INVARIANT(uv)) { |
3590
|
8
|
|
|
|
|
*d++ = (char) LATIN1_TO_NATIVE(uv); |
3591
|
|
|
|
|
|
} |
3592
|
|
|
|
|
|
else { |
3593
|
74
|
|
|
|
|
d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0); |
3594
|
|
|
|
|
|
} |
3595
|
|
|
|
|
|
} |
3596
|
|
|
|
|
|
} |
3597
|
|
|
|
|
|
else /* Here is \N{NAME} but not \N{U+...}. */ |
3598
|
2578
|
100
|
|
|
|
if ((res = get_and_check_backslash_N_name(s, e))) |
3599
|
|
|
|
|
|
{ |
3600
|
|
|
|
|
|
STRLEN len; |
3601
|
2436
|
50
|
|
|
|
const char *str = SvPV_const(res, len); |
3602
|
2436
|
100
|
|
|
|
if (PL_lex_inpat) { |
3603
|
|
|
|
|
|
|
3604
|
172
|
100
|
|
|
|
if (! len) { /* The name resolved to an empty string */ |
3605
|
12
|
|
|
|
|
Copy("\\N{}", d, 4, char); |
3606
|
12
|
|
|
|
|
d += 4; |
3607
|
|
|
|
|
|
} |
3608
|
|
|
|
|
|
else { |
3609
|
|
|
|
|
|
/* In order to not lose information for the regex |
3610
|
|
|
|
|
|
* compiler, pass the result in the specially made |
3611
|
|
|
|
|
|
* syntax: \N{U+c1.c2.c3...}, where c1 etc. are |
3612
|
|
|
|
|
|
* the code points in hex of each character |
3613
|
|
|
|
|
|
* returned by charnames */ |
3614
|
|
|
|
|
|
|
3615
|
160
|
|
|
|
|
const char *str_end = str + len; |
3616
|
160
|
|
|
|
|
const STRLEN off = d - SvPVX_const(sv); |
3617
|
|
|
|
|
|
|
3618
|
160
|
100
|
|
|
|
if (! SvUTF8(res)) { |
3619
|
|
|
|
|
|
/* For the non-UTF-8 case, we can determine the |
3620
|
|
|
|
|
|
* exact length needed without having to parse |
3621
|
|
|
|
|
|
* through the string. Each character takes up |
3622
|
|
|
|
|
|
* 2 hex digits plus either a trailing dot or |
3623
|
|
|
|
|
|
* the "}" */ |
3624
|
22
|
50
|
|
|
|
d = off + SvGROW(sv, off |
|
|
100
|
|
|
|
|
3625
|
|
|
|
|
|
+ 3 * len |
3626
|
|
|
|
|
|
+ 6 /* For the "\N{U+", and |
3627
|
|
|
|
|
|
trailing NUL */ |
3628
|
|
|
|
|
|
+ (STRLEN)(send - e)); |
3629
|
22
|
|
|
|
|
Copy("\\N{U+", d, 5, char); |
3630
|
22
|
|
|
|
|
d += 5; |
3631
|
1603
|
100
|
|
|
|
while (str < str_end) { |
3632
|
|
|
|
|
|
char hex_string[4]; |
3633
|
2355
|
50
|
|
|
|
my_snprintf(hex_string, sizeof(hex_string), |
3634
|
|
|
|
|
|
"%02X.", (U8) *str); |
3635
|
1570
|
|
|
|
|
Copy(hex_string, d, 3, char); |
3636
|
1570
|
|
|
|
|
d += 3; |
3637
|
1570
|
|
|
|
|
str++; |
3638
|
|
|
|
|
|
} |
3639
|
22
|
|
|
|
|
d--; /* We will overwrite below the final |
3640
|
|
|
|
|
|
dot with a right brace */ |
3641
|
|
|
|
|
|
} |
3642
|
|
|
|
|
|
else { |
3643
|
|
|
|
|
|
STRLEN char_length; /* cur char's byte length */ |
3644
|
|
|
|
|
|
|
3645
|
|
|
|
|
|
/* and the number of bytes after this is |
3646
|
|
|
|
|
|
* translated into hex digits */ |
3647
|
|
|
|
|
|
STRLEN output_length; |
3648
|
|
|
|
|
|
|
3649
|
|
|
|
|
|
/* 2 hex per byte; 2 chars for '\N'; 2 chars |
3650
|
|
|
|
|
|
* for max('U+', '.'); and 1 for NUL */ |
3651
|
|
|
|
|
|
char hex_string[2 * UTF8_MAXBYTES + 5]; |
3652
|
|
|
|
|
|
|
3653
|
|
|
|
|
|
/* Get the first character of the result. */ |
3654
|
138
|
|
|
|
|
U32 uv = utf8n_to_uvchr((U8 *) str, |
3655
|
|
|
|
|
|
len, |
3656
|
|
|
|
|
|
&char_length, |
3657
|
|
|
|
|
|
UTF8_ALLOW_ANYUV); |
3658
|
|
|
|
|
|
/* Convert first code point to hex, including |
3659
|
|
|
|
|
|
* the boiler plate before it. */ |
3660
|
138
|
|
|
|
|
output_length = |
3661
|
138
|
50
|
|
|
|
my_snprintf(hex_string, sizeof(hex_string), |
3662
|
|
|
|
|
|
"\\N{U+%X", |
3663
|
|
|
|
|
|
(unsigned int) uv); |
3664
|
|
|
|
|
|
|
3665
|
|
|
|
|
|
/* Make sure there is enough space to hold it */ |
3666
|
138
|
50
|
|
|
|
d = off + SvGROW(sv, off |
|
|
50
|
|
|
|
|
3667
|
|
|
|
|
|
+ output_length |
3668
|
|
|
|
|
|
+ (STRLEN)(send - e) |
3669
|
|
|
|
|
|
+ 2); /* '}' + NUL */ |
3670
|
|
|
|
|
|
/* And output it */ |
3671
|
138
|
|
|
|
|
Copy(hex_string, d, output_length, char); |
3672
|
138
|
|
|
|
|
d += output_length; |
3673
|
|
|
|
|
|
|
3674
|
|
|
|
|
|
/* For each subsequent character, append dot and |
3675
|
|
|
|
|
|
* its ordinal in hex */ |
3676
|
211
|
100
|
|
|
|
while ((str += char_length) < str_end) { |
3677
|
4
|
|
|
|
|
const STRLEN off = d - SvPVX_const(sv); |
3678
|
4
|
|
|
|
|
U32 uv = utf8n_to_uvchr((U8 *) str, |
3679
|
|
|
|
|
|
str_end - str, |
3680
|
|
|
|
|
|
&char_length, |
3681
|
|
|
|
|
|
UTF8_ALLOW_ANYUV); |
3682
|
4
|
|
|
|
|
output_length = |
3683
|
4
|
50
|
|
|
|
my_snprintf(hex_string, |
3684
|
|
|
|
|
|
sizeof(hex_string), |
3685
|
|
|
|
|
|
".%X", |
3686
|
|
|
|
|
|
(unsigned int) uv); |
3687
|
|
|
|
|
|
|
3688
|
4
|
50
|
|
|
|
d = off + SvGROW(sv, off |
|
|
50
|
|
|
|
|
3689
|
|
|
|
|
|
+ output_length |
3690
|
|
|
|
|
|
+ (STRLEN)(send - e) |
3691
|
|
|
|
|
|
+ 2); /* '}' + NUL */ |
3692
|
4
|
|
|
|
|
Copy(hex_string, d, output_length, char); |
3693
|
4
|
|
|
|
|
d += output_length; |
3694
|
|
|
|
|
|
} |
3695
|
|
|
|
|
|
} |
3696
|
|
|
|
|
|
|
3697
|
160
|
|
|
|
|
*d++ = '}'; /* Done. Add the trailing brace */ |
3698
|
|
|
|
|
|
} |
3699
|
|
|
|
|
|
} |
3700
|
|
|
|
|
|
else { /* Here, not in a pattern. Convert the name to a |
3701
|
|
|
|
|
|
* string. */ |
3702
|
|
|
|
|
|
|
3703
|
|
|
|
|
|
/* If destination is not in utf8, unconditionally |
3704
|
|
|
|
|
|
* recode it to be so. This is because \N{} implies |
3705
|
|
|
|
|
|
* Unicode semantics, and scalars have to be in utf8 |
3706
|
|
|
|
|
|
* to guarantee those semantics */ |
3707
|
2264
|
100
|
|
|
|
if (! has_utf8) { |
3708
|
2232
|
|
|
|
|
SvCUR_set(sv, d - SvPVX_const(sv)); |
3709
|
2232
|
|
|
|
|
SvPOK_on(sv); |
3710
|
2232
|
|
|
|
|
*d = '\0'; |
3711
|
|
|
|
|
|
/* See Note on sizing above. */ |
3712
|
2232
|
|
|
|
|
sv_utf8_upgrade_flags_grow(sv, |
3713
|
|
|
|
|
|
SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, |
3714
|
|
|
|
|
|
len + (STRLEN)(send - s) + 1); |
3715
|
2232
|
|
|
|
|
d = SvPVX(sv) + SvCUR(sv); |
3716
|
|
|
|
|
|
has_utf8 = TRUE; |
3717
|
32
|
50
|
|
|
|
} else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */ |
3718
|
|
|
|
|
|
|
3719
|
|
|
|
|
|
/* See Note on sizing above. (NOTE: SvCUR() is not |
3720
|
|
|
|
|
|
* set correctly here). */ |
3721
|
0
|
|
|
|
|
const STRLEN off = d - SvPVX_const(sv); |
3722
|
0
|
0
|
|
|
|
d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1); |
|
|
0
|
|
|
|
|
3723
|
|
|
|
|
|
} |
3724
|
2264
|
|
|
|
|
Copy(str, d, len, char); |
3725
|
2264
|
|
|
|
|
d += len; |
3726
|
|
|
|
|
|
} |
3727
|
|
|
|
|
|
|
3728
|
2436
|
|
|
|
|
SvREFCNT_dec(res); |
3729
|
|
|
|
|
|
|
3730
|
|
|
|
|
|
} /* End \N{NAME} */ |
3731
|
|
|
|
|
|
#ifdef EBCDIC |
3732
|
|
|
|
|
|
if (!dorange) |
3733
|
|
|
|
|
|
native_range = FALSE; /* \N{} is defined to be Unicode */ |
3734
|
|
|
|
|
|
#endif |
3735
|
2932
|
|
|
|
|
s = e + 1; /* Point to just after the '}' */ |
3736
|
2932
|
|
|
|
|
continue; |
3737
|
|
|
|
|
|
|
3738
|
|
|
|
|
|
/* \c is a control character */ |
3739
|
|
|
|
|
|
case 'c': |
3740
|
231466
|
|
|
|
|
s++; |
3741
|
231466
|
100
|
|
|
|
if (s < send) { |
3742
|
231424
|
|
|
|
|
*d++ = grok_bslash_c(*s++, has_utf8, 1); |
3743
|
|
|
|
|
|
} |
3744
|
|
|
|
|
|
else { |
3745
|
42
|
|
|
|
|
yyerror("Missing control char name in \\c"); |
3746
|
|
|
|
|
|
} |
3747
|
231454
|
|
|
|
|
continue; |
3748
|
|
|
|
|
|
|
3749
|
|
|
|
|
|
/* printf-style backslashes, formfeeds, newlines, etc */ |
3750
|
|
|
|
|
|
case 'b': |
3751
|
77326
|
|
|
|
|
*d++ = '\b'; |
3752
|
77326
|
|
|
|
|
break; |
3753
|
|
|
|
|
|
case 'n': |
3754
|
2602192
|
|
|
|
|
*d++ = '\n'; |
3755
|
2602192
|
|
|
|
|
break; |
3756
|
|
|
|
|
|
case 'r': |
3757
|
25598
|
|
|
|
|
*d++ = '\r'; |
3758
|
25598
|
|
|
|
|
break; |
3759
|
|
|
|
|
|
case 'f': |
3760
|
59390
|
|
|
|
|
*d++ = '\f'; |
3761
|
59390
|
|
|
|
|
break; |
3762
|
|
|
|
|
|
case 't': |
3763
|
632333
|
|
|
|
|
*d++ = '\t'; |
3764
|
632333
|
|
|
|
|
break; |
3765
|
|
|
|
|
|
case 'e': |
3766
|
11906
|
|
|
|
|
*d++ = ASCII_TO_NATIVE('\033'); |
3767
|
11906
|
|
|
|
|
break; |
3768
|
|
|
|
|
|
case 'a': |
3769
|
14984
|
|
|
|
|
*d++ = '\a'; |
3770
|
14984
|
|
|
|
|
break; |
3771
|
|
|
|
|
|
} /* end switch */ |
3772
|
|
|
|
|
|
|
3773
|
3423729
|
|
|
|
|
s++; |
3774
|
3423729
|
|
|
|
|
continue; |
3775
|
|
|
|
|
|
} /* end if (backslash) */ |
3776
|
|
|
|
|
|
#ifdef EBCDIC |
3777
|
|
|
|
|
|
else |
3778
|
|
|
|
|
|
literal_endpoint++; |
3779
|
|
|
|
|
|
#endif |
3780
|
|
|
|
|
|
|
3781
|
|
|
|
|
|
default_action: |
3782
|
|
|
|
|
|
/* If we started with encoded form, or already know we want it, |
3783
|
|
|
|
|
|
then encode the next character */ |
3784
|
188335713
|
100
|
|
|
|
if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3785
|
43734
|
|
|
|
|
STRLEN len = 1; |
3786
|
|
|
|
|
|
|
3787
|
|
|
|
|
|
|
3788
|
|
|
|
|
|
/* One might think that it is wasted effort in the case of the |
3789
|
|
|
|
|
|
* source being utf8 (this_utf8 == TRUE) to take the next character |
3790
|
|
|
|
|
|
* in the source, convert it to an unsigned value, and then convert |
3791
|
|
|
|
|
|
* it back again. But the source has not been validated here. The |
3792
|
|
|
|
|
|
* routine that does the conversion checks for errors like |
3793
|
|
|
|
|
|
* malformed utf8 */ |
3794
|
|
|
|
|
|
|
3795
|
|
|
|
|
|
const UV nextuv = (this_utf8) |
3796
|
43730
|
|
|
|
|
? utf8n_to_uvchr((U8*)s, send - s, &len, 0) |
3797
|
65599
|
100
|
|
|
|
: (UV) ((U8) *s); |
3798
|
43734
|
100
|
|
|
|
const STRLEN need = UNISKIP(nextuv); |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3799
|
43734
|
100
|
|
|
|
if (!has_utf8) { |
3800
|
38318
|
|
|
|
|
SvCUR_set(sv, d - SvPVX_const(sv)); |
3801
|
38318
|
|
|
|
|
SvPOK_on(sv); |
3802
|
38318
|
|
|
|
|
*d = '\0'; |
3803
|
|
|
|
|
|
/* See Note on sizing above. */ |
3804
|
38318
|
|
|
|
|
sv_utf8_upgrade_flags_grow(sv, |
3805
|
|
|
|
|
|
SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, |
3806
|
|
|
|
|
|
need + (STRLEN)(send - s) + 1); |
3807
|
38318
|
|
|
|
|
d = SvPVX(sv) + SvCUR(sv); |
3808
|
|
|
|
|
|
has_utf8 = TRUE; |
3809
|
5416
|
100
|
|
|
|
} else if (need > len) { |
3810
|
|
|
|
|
|
/* encoded value larger than old, may need extra space (NOTE: |
3811
|
|
|
|
|
|
* SvCUR() is not set correctly here). See Note on sizing |
3812
|
|
|
|
|
|
* above. */ |
3813
|
4
|
|
|
|
|
const STRLEN off = d - SvPVX_const(sv); |
3814
|
4
|
50
|
|
|
|
d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off; |
|
|
50
|
|
|
|
|
3815
|
|
|
|
|
|
} |
3816
|
43734
|
|
|
|
|
s += len; |
3817
|
|
|
|
|
|
|
3818
|
43734
|
|
|
|
|
d = (char*)uvchr_to_utf8((U8*)d, nextuv); |
3819
|
|
|
|
|
|
#ifdef EBCDIC |
3820
|
|
|
|
|
|
if (uv > 255 && !dorange) |
3821
|
|
|
|
|
|
native_range = FALSE; |
3822
|
|
|
|
|
|
#endif |
3823
|
|
|
|
|
|
} |
3824
|
|
|
|
|
|
else { |
3825
|
206923360
|
|
|
|
|
*d++ = *s++; |
3826
|
|
|
|
|
|
} |
3827
|
|
|
|
|
|
} /* while loop to process each character */ |
3828
|
|
|
|
|
|
|
3829
|
|
|
|
|
|
/* terminate the string and set up the sv */ |
3830
|
22710137
|
|
|
|
|
*d = '\0'; |
3831
|
22710137
|
|
|
|
|
SvCUR_set(sv, d - SvPVX_const(sv)); |
3832
|
22710137
|
50
|
|
|
|
if (SvCUR(sv) >= SvLEN(sv)) |
3833
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf |
3834
|
0
|
|
|
|
|
" >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv)); |
3835
|
|
|
|
|
|
|
3836
|
22710137
|
|
|
|
|
SvPOK_on(sv); |
3837
|
22710137
|
100
|
|
|
|
if (PL_encoding && !has_utf8) { |
|
|
100
|
|
|
|
|
3838
|
732
|
|
|
|
|
sv_recode_to_utf8(sv, PL_encoding); |
3839
|
732
|
50
|
|
|
|
if (SvUTF8(sv)) |
3840
|
|
|
|
|
|
has_utf8 = TRUE; |
3841
|
|
|
|
|
|
} |
3842
|
22710137
|
100
|
|
|
|
if (has_utf8) { |
3843
|
305900
|
|
|
|
|
SvUTF8_on(sv); |
3844
|
305900
|
100
|
|
|
|
if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { |
|
|
50
|
|
|
|
|
3845
|
324
|
100
|
|
|
|
PL_sublex_info.sub_op->op_private |= |
3846
|
216
|
|
|
|
|
(PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF); |
3847
|
|
|
|
|
|
} |
3848
|
|
|
|
|
|
} |
3849
|
|
|
|
|
|
|
3850
|
|
|
|
|
|
/* shrink the sv if we allocated more than we used */ |
3851
|
22710137
|
100
|
|
|
|
if (SvCUR(sv) + 5 < SvLEN(sv)) { |
3852
|
20928118
|
|
|
|
|
SvPV_shrink_to_cur(sv); |
3853
|
|
|
|
|
|
} |
3854
|
|
|
|
|
|
|
3855
|
|
|
|
|
|
/* return the substring (via pl_yylval) only if we parsed anything */ |
3856
|
22710137
|
100
|
|
|
|
if (s > PL_bufptr) { |
3857
|
19981035
|
|
|
|
|
char *s2 = PL_bufptr; |
3858
|
359563858
|
100
|
|
|
|
for (; s2 < s; s2++) { |
3859
|
339582823
|
100
|
|
|
|
if (*s2 == '\n') |
3860
|
1632227
|
100
|
|
|
|
COPLINE_INC_WITH_HERELINES; |
3861
|
|
|
|
|
|
} |
3862
|
19981035
|
|
|
|
|
SvREFCNT_inc_simple_void_NN(sv); |
3863
|
19981035
|
100
|
|
|
|
if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING )) |
|
|
100
|
|
|
|
|
3864
|
118
|
100
|
|
|
|
&& ! PL_parser->lex_re_reparsing) |
3865
|
|
|
|
|
|
{ |
3866
|
86
|
100
|
|
|
|
const char *const key = PL_lex_inpat ? "qr" : "q"; |
3867
|
86
|
100
|
|
|
|
const STRLEN keylen = PL_lex_inpat ? 2 : 1; |
3868
|
|
|
|
|
|
const char *type; |
3869
|
|
|
|
|
|
STRLEN typelen; |
3870
|
|
|
|
|
|
|
3871
|
86
|
100
|
|
|
|
if (PL_lex_inwhat == OP_TRANS) { |
3872
|
|
|
|
|
|
type = "tr"; |
3873
|
|
|
|
|
|
typelen = 2; |
3874
|
82
|
100
|
|
|
|
} else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) { |
|
|
50
|
|
|
|
|
3875
|
|
|
|
|
|
type = "s"; |
3876
|
|
|
|
|
|
typelen = 1; |
3877
|
78
|
100
|
|
|
|
} else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') { |
|
|
100
|
|
|
|
|
3878
|
|
|
|
|
|
type = "q"; |
3879
|
|
|
|
|
|
typelen = 1; |
3880
|
|
|
|
|
|
} else { |
3881
|
|
|
|
|
|
type = "qq"; |
3882
|
|
|
|
|
|
typelen = 2; |
3883
|
|
|
|
|
|
} |
3884
|
|
|
|
|
|
|
3885
|
86
|
|
|
|
|
sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL, |
3886
|
|
|
|
|
|
type, typelen); |
3887
|
|
|
|
|
|
} |
3888
|
19981035
|
|
|
|
|
pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); |
3889
|
|
|
|
|
|
} |
3890
|
22710137
|
|
|
|
|
LEAVE_with_name("scan_const"); |
3891
|
22710137
|
|
|
|
|
return s; |
3892
|
|
|
|
|
|
} |
3893
|
|
|
|
|
|
|
3894
|
|
|
|
|
|
/* S_intuit_more |
3895
|
|
|
|
|
|
* Returns TRUE if there's more to the expression (e.g., a subscript), |
3896
|
|
|
|
|
|
* FALSE otherwise. |
3897
|
|
|
|
|
|
* |
3898
|
|
|
|
|
|
* It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/ |
3899
|
|
|
|
|
|
* |
3900
|
|
|
|
|
|
* ->[ and ->{ return TRUE |
3901
|
|
|
|
|
|
* { and [ outside a pattern are always subscripts, so return TRUE |
3902
|
|
|
|
|
|
* if we're outside a pattern and it's not { or [, then return FALSE |
3903
|
|
|
|
|
|
* if we're in a pattern and the first char is a { |
3904
|
|
|
|
|
|
* {4,5} (any digits around the comma) returns FALSE |
3905
|
|
|
|
|
|
* if we're in a pattern and the first char is a [ |
3906
|
|
|
|
|
|
* [] returns FALSE |
3907
|
|
|
|
|
|
* [SOMETHING] has a funky algorithm to decide whether it's a |
3908
|
|
|
|
|
|
* character class or not. It has to deal with things like |
3909
|
|
|
|
|
|
* /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/ |
3910
|
|
|
|
|
|
* anything else returns TRUE |
3911
|
|
|
|
|
|
*/ |
3912
|
|
|
|
|
|
|
3913
|
|
|
|
|
|
/* This is the one truly awful dwimmer necessary to conflate C and sed. */ |
3914
|
|
|
|
|
|
|
3915
|
|
|
|
|
|
STATIC int |
3916
|
136239962
|
|
|
|
|
S_intuit_more(pTHX_ char *s) |
3917
|
|
|
|
|
|
{ |
3918
|
|
|
|
|
|
dVAR; |
3919
|
|
|
|
|
|
|
3920
|
|
|
|
|
|
PERL_ARGS_ASSERT_INTUIT_MORE; |
3921
|
|
|
|
|
|
|
3922
|
136239962
|
100
|
|
|
|
if (PL_lex_brackets) |
3923
|
|
|
|
|
|
return TRUE; |
3924
|
23666468
|
100
|
|
|
|
if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{')) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3925
|
|
|
|
|
|
return TRUE; |
3926
|
22970064
|
100
|
|
|
|
if (*s != '{' && *s != '[') |
3927
|
|
|
|
|
|
return FALSE; |
3928
|
1521148
|
100
|
|
|
|
if (!PL_lex_inpat) |
3929
|
|
|
|
|
|
return TRUE; |
3930
|
|
|
|
|
|
|
3931
|
|
|
|
|
|
/* In a pattern, so maybe we have {n,m}. */ |
3932
|
20826
|
100
|
|
|
|
if (*s == '{') { |
3933
|
13974
|
100
|
|
|
|
if (regcurly(s, FALSE)) { |
3934
|
|
|
|
|
|
return FALSE; |
3935
|
|
|
|
|
|
} |
3936
|
7942
|
|
|
|
|
return TRUE; |
3937
|
|
|
|
|
|
} |
3938
|
|
|
|
|
|
|
3939
|
|
|
|
|
|
/* On the other hand, maybe we have a character class */ |
3940
|
|
|
|
|
|
|
3941
|
6852
|
|
|
|
|
s++; |
3942
|
6852
|
100
|
|
|
|
if (*s == ']' || *s == '^') |
3943
|
|
|
|
|
|
return FALSE; |
3944
|
|
|
|
|
|
else { |
3945
|
|
|
|
|
|
/* this is terrifying, and it works */ |
3946
|
|
|
|
|
|
int weight; |
3947
|
|
|
|
|
|
char seen[256]; |
3948
|
6792
|
|
|
|
|
const char * const send = strchr(s,']'); |
3949
|
|
|
|
|
|
unsigned char un_char, last_un_char; |
3950
|
|
|
|
|
|
char tmpbuf[sizeof PL_tokenbuf * 4]; |
3951
|
|
|
|
|
|
|
3952
|
6792
|
50
|
|
|
|
if (!send) /* has to be an expression */ |
3953
|
|
|
|
|
|
return TRUE; |
3954
|
|
|
|
|
|
weight = 2; /* let's weigh the evidence */ |
3955
|
|
|
|
|
|
|
3956
|
6792
|
100
|
|
|
|
if (*s == '$') |
3957
|
|
|
|
|
|
weight -= 3; |
3958
|
6452
|
100
|
|
|
|
else if (isDIGIT(*s)) { |
3959
|
5916
|
50
|
|
|
|
if (s[1] != ']') { |
3960
|
0
|
0
|
|
|
|
if (isDIGIT(s[1]) && s[2] == ']') |
|
|
0
|
|
|
|
|
3961
|
|
|
|
|
|
weight -= 10; |
3962
|
|
|
|
|
|
} |
3963
|
|
|
|
|
|
else |
3964
|
|
|
|
|
|
weight -= 100; |
3965
|
|
|
|
|
|
} |
3966
|
|
|
|
|
|
Zero(seen,256,char); |
3967
|
|
|
|
|
|
un_char = 255; |
3968
|
16812
|
100
|
|
|
|
for (; s < send; s++) { |
3969
|
|
|
|
|
|
last_un_char = un_char; |
3970
|
10020
|
|
|
|
|
un_char = (unsigned char)*s; |
3971
|
10020
|
|
|
|
|
switch (*s) { |
3972
|
|
|
|
|
|
case '@': |
3973
|
|
|
|
|
|
case '&': |
3974
|
|
|
|
|
|
case '$': |
3975
|
340
|
|
|
|
|
weight -= seen[un_char] * 10; |
3976
|
340
|
50
|
|
|
|
if (isWORDCHAR_lazy_if(s+1,UTF)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
3977
|
|
|
|
|
|
int len; |
3978
|
340
|
|
|
|
|
scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE); |
3979
|
340
|
|
|
|
|
len = (int)strlen(tmpbuf); |
3980
|
340
|
100
|
|
|
|
if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
3981
|
|
|
|
|
|
UTF ? SVf_UTF8 : 0, SVt_PV)) |
3982
|
0
|
|
|
|
|
weight -= 100; |
3983
|
|
|
|
|
|
else |
3984
|
340
|
|
|
|
|
weight -= 10; |
3985
|
|
|
|
|
|
} |
3986
|
0
|
0
|
|
|
|
else if (*s == '$' && s[1] && |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3987
|
0
|
|
|
|
|
strchr("[#!%*<>()-=",s[1])) { |
3988
|
0
|
0
|
|
|
|
if (/*{*/ strchr("])} =",s[2])) |
3989
|
0
|
|
|
|
|
weight -= 10; |
3990
|
|
|
|
|
|
else |
3991
|
0
|
|
|
|
|
weight -= 1; |
3992
|
|
|
|
|
|
} |
3993
|
|
|
|
|
|
break; |
3994
|
|
|
|
|
|
case '\\': |
3995
|
|
|
|
|
|
un_char = 254; |
3996
|
1044
|
50
|
|
|
|
if (s[1]) { |
3997
|
1044
|
100
|
|
|
|
if (strchr("wds]",s[1])) |
3998
|
4
|
|
|
|
|
weight += 100; |
3999
|
1040
|
50
|
|
|
|
else if (seen[(U8)'\''] || seen[(U8)'"']) |
|
|
50
|
|
|
|
|
4000
|
0
|
|
|
|
|
weight += 1; |
4001
|
1040
|
50
|
|
|
|
else if (strchr("rnftbxcav",s[1])) |
4002
|
0
|
|
|
|
|
weight += 40; |
4003
|
1040
|
50
|
|
|
|
else if (isDIGIT(s[1])) { |
4004
|
0
|
|
|
|
|
weight += 40; |
4005
|
0
|
0
|
|
|
|
while (s[1] && isDIGIT(s[1])) |
|
|
0
|
|
|
|
|
4006
|
0
|
|
|
|
|
s++; |
4007
|
|
|
|
|
|
} |
4008
|
|
|
|
|
|
} |
4009
|
|
|
|
|
|
else |
4010
|
0
|
|
|
|
|
weight += 100; |
4011
|
|
|
|
|
|
break; |
4012
|
|
|
|
|
|
case '-': |
4013
|
12
|
50
|
|
|
|
if (s[1] == '\\') |
4014
|
0
|
|
|
|
|
weight += 50; |
4015
|
12
|
100
|
|
|
|
if (strchr("aA01! ",last_un_char)) |
4016
|
4
|
|
|
|
|
weight += 30; |
4017
|
12
|
100
|
|
|
|
if (strchr("zZ79~",s[1])) |
4018
|
4
|
|
|
|
|
weight += 30; |
4019
|
12
|
100
|
|
|
|
if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$')) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
4020
|
8
|
|
|
|
|
weight -= 5; /* cope with negative subscript */ |
4021
|
|
|
|
|
|
break; |
4022
|
|
|
|
|
|
default: |
4023
|
8624
|
100
|
|
|
|
if (!isWORDCHAR(last_un_char) |
4024
|
7308
|
100
|
|
|
|
&& !(last_un_char == '$' || last_un_char == '@' |
|
|
50
|
|
|
|
|
4025
|
|
|
|
|
|
|| last_un_char == '&') |
4026
|
6968
|
100
|
|
|
|
&& isALPHA(*s) && s[1] && isALPHA(s[1])) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4027
|
|
|
|
|
|
char *d = tmpbuf; |
4028
|
0
|
0
|
|
|
|
while (isALPHA(*s)) |
4029
|
0
|
|
|
|
|
*d++ = *s++; |
4030
|
0
|
|
|
|
|
*d = '\0'; |
4031
|
0
|
0
|
|
|
|
if (keyword(tmpbuf, d - tmpbuf, 0)) |
4032
|
0
|
|
|
|
|
weight -= 150; |
4033
|
|
|
|
|
|
} |
4034
|
8624
|
50
|
|
|
|
if (un_char == last_un_char + 1) |
4035
|
0
|
|
|
|
|
weight += 5; |
4036
|
8624
|
|
|
|
|
weight -= seen[un_char]; |
4037
|
8624
|
|
|
|
|
break; |
4038
|
|
|
|
|
|
} |
4039
|
10020
|
|
|
|
|
seen[un_char]++; |
4040
|
|
|
|
|
|
} |
4041
|
6792
|
100
|
|
|
|
if (weight >= 0) /* probably a character class */ |
4042
|
|
|
|
|
|
return FALSE; |
4043
|
|
|
|
|
|
} |
4044
|
|
|
|
|
|
|
4045
|
70304664
|
|
|
|
|
return TRUE; |
4046
|
|
|
|
|
|
} |
4047
|
|
|
|
|
|
|
4048
|
|
|
|
|
|
/* |
4049
|
|
|
|
|
|
* S_intuit_method |
4050
|
|
|
|
|
|
* |
4051
|
|
|
|
|
|
* Does all the checking to disambiguate |
4052
|
|
|
|
|
|
* foo bar |
4053
|
|
|
|
|
|
* between foo(bar) and bar->foo. Returns 0 if not a method, otherwise |
4054
|
|
|
|
|
|
* FUNCMETH (bar->foo(args)) or METHOD (bar->foo args). |
4055
|
|
|
|
|
|
* |
4056
|
|
|
|
|
|
* First argument is the stuff after the first token, e.g. "bar". |
4057
|
|
|
|
|
|
* |
4058
|
|
|
|
|
|
* Not a method if foo is a filehandle. |
4059
|
|
|
|
|
|
* Not a method if foo is a subroutine prototyped to take a filehandle. |
4060
|
|
|
|
|
|
* Not a method if it's really "Foo $bar" |
4061
|
|
|
|
|
|
* Method if it's "foo $bar" |
4062
|
|
|
|
|
|
* Not a method if it's really "print foo $bar" |
4063
|
|
|
|
|
|
* Method if it's really "foo package::" (interpreted as package->foo) |
4064
|
|
|
|
|
|
* Not a method if bar is known to be a subroutine ("sub bar; foo bar") |
4065
|
|
|
|
|
|
* Not a method if bar is a filehandle or package, but is quoted with |
4066
|
|
|
|
|
|
* => |
4067
|
|
|
|
|
|
*/ |
4068
|
|
|
|
|
|
|
4069
|
|
|
|
|
|
STATIC int |
4070
|
765059
|
|
|
|
|
S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) |
4071
|
|
|
|
|
|
{ |
4072
|
|
|
|
|
|
dVAR; |
4073
|
765059
|
|
|
|
|
char *s = start + (*start == '$'); |
4074
|
|
|
|
|
|
char tmpbuf[sizeof PL_tokenbuf]; |
4075
|
|
|
|
|
|
STRLEN len; |
4076
|
|
|
|
|
|
GV* indirgv; |
4077
|
|
|
|
|
|
#ifdef PERL_MAD |
4078
|
|
|
|
|
|
int soff; |
4079
|
|
|
|
|
|
#endif |
4080
|
|
|
|
|
|
|
4081
|
|
|
|
|
|
PERL_ARGS_ASSERT_INTUIT_METHOD; |
4082
|
|
|
|
|
|
|
4083
|
765059
|
100
|
|
|
|
if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
4084
|
|
|
|
|
|
return 0; |
4085
|
683315
|
100
|
|
|
|
if (cv && SvPOK(cv)) { |
|
|
100
|
|
|
|
|
4086
|
164088
|
50
|
|
|
|
const char *proto = CvPROTO(cv); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
4087
|
164088
|
50
|
|
|
|
if (proto) { |
4088
|
164212
|
100
|
|
|
|
while (*proto && (isSPACE(*proto) || *proto == ';')) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4089
|
124
|
|
|
|
|
proto++; |
4090
|
164088
|
100
|
|
|
|
if (*proto == '*') |
4091
|
|
|
|
|
|
return 0; |
4092
|
|
|
|
|
|
} |
4093
|
|
|
|
|
|
} |
4094
|
|
|
|
|
|
|
4095
|
682693
|
100
|
|
|
|
if (*start == '$') { |
4096
|
347732
|
100
|
|
|
|
if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY || |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
4097
|
0
|
|
|
|
|
isUPPER(*PL_tokenbuf)) |
4098
|
|
|
|
|
|
return 0; |
4099
|
|
|
|
|
|
#ifdef PERL_MAD |
4100
|
|
|
|
|
|
len = start - SvPVX(PL_linestr); |
4101
|
|
|
|
|
|
#endif |
4102
|
0
|
|
|
|
|
s = PEEKSPACE(s); |
4103
|
|
|
|
|
|
#ifdef PERL_MAD |
4104
|
|
|
|
|
|
start = SvPVX(PL_linestr) + len; |
4105
|
|
|
|
|
|
#endif |
4106
|
0
|
|
|
|
|
PL_bufptr = start; |
4107
|
0
|
|
|
|
|
PL_expect = XREF; |
4108
|
0
|
0
|
|
|
|
return *s == '(' ? FUNCMETH : METHOD; |
4109
|
|
|
|
|
|
} |
4110
|
|
|
|
|
|
|
4111
|
334961
|
|
|
|
|
s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); |
4112
|
|
|
|
|
|
/* start is the beginning of the possible filehandle/object, |
4113
|
|
|
|
|
|
* and s is the end of it |
4114
|
|
|
|
|
|
* tmpbuf is a copy of it (but with single quotes as double colons) |
4115
|
|
|
|
|
|
*/ |
4116
|
|
|
|
|
|
|
4117
|
334961
|
100
|
|
|
|
if (!keyword(tmpbuf, len, 0)) { |
4118
|
177227
|
100
|
|
|
|
if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4119
|
4
|
|
|
|
|
len -= 2; |
4120
|
4
|
|
|
|
|
tmpbuf[len] = '\0'; |
4121
|
|
|
|
|
|
#ifdef PERL_MAD |
4122
|
|
|
|
|
|
soff = s - SvPVX(PL_linestr); |
4123
|
|
|
|
|
|
#endif |
4124
|
4
|
|
|
|
|
goto bare_package; |
4125
|
|
|
|
|
|
} |
4126
|
177223
|
50
|
|
|
|
indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
4127
|
177223
|
100
|
|
|
|
if (indirgv && GvCVu(indirgv)) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
4128
|
|
|
|
|
|
return 0; |
4129
|
|
|
|
|
|
/* filehandle or package name makes it a method */ |
4130
|
165865
|
100
|
|
|
|
if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4131
|
|
|
|
|
|
#ifdef PERL_MAD |
4132
|
|
|
|
|
|
soff = s - SvPVX(PL_linestr); |
4133
|
|
|
|
|
|
#endif |
4134
|
92615
|
|
|
|
|
s = PEEKSPACE(s); |
4135
|
92615
|
100
|
|
|
|
if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>') |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
4136
|
|
|
|
|
|
return 0; /* no assumptions -- "=>" quotes bareword */ |
4137
|
|
|
|
|
|
bare_package: |
4138
|
|
|
|
|
|
start_force(PL_curforce); |
4139
|
62949
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, |
4140
|
|
|
|
|
|
S_newSV_maybe_utf8(aTHX_ tmpbuf, len)); |
4141
|
62949
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE; |
4142
|
|
|
|
|
|
if (PL_madskills) |
4143
|
|
|
|
|
|
curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start, |
4144
|
|
|
|
|
|
( UTF ? SVf_UTF8 : 0 ))); |
4145
|
62949
|
|
|
|
|
PL_expect = XTERM; |
4146
|
62949
|
|
|
|
|
force_next(WORD); |
4147
|
62949
|
|
|
|
|
PL_bufptr = s; |
4148
|
|
|
|
|
|
#ifdef PERL_MAD |
4149
|
|
|
|
|
|
PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */ |
4150
|
|
|
|
|
|
#endif |
4151
|
433261
|
100
|
|
|
|
return *s == '(' ? FUNCMETH : METHOD; |
4152
|
|
|
|
|
|
} |
4153
|
|
|
|
|
|
} |
4154
|
|
|
|
|
|
return 0; |
4155
|
|
|
|
|
|
} |
4156
|
|
|
|
|
|
|
4157
|
|
|
|
|
|
/* Encoded script support. filter_add() effectively inserts a |
4158
|
|
|
|
|
|
* 'pre-processing' function into the current source input stream. |
4159
|
|
|
|
|
|
* Note that the filter function only applies to the current source file |
4160
|
|
|
|
|
|
* (e.g., it will not affect files 'require'd or 'use'd by this one). |
4161
|
|
|
|
|
|
* |
4162
|
|
|
|
|
|
* The datasv parameter (which may be NULL) can be used to pass |
4163
|
|
|
|
|
|
* private data to this instance of the filter. The filter function |
4164
|
|
|
|
|
|
* can recover the SV using the FILTER_DATA macro and use it to |
4165
|
|
|
|
|
|
* store private buffers and state information. |
4166
|
|
|
|
|
|
* |
4167
|
|
|
|
|
|
* The supplied datasv parameter is upgraded to a PVIO type |
4168
|
|
|
|
|
|
* and the IoDIRP/IoANY field is used to store the function pointer, |
4169
|
|
|
|
|
|
* and IOf_FAKE_DIRP is enabled on datasv to mark this as such. |
4170
|
|
|
|
|
|
* Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for |
4171
|
|
|
|
|
|
* private use must be set using malloc'd pointers. |
4172
|
|
|
|
|
|
*/ |
4173
|
|
|
|
|
|
|
4174
|
|
|
|
|
|
SV * |
4175
|
19730
|
|
|
|
|
Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) |
4176
|
19728
|
50
|
|
|
|
{ |
4177
|
|
|
|
|
|
dVAR; |
4178
|
19730
|
50
|
|
|
|
if (!funcp) |
4179
|
|
|
|
|
|
return NULL; |
4180
|
|
|
|
|
|
|
4181
|
19730
|
50
|
|
|
|
if (!PL_parser) |
4182
|
|
|
|
|
|
return NULL; |
4183
|
|
|
|
|
|
|
4184
|
19730
|
100
|
|
|
|
if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) |
4185
|
2
|
|
|
|
|
Perl_croak(aTHX_ "Source filters apply only to byte streams"); |
4186
|
|
|
|
|
|
|
4187
|
19728
|
100
|
|
|
|
if (!PL_rsfp_filters) |
4188
|
19690
|
|
|
|
|
PL_rsfp_filters = newAV(); |
4189
|
19728
|
100
|
|
|
|
if (!datasv) |
4190
|
19640
|
|
|
|
|
datasv = newSV(0); |
4191
|
29592
|
|
|
|
|
SvUPGRADE(datasv, SVt_PVIO); |
4192
|
19728
|
|
|
|
|
IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */ |
4193
|
19728
|
|
|
|
|
IoFLAGS(datasv) |= IOf_FAKE_DIRP; |
4194
|
|
|
|
|
|
DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n", |
4195
|
|
|
|
|
|
FPTR2DPTR(void *, IoANY(datasv)), |
4196
|
|
|
|
|
|
SvPV_nolen(datasv))); |
4197
|
19728
|
|
|
|
|
av_unshift(PL_rsfp_filters, 1); |
4198
|
19728
|
|
|
|
|
av_store(PL_rsfp_filters, 0, datasv) ; |
4199
|
19728
|
50
|
|
|
|
if ( |
4200
|
19728
|
|
|
|
|
!PL_parser->filtered |
4201
|
19728
|
100
|
|
|
|
&& PL_parser->lex_flags & LEX_EVALBYTES |
4202
|
2
|
50
|
|
|
|
&& PL_bufptr < PL_bufend |
4203
|
|
|
|
|
|
) { |
4204
|
2
|
|
|
|
|
const char *s = PL_bufptr; |
4205
|
9867
|
50
|
|
|
|
while (s < PL_bufend) { |
4206
|
2
|
50
|
|
|
|
if (*s == '\n') { |
4207
|
2
|
|
|
|
|
SV *linestr = PL_parser->linestr; |
4208
|
2
|
|
|
|
|
char *buf = SvPVX(linestr); |
4209
|
2
|
|
|
|
|
STRLEN const bufptr_pos = PL_parser->bufptr - buf; |
4210
|
2
|
|
|
|
|
STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf; |
4211
|
2
|
|
|
|
|
STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf; |
4212
|
2
|
|
|
|
|
STRLEN const linestart_pos = PL_parser->linestart - buf; |
4213
|
2
|
50
|
|
|
|
STRLEN const last_uni_pos = |
4214
|
2
|
|
|
|
|
PL_parser->last_uni ? PL_parser->last_uni - buf : 0; |
4215
|
2
|
50
|
|
|
|
STRLEN const last_lop_pos = |
4216
|
2
|
|
|
|
|
PL_parser->last_lop ? PL_parser->last_lop - buf : 0; |
4217
|
2
|
|
|
|
|
av_push(PL_rsfp_filters, linestr); |
4218
|
4
|
|
|
|
|
PL_parser->linestr = |
4219
|
2
|
|
|
|
|
newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr)); |
4220
|
2
|
|
|
|
|
buf = SvPVX(PL_parser->linestr); |
4221
|
2
|
|
|
|
|
PL_parser->bufend = buf + SvCUR(PL_parser->linestr); |
4222
|
2
|
|
|
|
|
PL_parser->bufptr = buf + bufptr_pos; |
4223
|
2
|
|
|
|
|
PL_parser->oldbufptr = buf + oldbufptr_pos; |
4224
|
2
|
|
|
|
|
PL_parser->oldoldbufptr = buf + oldoldbufptr_pos; |
4225
|
2
|
|
|
|
|
PL_parser->linestart = buf + linestart_pos; |
4226
|
2
|
50
|
|
|
|
if (PL_parser->last_uni) |
4227
|
0
|
|
|
|
|
PL_parser->last_uni = buf + last_uni_pos; |
4228
|
2
|
50
|
|
|
|
if (PL_parser->last_lop) |
4229
|
0
|
|
|
|
|
PL_parser->last_lop = buf + last_lop_pos; |
4230
|
2
|
|
|
|
|
SvLEN(linestr) = SvCUR(linestr); |
4231
|
2
|
|
|
|
|
SvCUR(linestr) = s-SvPVX(linestr); |
4232
|
2
|
|
|
|
|
PL_parser->filtered = 1; |
4233
|
2
|
|
|
|
|
break; |
4234
|
|
|
|
|
|
} |
4235
|
0
|
|
|
|
|
s++; |
4236
|
|
|
|
|
|
} |
4237
|
|
|
|
|
|
} |
4238
|
|
|
|
|
|
return(datasv); |
4239
|
|
|
|
|
|
} |
4240
|
|
|
|
|
|
|
4241
|
|
|
|
|
|
|
4242
|
|
|
|
|
|
/* Delete most recently added instance of this filter function. */ |
4243
|
|
|
|
|
|
void |
4244
|
11630
|
|
|
|
|
Perl_filter_del(pTHX_ filter_t funcp) |
4245
|
|
|
|
|
|
{ |
4246
|
|
|
|
|
|
dVAR; |
4247
|
|
|
|
|
|
SV *datasv; |
4248
|
|
|
|
|
|
|
4249
|
|
|
|
|
|
PERL_ARGS_ASSERT_FILTER_DEL; |
4250
|
|
|
|
|
|
|
4251
|
|
|
|
|
|
#ifdef DEBUGGING |
4252
|
|
|
|
|
|
DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", |
4253
|
|
|
|
|
|
FPTR2DPTR(void*, funcp))); |
4254
|
|
|
|
|
|
#endif |
4255
|
11630
|
50
|
|
|
|
if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4256
|
|
|
|
|
|
return; |
4257
|
|
|
|
|
|
/* if filter is on top of stack (usual case) just pop it off */ |
4258
|
11630
|
50
|
|
|
|
datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters)); |
4259
|
11630
|
50
|
|
|
|
if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) { |
4260
|
11630
|
|
|
|
|
sv_free(av_pop(PL_rsfp_filters)); |
4261
|
|
|
|
|
|
|
4262
|
11630
|
|
|
|
|
return; |
4263
|
|
|
|
|
|
} |
4264
|
|
|
|
|
|
/* we need to search for the correct entry and clear it */ |
4265
|
5815
|
|
|
|
|
Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)"); |
4266
|
|
|
|
|
|
} |
4267
|
|
|
|
|
|
|
4268
|
|
|
|
|
|
|
4269
|
|
|
|
|
|
/* Invoke the idxth filter function for the current rsfp. */ |
4270
|
|
|
|
|
|
/* maxlen 0 = read one text line */ |
4271
|
|
|
|
|
|
I32 |
4272
|
42469402
|
|
|
|
|
Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) |
4273
|
|
|
|
|
|
{ |
4274
|
|
|
|
|
|
dVAR; |
4275
|
|
|
|
|
|
filter_t funcp; |
4276
|
|
|
|
|
|
SV *datasv = NULL; |
4277
|
|
|
|
|
|
/* This API is bad. It should have been using unsigned int for maxlen. |
4278
|
|
|
|
|
|
Not sure if we want to change the API, but if not we should sanity |
4279
|
|
|
|
|
|
check the value here. */ |
4280
|
42469402
|
50
|
|
|
|
unsigned int correct_length |
4281
|
|
|
|
|
|
= maxlen < 0 ? |
4282
|
|
|
|
|
|
#ifdef PERL_MICRO |
4283
|
|
|
|
|
|
0x7FFFFFFF |
4284
|
|
|
|
|
|
#else |
4285
|
|
|
|
|
|
INT_MAX |
4286
|
|
|
|
|
|
#endif |
4287
|
|
|
|
|
|
: maxlen; |
4288
|
|
|
|
|
|
|
4289
|
|
|
|
|
|
PERL_ARGS_ASSERT_FILTER_READ; |
4290
|
|
|
|
|
|
|
4291
|
42469402
|
50
|
|
|
|
if (!PL_parser || !PL_rsfp_filters) |
|
|
50
|
|
|
|
|
4292
|
|
|
|
|
|
return -1; |
4293
|
42469402
|
100
|
|
|
|
if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */ |
4294
|
|
|
|
|
|
/* Provide a default input filter to make life easy. */ |
4295
|
|
|
|
|
|
/* Note that we append to the line. This is handy. */ |
4296
|
|
|
|
|
|
DEBUG_P(PerlIO_printf(Perl_debug_log, |
4297
|
|
|
|
|
|
"filter_read %d: from rsfp\n", idx)); |
4298
|
42420660
|
100
|
|
|
|
if (correct_length) { |
4299
|
|
|
|
|
|
/* Want a block */ |
4300
|
|
|
|
|
|
int len ; |
4301
|
20326
|
|
|
|
|
const int old_len = SvCUR(buf_sv); |
4302
|
|
|
|
|
|
|
4303
|
|
|
|
|
|
/* ensure buf_sv is large enough */ |
4304
|
20326
|
50
|
|
|
|
SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ; |
|
|
100
|
|
|
|
|
4305
|
20326
|
100
|
|
|
|
if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, |
4306
|
|
|
|
|
|
correct_length)) <= 0) { |
4307
|
7998
|
50
|
|
|
|
if (PerlIO_error(PL_rsfp)) |
4308
|
|
|
|
|
|
return -1; /* error */ |
4309
|
|
|
|
|
|
else |
4310
|
7998
|
|
|
|
|
return 0 ; /* end of file */ |
4311
|
|
|
|
|
|
} |
4312
|
12328
|
|
|
|
|
SvCUR_set(buf_sv, old_len + len) ; |
4313
|
12328
|
|
|
|
|
SvPVX(buf_sv)[old_len + len] = '\0'; |
4314
|
|
|
|
|
|
} else { |
4315
|
|
|
|
|
|
/* Want a line */ |
4316
|
42400334
|
100
|
|
|
|
if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) { |
4317
|
5706
|
50
|
|
|
|
if (PerlIO_error(PL_rsfp)) |
4318
|
|
|
|
|
|
return -1; /* error */ |
4319
|
|
|
|
|
|
else |
4320
|
5706
|
|
|
|
|
return 0 ; /* end of file */ |
4321
|
|
|
|
|
|
} |
4322
|
|
|
|
|
|
} |
4323
|
42406956
|
|
|
|
|
return SvCUR(buf_sv); |
4324
|
|
|
|
|
|
} |
4325
|
|
|
|
|
|
/* Skip this filter slot if filter has been deleted */ |
4326
|
48742
|
50
|
|
|
|
if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) { |
|
|
50
|
|
|
|
|
4327
|
|
|
|
|
|
DEBUG_P(PerlIO_printf(Perl_debug_log, |
4328
|
|
|
|
|
|
"filter_read %d: skipped (filter deleted)\n", |
4329
|
|
|
|
|
|
idx)); |
4330
|
0
|
|
|
|
|
return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */ |
4331
|
|
|
|
|
|
} |
4332
|
48742
|
100
|
|
|
|
if (SvTYPE(datasv) != SVt_PVIO) { |
4333
|
4
|
50
|
|
|
|
if (correct_length) { |
4334
|
|
|
|
|
|
/* Want a block */ |
4335
|
0
|
|
|
|
|
const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv); |
4336
|
0
|
0
|
|
|
|
if (!remainder) return 0; /* eof */ |
4337
|
0
|
0
|
|
|
|
if (correct_length > remainder) correct_length = remainder; |
4338
|
0
|
|
|
|
|
sv_catpvn(buf_sv, SvEND(datasv), correct_length); |
4339
|
0
|
|
|
|
|
SvCUR_set(datasv, SvCUR(datasv) + correct_length); |
4340
|
|
|
|
|
|
} else { |
4341
|
|
|
|
|
|
/* Want a line */ |
4342
|
4
|
|
|
|
|
const char *s = SvEND(datasv); |
4343
|
4
|
|
|
|
|
const char *send = SvPVX(datasv) + SvLEN(datasv); |
4344
|
38
|
100
|
|
|
|
while (s < send) { |
4345
|
34
|
100
|
|
|
|
if (*s == '\n') { |
4346
|
2
|
|
|
|
|
s++; |
4347
|
2
|
|
|
|
|
break; |
4348
|
|
|
|
|
|
} |
4349
|
32
|
|
|
|
|
s++; |
4350
|
|
|
|
|
|
} |
4351
|
4
|
100
|
|
|
|
if (s == send) return 0; /* eof */ |
4352
|
2
|
|
|
|
|
sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv)); |
4353
|
2
|
|
|
|
|
SvCUR_set(datasv, s-SvPVX(datasv)); |
4354
|
|
|
|
|
|
} |
4355
|
2
|
|
|
|
|
return SvCUR(buf_sv); |
4356
|
|
|
|
|
|
} |
4357
|
|
|
|
|
|
/* Get function pointer hidden within datasv */ |
4358
|
48738
|
|
|
|
|
funcp = DPTR2FPTR(filter_t, IoANY(datasv)); |
4359
|
|
|
|
|
|
DEBUG_P(PerlIO_printf(Perl_debug_log, |
4360
|
|
|
|
|
|
"filter_read %d: via function %p (%s)\n", |
4361
|
|
|
|
|
|
idx, (void*)datasv, SvPV_nolen_const(datasv))); |
4362
|
|
|
|
|
|
/* Call function. The function is expected to */ |
4363
|
|
|
|
|
|
/* call "FILTER_READ(idx+1, buf_sv)" first. */ |
4364
|
|
|
|
|
|
/* Return: <0:error, =0:eof, >0:not eof */ |
4365
|
21921650
|
|
|
|
|
return (*funcp)(aTHX_ idx, buf_sv, correct_length); |
4366
|
|
|
|
|
|
} |
4367
|
|
|
|
|
|
|
4368
|
|
|
|
|
|
STATIC char * |
4369
|
|
|
|
|
|
S_filter_gets(pTHX_ SV *sv, STRLEN append) |
4370
|
|
|
|
|
|
{ |
4371
|
|
|
|
|
|
dVAR; |
4372
|
|
|
|
|
|
|
4373
|
|
|
|
|
|
PERL_ARGS_ASSERT_FILTER_GETS; |
4374
|
|
|
|
|
|
|
4375
|
|
|
|
|
|
#ifdef PERL_CR_FILTER |
4376
|
|
|
|
|
|
if (!PL_rsfp_filters) { |
4377
|
|
|
|
|
|
filter_add(S_cr_textfilter,NULL); |
4378
|
|
|
|
|
|
} |
4379
|
|
|
|
|
|
#endif |
4380
|
215443159
|
100
|
|
|
|
if (PL_rsfp_filters) { |
4381
|
42440262
|
100
|
|
|
|
if (!append) |
4382
|
40267224
|
|
|
|
|
SvCUR_set(sv, 0); /* start with empty line */ |
4383
|
42440262
|
100
|
|
|
|
if (FILTER_READ(0, sv, 0) > 0) |
4384
|
42415054
|
|
|
|
|
return ( SvPVX(sv) ) ; |
4385
|
|
|
|
|
|
else |
4386
|
|
|
|
|
|
return NULL ; |
4387
|
|
|
|
|
|
} |
4388
|
|
|
|
|
|
else |
4389
|
173002897
|
|
|
|
|
return (sv_gets(sv, PL_rsfp, append)); |
4390
|
|
|
|
|
|
} |
4391
|
|
|
|
|
|
|
4392
|
|
|
|
|
|
STATIC HV * |
4393
|
90
|
|
|
|
|
S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len) |
4394
|
|
|
|
|
|
{ |
4395
|
|
|
|
|
|
dVAR; |
4396
|
|
|
|
|
|
GV *gv; |
4397
|
|
|
|
|
|
|
4398
|
|
|
|
|
|
PERL_ARGS_ASSERT_FIND_IN_MY_STASH; |
4399
|
|
|
|
|
|
|
4400
|
90
|
100
|
|
|
|
if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__")) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
4401
|
4
|
|
|
|
|
return PL_curstash; |
4402
|
|
|
|
|
|
|
4403
|
125
|
100
|
|
|
|
if (len > 2 && |
|
|
100
|
|
|
|
|
4404
|
55
|
50
|
|
|
|
(pkgname[len - 2] == ':' && pkgname[len - 1] == ':') && |
|
|
100
|
|
|
|
|
4405
|
8
|
50
|
|
|
|
(gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV))) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4406
|
|
|
|
|
|
{ |
4407
|
4
|
|
|
|
|
return GvHV(gv); /* Foo:: */ |
4408
|
|
|
|
|
|
} |
4409
|
|
|
|
|
|
|
4410
|
|
|
|
|
|
/* use constant CLASS => 'MyClass' */ |
4411
|
82
|
50
|
|
|
|
gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4412
|
82
|
100
|
|
|
|
if (gv && GvCV(gv)) { |
|
|
50
|
|
|
|
|
4413
|
8
|
|
|
|
|
SV * const sv = cv_const_sv(GvCV(gv)); |
4414
|
8
|
50
|
|
|
|
if (sv) |
4415
|
8
|
50
|
|
|
|
pkgname = SvPV_const(sv, len); |
4416
|
|
|
|
|
|
} |
4417
|
|
|
|
|
|
|
4418
|
86
|
50
|
|
|
|
return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4419
|
|
|
|
|
|
} |
4420
|
|
|
|
|
|
|
4421
|
|
|
|
|
|
/* |
4422
|
|
|
|
|
|
* S_readpipe_override |
4423
|
|
|
|
|
|
* Check whether readpipe() is overridden, and generates the appropriate |
4424
|
|
|
|
|
|
* optree, provided sublex_start() is called afterwards. |
4425
|
|
|
|
|
|
*/ |
4426
|
|
|
|
|
|
STATIC void |
4427
|
74864
|
|
|
|
|
S_readpipe_override(pTHX) |
4428
|
|
|
|
|
|
{ |
4429
|
|
|
|
|
|
GV **gvp; |
4430
|
74864
|
|
|
|
|
GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV); |
4431
|
74864
|
|
|
|
|
pl_yylval.ival = OP_BACKTICK; |
4432
|
74864
|
100
|
|
|
|
if ((gv_readpipe |
4433
|
4
|
50
|
|
|
|
&& GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4434
|
74860
|
100
|
|
|
|
|| |
4435
|
74860
|
|
|
|
|
((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE)) |
4436
|
6
|
50
|
|
|
|
&& (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
4437
|
4
|
50
|
|
|
|
&& GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4438
|
|
|
|
|
|
{ |
4439
|
8
|
50
|
|
|
|
COPLINE_SET_FROM_MULTI_END; |
4440
|
8
|
|
|
|
|
PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, |
4441
|
|
|
|
|
|
op_append_elem(OP_LIST, |
4442
|
|
|
|
|
|
newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */ |
4443
|
|
|
|
|
|
newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe)))); |
4444
|
|
|
|
|
|
} |
4445
|
74864
|
|
|
|
|
} |
4446
|
|
|
|
|
|
|
4447
|
|
|
|
|
|
#ifdef PERL_MAD |
4448
|
|
|
|
|
|
/* |
4449
|
|
|
|
|
|
* Perl_madlex |
4450
|
|
|
|
|
|
* The intent of this yylex wrapper is to minimize the changes to the |
4451
|
|
|
|
|
|
* tokener when we aren't interested in collecting madprops. It remains |
4452
|
|
|
|
|
|
* to be seen how successful this strategy will be... |
4453
|
|
|
|
|
|
*/ |
4454
|
|
|
|
|
|
|
4455
|
|
|
|
|
|
int |
4456
|
|
|
|
|
|
Perl_madlex(pTHX) |
4457
|
|
|
|
|
|
{ |
4458
|
|
|
|
|
|
int optype; |
4459
|
|
|
|
|
|
char *s = PL_bufptr; |
4460
|
|
|
|
|
|
|
4461
|
|
|
|
|
|
/* make sure PL_thiswhite is initialized */ |
4462
|
|
|
|
|
|
PL_thiswhite = 0; |
4463
|
|
|
|
|
|
PL_thismad = 0; |
4464
|
|
|
|
|
|
|
4465
|
|
|
|
|
|
/* previous token ate up our whitespace? */ |
4466
|
|
|
|
|
|
if (!PL_lasttoke && PL_nextwhite) { |
4467
|
|
|
|
|
|
PL_thiswhite = PL_nextwhite; |
4468
|
|
|
|
|
|
PL_nextwhite = 0; |
4469
|
|
|
|
|
|
} |
4470
|
|
|
|
|
|
|
4471
|
|
|
|
|
|
/* isolate the token, and figure out where it is without whitespace */ |
4472
|
|
|
|
|
|
PL_realtokenstart = -1; |
4473
|
|
|
|
|
|
PL_thistoken = 0; |
4474
|
|
|
|
|
|
optype = yylex(); |
4475
|
|
|
|
|
|
s = PL_bufptr; |
4476
|
|
|
|
|
|
assert(PL_curforce < 0); |
4477
|
|
|
|
|
|
|
4478
|
|
|
|
|
|
if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */ |
4479
|
|
|
|
|
|
if (!PL_thistoken) { |
4480
|
|
|
|
|
|
if (PL_realtokenstart < 0 || !CopLINE(PL_curcop)) |
4481
|
|
|
|
|
|
PL_thistoken = newSVpvs(""); |
4482
|
|
|
|
|
|
else { |
4483
|
|
|
|
|
|
char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart; |
4484
|
|
|
|
|
|
PL_thistoken = newSVpvn(tstart, s - tstart); |
4485
|
|
|
|
|
|
} |
4486
|
|
|
|
|
|
} |
4487
|
|
|
|
|
|
if (PL_thismad) /* install head */ |
4488
|
|
|
|
|
|
CURMAD('X', PL_thistoken); |
4489
|
|
|
|
|
|
} |
4490
|
|
|
|
|
|
|
4491
|
|
|
|
|
|
/* last whitespace of a sublex? */ |
4492
|
|
|
|
|
|
if (optype == ')' && PL_endwhite) { |
4493
|
|
|
|
|
|
CURMAD('X', PL_endwhite); |
4494
|
|
|
|
|
|
} |
4495
|
|
|
|
|
|
|
4496
|
|
|
|
|
|
if (!PL_thismad) { |
4497
|
|
|
|
|
|
|
4498
|
|
|
|
|
|
/* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */ |
4499
|
|
|
|
|
|
if (!PL_thiswhite && !PL_endwhite && !optype) { |
4500
|
|
|
|
|
|
sv_free(PL_thistoken); |
4501
|
|
|
|
|
|
PL_thistoken = 0; |
4502
|
|
|
|
|
|
return 0; |
4503
|
|
|
|
|
|
} |
4504
|
|
|
|
|
|
|
4505
|
|
|
|
|
|
/* put off final whitespace till peg */ |
4506
|
|
|
|
|
|
if (optype == ';' && !PL_rsfp && !PL_parser->filtered) { |
4507
|
|
|
|
|
|
PL_nextwhite = PL_thiswhite; |
4508
|
|
|
|
|
|
PL_thiswhite = 0; |
4509
|
|
|
|
|
|
} |
4510
|
|
|
|
|
|
else if (PL_thisopen) { |
4511
|
|
|
|
|
|
CURMAD('q', PL_thisopen); |
4512
|
|
|
|
|
|
if (PL_thistoken) |
4513
|
|
|
|
|
|
sv_free(PL_thistoken); |
4514
|
|
|
|
|
|
PL_thistoken = 0; |
4515
|
|
|
|
|
|
} |
4516
|
|
|
|
|
|
else { |
4517
|
|
|
|
|
|
/* Store actual token text as madprop X */ |
4518
|
|
|
|
|
|
CURMAD('X', PL_thistoken); |
4519
|
|
|
|
|
|
} |
4520
|
|
|
|
|
|
|
4521
|
|
|
|
|
|
if (PL_thiswhite) { |
4522
|
|
|
|
|
|
/* add preceding whitespace as madprop _ */ |
4523
|
|
|
|
|
|
CURMAD('_', PL_thiswhite); |
4524
|
|
|
|
|
|
} |
4525
|
|
|
|
|
|
|
4526
|
|
|
|
|
|
if (PL_thisstuff) { |
4527
|
|
|
|
|
|
/* add quoted material as madprop = */ |
4528
|
|
|
|
|
|
CURMAD('=', PL_thisstuff); |
4529
|
|
|
|
|
|
} |
4530
|
|
|
|
|
|
|
4531
|
|
|
|
|
|
if (PL_thisclose) { |
4532
|
|
|
|
|
|
/* add terminating quote as madprop Q */ |
4533
|
|
|
|
|
|
CURMAD('Q', PL_thisclose); |
4534
|
|
|
|
|
|
} |
4535
|
|
|
|
|
|
} |
4536
|
|
|
|
|
|
|
4537
|
|
|
|
|
|
/* special processing based on optype */ |
4538
|
|
|
|
|
|
|
4539
|
|
|
|
|
|
switch (optype) { |
4540
|
|
|
|
|
|
|
4541
|
|
|
|
|
|
/* opval doesn't need a TOKEN since it can already store mp */ |
4542
|
|
|
|
|
|
case WORD: |
4543
|
|
|
|
|
|
case METHOD: |
4544
|
|
|
|
|
|
case FUNCMETH: |
4545
|
|
|
|
|
|
case THING: |
4546
|
|
|
|
|
|
case PMFUNC: |
4547
|
|
|
|
|
|
case PRIVATEREF: |
4548
|
|
|
|
|
|
case FUNC0SUB: |
4549
|
|
|
|
|
|
case UNIOPSUB: |
4550
|
|
|
|
|
|
case LSTOPSUB: |
4551
|
|
|
|
|
|
if (pl_yylval.opval) |
4552
|
|
|
|
|
|
append_madprops(PL_thismad, pl_yylval.opval, 0); |
4553
|
|
|
|
|
|
PL_thismad = 0; |
4554
|
|
|
|
|
|
return optype; |
4555
|
|
|
|
|
|
|
4556
|
|
|
|
|
|
/* fake EOF */ |
4557
|
|
|
|
|
|
case 0: |
4558
|
|
|
|
|
|
optype = PEG; |
4559
|
|
|
|
|
|
if (PL_endwhite) { |
4560
|
|
|
|
|
|
addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0); |
4561
|
|
|
|
|
|
PL_endwhite = 0; |
4562
|
|
|
|
|
|
} |
4563
|
|
|
|
|
|
break; |
4564
|
|
|
|
|
|
|
4565
|
|
|
|
|
|
/* pval */ |
4566
|
|
|
|
|
|
case LABEL: |
4567
|
|
|
|
|
|
break; |
4568
|
|
|
|
|
|
|
4569
|
|
|
|
|
|
case ']': |
4570
|
|
|
|
|
|
case '}': |
4571
|
|
|
|
|
|
if (PL_faketokens) |
4572
|
|
|
|
|
|
break; |
4573
|
|
|
|
|
|
/* remember any fake bracket that lexer is about to discard */ |
4574
|
|
|
|
|
|
if (PL_lex_brackets == 1 && |
4575
|
|
|
|
|
|
((expectation)PL_lex_brackstack[0] & XFAKEBRACK)) |
4576
|
|
|
|
|
|
{ |
4577
|
|
|
|
|
|
s = PL_bufptr; |
4578
|
|
|
|
|
|
while (s < PL_bufend && (*s == ' ' || *s == '\t')) |
4579
|
|
|
|
|
|
s++; |
4580
|
|
|
|
|
|
if (*s == '}') { |
4581
|
|
|
|
|
|
PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr); |
4582
|
|
|
|
|
|
addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0); |
4583
|
|
|
|
|
|
PL_thiswhite = 0; |
4584
|
|
|
|
|
|
PL_bufptr = s - 1; |
4585
|
|
|
|
|
|
break; /* don't bother looking for trailing comment */ |
4586
|
|
|
|
|
|
} |
4587
|
|
|
|
|
|
else |
4588
|
|
|
|
|
|
s = PL_bufptr; |
4589
|
|
|
|
|
|
} |
4590
|
|
|
|
|
|
if (optype == ']') |
4591
|
|
|
|
|
|
break; |
4592
|
|
|
|
|
|
/* FALLTHROUGH */ |
4593
|
|
|
|
|
|
|
4594
|
|
|
|
|
|
/* attach a trailing comment to its statement instead of next token */ |
4595
|
|
|
|
|
|
case ';': |
4596
|
|
|
|
|
|
if (PL_faketokens) |
4597
|
|
|
|
|
|
break; |
4598
|
|
|
|
|
|
if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) { |
4599
|
|
|
|
|
|
s = PL_bufptr; |
4600
|
|
|
|
|
|
while (s < PL_bufend && (*s == ' ' || *s == '\t')) |
4601
|
|
|
|
|
|
s++; |
4602
|
|
|
|
|
|
if (*s == '\n' || *s == '#') { |
4603
|
|
|
|
|
|
while (s < PL_bufend && *s != '\n') |
4604
|
|
|
|
|
|
s++; |
4605
|
|
|
|
|
|
if (s < PL_bufend) |
4606
|
|
|
|
|
|
s++; |
4607
|
|
|
|
|
|
PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr); |
4608
|
|
|
|
|
|
addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0); |
4609
|
|
|
|
|
|
PL_thiswhite = 0; |
4610
|
|
|
|
|
|
PL_bufptr = s; |
4611
|
|
|
|
|
|
} |
4612
|
|
|
|
|
|
} |
4613
|
|
|
|
|
|
break; |
4614
|
|
|
|
|
|
|
4615
|
|
|
|
|
|
/* ival */ |
4616
|
|
|
|
|
|
default: |
4617
|
|
|
|
|
|
break; |
4618
|
|
|
|
|
|
|
4619
|
|
|
|
|
|
} |
4620
|
|
|
|
|
|
|
4621
|
|
|
|
|
|
/* Create new token struct. Note: opvals return early above. */ |
4622
|
|
|
|
|
|
pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad); |
4623
|
|
|
|
|
|
PL_thismad = 0; |
4624
|
|
|
|
|
|
return optype; |
4625
|
|
|
|
|
|
} |
4626
|
|
|
|
|
|
#endif |
4627
|
|
|
|
|
|
|
4628
|
|
|
|
|
|
STATIC char * |
4629
|
4646544
|
|
|
|
|
S_tokenize_use(pTHX_ int is_use, char *s) { |
4630
|
|
|
|
|
|
dVAR; |
4631
|
|
|
|
|
|
|
4632
|
|
|
|
|
|
PERL_ARGS_ASSERT_TOKENIZE_USE; |
4633
|
|
|
|
|
|
|
4634
|
4646544
|
50
|
|
|
|
if (PL_expect != XSTATE) |
4635
|
0
|
0
|
|
|
|
yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression", |
4636
|
|
|
|
|
|
is_use ? "use" : "no")); |
4637
|
4646544
|
|
|
|
|
PL_expect = XTERM; |
4638
|
4646544
|
|
|
|
|
s = SKIPSPACE1(s); |
4639
|
4646544
|
100
|
|
|
|
if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4640
|
108030
|
|
|
|
|
s = force_version(s, TRUE); |
4641
|
108030
|
100
|
|
|
|
if (*s == ';' || *s == '}' |
4642
|
70
|
50
|
|
|
|
|| (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) { |
4643
|
|
|
|
|
|
start_force(PL_curforce); |
4644
|
108030
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval = NULL; |
4645
|
108030
|
|
|
|
|
force_next(WORD); |
4646
|
|
|
|
|
|
} |
4647
|
0
|
0
|
|
|
|
else if (*s == 'v') { |
4648
|
0
|
|
|
|
|
s = force_word(s,WORD,FALSE,TRUE); |
4649
|
0
|
|
|
|
|
s = force_version(s, FALSE); |
4650
|
|
|
|
|
|
} |
4651
|
|
|
|
|
|
} |
4652
|
|
|
|
|
|
else { |
4653
|
4538514
|
|
|
|
|
s = force_word(s,WORD,FALSE,TRUE); |
4654
|
4538514
|
|
|
|
|
s = force_version(s, FALSE); |
4655
|
|
|
|
|
|
} |
4656
|
4646544
|
|
|
|
|
pl_yylval.ival = is_use; |
4657
|
4646544
|
|
|
|
|
return s; |
4658
|
|
|
|
|
|
} |
4659
|
|
|
|
|
|
#ifdef DEBUGGING |
4660
|
|
|
|
|
|
static const char* const exp_name[] = |
4661
|
|
|
|
|
|
{ "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK", |
4662
|
|
|
|
|
|
"ATTRTERM", "TERMBLOCK", "TERMORDORDOR" |
4663
|
|
|
|
|
|
}; |
4664
|
|
|
|
|
|
#endif |
4665
|
|
|
|
|
|
|
4666
|
|
|
|
|
|
#define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l) |
4667
|
|
|
|
|
|
STATIC bool |
4668
|
125145386
|
|
|
|
|
S_word_takes_any_delimeter(char *p, STRLEN len) |
4669
|
|
|
|
|
|
{ |
4670
|
248620785
|
100
|
|
|
|
return (len == 1 && strchr("msyq", p[0])) || |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4671
|
39684773
|
100
|
|
|
|
(len == 2 && ( |
4672
|
58898642
|
100
|
|
|
|
(p[0] == 't' && p[1] == 'r') || |
|
|
100
|
|
|
|
|
4673
|
83125873
|
100
|
|
|
|
(p[0] == 'q' && strchr("qwxr", p[1])))); |
4674
|
|
|
|
|
|
} |
4675
|
|
|
|
|
|
|
4676
|
|
|
|
|
|
/* |
4677
|
|
|
|
|
|
yylex |
4678
|
|
|
|
|
|
|
4679
|
|
|
|
|
|
Works out what to call the token just pulled out of the input |
4680
|
|
|
|
|
|
stream. The yacc parser takes care of taking the ops we return and |
4681
|
|
|
|
|
|
stitching them into a tree. |
4682
|
|
|
|
|
|
|
4683
|
|
|
|
|
|
Returns: |
4684
|
|
|
|
|
|
The type of the next token |
4685
|
|
|
|
|
|
|
4686
|
|
|
|
|
|
Structure: |
4687
|
|
|
|
|
|
Switch based on the current state: |
4688
|
|
|
|
|
|
- if we already built the token before, use it |
4689
|
|
|
|
|
|
- if we have a case modifier in a string, deal with that |
4690
|
|
|
|
|
|
- handle other cases of interpolation inside a string |
4691
|
|
|
|
|
|
- scan the next line if we are inside a format |
4692
|
|
|
|
|
|
In the normal state switch on the next character: |
4693
|
|
|
|
|
|
- default: |
4694
|
|
|
|
|
|
if alphabetic, go to key lookup |
4695
|
|
|
|
|
|
unrecoginized character - croak |
4696
|
|
|
|
|
|
- 0/4/26: handle end-of-line or EOF |
4697
|
|
|
|
|
|
- cases for whitespace |
4698
|
|
|
|
|
|
- \n and #: handle comments and line numbers |
4699
|
|
|
|
|
|
- various operators, brackets and sigils |
4700
|
|
|
|
|
|
- numbers |
4701
|
|
|
|
|
|
- quotes |
4702
|
|
|
|
|
|
- 'v': vstrings (or go to key lookup) |
4703
|
|
|
|
|
|
- 'x' repetition operator (or go to key lookup) |
4704
|
|
|
|
|
|
- other ASCII alphanumerics (key lookup begins here): |
4705
|
|
|
|
|
|
word before => ? |
4706
|
|
|
|
|
|
keyword plugin |
4707
|
|
|
|
|
|
scan built-in keyword (but do nothing with it yet) |
4708
|
|
|
|
|
|
check for statement label |
4709
|
|
|
|
|
|
check for lexical subs |
4710
|
|
|
|
|
|
goto just_a_word if there is one |
4711
|
|
|
|
|
|
see whether built-in keyword is overridden |
4712
|
|
|
|
|
|
switch on keyword number: |
4713
|
|
|
|
|
|
- default: just_a_word: |
4714
|
|
|
|
|
|
not a built-in keyword; handle bareword lookup |
4715
|
|
|
|
|
|
disambiguate between method and sub call |
4716
|
|
|
|
|
|
fall back to bareword |
4717
|
|
|
|
|
|
- cases for built-in keywords |
4718
|
|
|
|
|
|
*/ |
4719
|
|
|
|
|
|
|
4720
|
|
|
|
|
|
|
4721
|
|
|
|
|
|
#ifdef __SC__ |
4722
|
|
|
|
|
|
#pragma segment Perl_yylex |
4723
|
|
|
|
|
|
#endif |
4724
|
|
|
|
|
|
int |
4725
|
1060137204
|
|
|
|
|
Perl_yylex(pTHX) |
4726
|
|
|
|
|
|
{ |
4727
|
|
|
|
|
|
dVAR; |
4728
|
|
|
|
|
|
char *s = PL_bufptr; |
4729
|
|
|
|
|
|
char *d; |
4730
|
|
|
|
|
|
STRLEN len; |
4731
|
|
|
|
|
|
bool bof = FALSE; |
4732
|
1060137204
|
|
|
|
|
const bool saw_infix_sigil = PL_parser->saw_infix_sigil; |
4733
|
|
|
|
|
|
U8 formbrack = 0; |
4734
|
|
|
|
|
|
U32 fake_eof = 0; |
4735
|
|
|
|
|
|
|
4736
|
|
|
|
|
|
/* orig_keyword, gvp, and gv are initialized here because |
4737
|
|
|
|
|
|
* jump to the label just_a_word_zero can bypass their |
4738
|
|
|
|
|
|
* initialization later. */ |
4739
|
|
|
|
|
|
I32 orig_keyword = 0; |
4740
|
|
|
|
|
|
GV *gv = NULL; |
4741
|
|
|
|
|
|
GV **gvp = NULL; |
4742
|
|
|
|
|
|
|
4743
|
|
|
|
|
|
DEBUG_T( { |
4744
|
|
|
|
|
|
SV* tmp = newSVpvs(""); |
4745
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n", |
4746
|
|
|
|
|
|
(IV)CopLINE(PL_curcop), |
4747
|
|
|
|
|
|
lex_state_names[PL_lex_state], |
4748
|
|
|
|
|
|
exp_name[PL_expect], |
4749
|
|
|
|
|
|
pv_display(tmp, s, strlen(s), 0, 60)); |
4750
|
|
|
|
|
|
SvREFCNT_dec(tmp); |
4751
|
|
|
|
|
|
} ); |
4752
|
|
|
|
|
|
|
4753
|
1060137204
|
|
|
|
|
switch (PL_lex_state) { |
4754
|
|
|
|
|
|
#ifdef COMMENTARY |
4755
|
|
|
|
|
|
case LEX_NORMAL: /* Some compilers will produce faster */ |
4756
|
|
|
|
|
|
case LEX_INTERPNORMAL: /* code if we comment these out. */ |
4757
|
|
|
|
|
|
break; |
4758
|
|
|
|
|
|
#endif |
4759
|
|
|
|
|
|
|
4760
|
|
|
|
|
|
/* when we've already built the next token, just pull it out of the queue */ |
4761
|
|
|
|
|
|
case LEX_KNOWNEXT: |
4762
|
|
|
|
|
|
#ifdef PERL_MAD |
4763
|
|
|
|
|
|
PL_lasttoke--; |
4764
|
|
|
|
|
|
pl_yylval = PL_nexttoke[PL_lasttoke].next_val; |
4765
|
|
|
|
|
|
if (PL_madskills) { |
4766
|
|
|
|
|
|
PL_thismad = PL_nexttoke[PL_lasttoke].next_mad; |
4767
|
|
|
|
|
|
PL_nexttoke[PL_lasttoke].next_mad = 0; |
4768
|
|
|
|
|
|
if (PL_thismad && PL_thismad->mad_key == '_') { |
4769
|
|
|
|
|
|
PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val); |
4770
|
|
|
|
|
|
PL_thismad->mad_val = 0; |
4771
|
|
|
|
|
|
mad_free(PL_thismad); |
4772
|
|
|
|
|
|
PL_thismad = 0; |
4773
|
|
|
|
|
|
} |
4774
|
|
|
|
|
|
} |
4775
|
|
|
|
|
|
if (!PL_lasttoke) { |
4776
|
|
|
|
|
|
PL_lex_state = PL_lex_defer; |
4777
|
|
|
|
|
|
PL_expect = PL_lex_expect; |
4778
|
|
|
|
|
|
PL_lex_defer = LEX_NORMAL; |
4779
|
|
|
|
|
|
if (!PL_nexttoke[PL_lasttoke].next_type) |
4780
|
|
|
|
|
|
return yylex(); |
4781
|
|
|
|
|
|
} |
4782
|
|
|
|
|
|
#else |
4783
|
253471868
|
|
|
|
|
PL_nexttoke--; |
4784
|
253471868
|
|
|
|
|
pl_yylval = PL_nextval[PL_nexttoke]; |
4785
|
253471868
|
100
|
|
|
|
if (!PL_nexttoke) { |
4786
|
246791236
|
|
|
|
|
PL_lex_state = PL_lex_defer; |
4787
|
246791236
|
|
|
|
|
PL_expect = PL_lex_expect; |
4788
|
246791236
|
|
|
|
|
PL_lex_defer = LEX_NORMAL; |
4789
|
|
|
|
|
|
} |
4790
|
|
|
|
|
|
#endif |
4791
|
|
|
|
|
|
{ |
4792
|
|
|
|
|
|
I32 next_type; |
4793
|
|
|
|
|
|
#ifdef PERL_MAD |
4794
|
|
|
|
|
|
next_type = PL_nexttoke[PL_lasttoke].next_type; |
4795
|
|
|
|
|
|
#else |
4796
|
253471868
|
|
|
|
|
next_type = PL_nexttype[PL_nexttoke]; |
4797
|
|
|
|
|
|
#endif |
4798
|
253471868
|
100
|
|
|
|
if (next_type & (7<<24)) { |
4799
|
327386
|
100
|
|
|
|
if (next_type & (1<<24)) { |
4800
|
8
|
50
|
|
|
|
if (PL_lex_brackets > 100) |
4801
|
0
|
|
|
|
|
Renew(PL_lex_brackstack, PL_lex_brackets + 10, char); |
4802
|
12
|
|
|
|
|
PL_lex_brackstack[PL_lex_brackets++] = |
4803
|
8
|
|
|
|
|
(char) ((next_type >> 16) & 0xff); |
4804
|
|
|
|
|
|
} |
4805
|
327386
|
50
|
|
|
|
if (next_type & (2<<24)) |
4806
|
327386
|
|
|
|
|
PL_lex_allbrackets++; |
4807
|
327386
|
50
|
|
|
|
if (next_type & (4<<24)) |
4808
|
0
|
|
|
|
|
PL_lex_allbrackets--; |
4809
|
327386
|
|
|
|
|
next_type &= 0xffff; |
4810
|
|
|
|
|
|
} |
4811
|
253471868
|
100
|
|
|
|
return REPORT(next_type == 'p' ? pending_ident() : next_type); |
4812
|
|
|
|
|
|
} |
4813
|
|
|
|
|
|
|
4814
|
|
|
|
|
|
/* interpolated case modifiers like \L \U, including \Q and \E. |
4815
|
|
|
|
|
|
when we get here, PL_bufptr is at the \ |
4816
|
|
|
|
|
|
*/ |
4817
|
|
|
|
|
|
case LEX_INTERPCASEMOD: |
4818
|
|
|
|
|
|
#ifdef DEBUGGING |
4819
|
|
|
|
|
|
if (PL_bufptr != PL_bufend && *PL_bufptr != '\\') |
4820
|
|
|
|
|
|
Perl_croak(aTHX_ |
4821
|
|
|
|
|
|
"panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u", |
4822
|
|
|
|
|
|
PL_bufptr, PL_bufend, *PL_bufptr); |
4823
|
|
|
|
|
|
#endif |
4824
|
|
|
|
|
|
/* handle \E or end of string */ |
4825
|
263572
|
100
|
|
|
|
if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') { |
|
|
100
|
|
|
|
|
4826
|
|
|
|
|
|
/* if at a \E */ |
4827
|
147474
|
100
|
|
|
|
if (PL_lex_casemods) { |
4828
|
116076
|
|
|
|
|
const char oldmod = PL_lex_casestack[--PL_lex_casemods]; |
4829
|
116076
|
|
|
|
|
PL_lex_casestack[PL_lex_casemods] = '\0'; |
4830
|
|
|
|
|
|
|
4831
|
116076
|
100
|
|
|
|
if (PL_bufptr != PL_bufend |
4832
|
84526
|
100
|
|
|
|
&& (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q' |
4833
|
80692
|
100
|
|
|
|
|| oldmod == 'F')) { |
4834
|
84518
|
|
|
|
|
PL_bufptr += 2; |
4835
|
84518
|
|
|
|
|
PL_lex_state = LEX_INTERPCONCAT; |
4836
|
|
|
|
|
|
#ifdef PERL_MAD |
4837
|
|
|
|
|
|
if (PL_madskills) |
4838
|
|
|
|
|
|
PL_thistoken = newSVpvs("\\E"); |
4839
|
|
|
|
|
|
#endif |
4840
|
|
|
|
|
|
} |
4841
|
116076
|
|
|
|
|
PL_lex_allbrackets--; |
4842
|
116076
|
|
|
|
|
return REPORT(')'); |
4843
|
|
|
|
|
|
} |
4844
|
31398
|
100
|
|
|
|
else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) { |
|
|
50
|
|
|
|
|
4845
|
|
|
|
|
|
/* Got an unpaired \E */ |
4846
|
16
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), |
4847
|
|
|
|
|
|
"Useless use of \\E"); |
4848
|
|
|
|
|
|
} |
4849
|
|
|
|
|
|
#ifdef PERL_MAD |
4850
|
|
|
|
|
|
while (PL_bufptr != PL_bufend && |
4851
|
|
|
|
|
|
PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') { |
4852
|
|
|
|
|
|
if (PL_madskills) { |
4853
|
|
|
|
|
|
if (!PL_thiswhite) |
4854
|
|
|
|
|
|
PL_thiswhite = newSVpvs(""); |
4855
|
|
|
|
|
|
sv_catpvn(PL_thiswhite, PL_bufptr, 2); |
4856
|
|
|
|
|
|
} |
4857
|
|
|
|
|
|
PL_bufptr += 2; |
4858
|
|
|
|
|
|
} |
4859
|
|
|
|
|
|
#else |
4860
|
31398
|
100
|
|
|
|
if (PL_bufptr != PL_bufend) |
4861
|
16
|
|
|
|
|
PL_bufptr += 2; |
4862
|
|
|
|
|
|
#endif |
4863
|
31398
|
|
|
|
|
PL_lex_state = LEX_INTERPCONCAT; |
4864
|
31398
|
|
|
|
|
return yylex(); |
4865
|
|
|
|
|
|
} |
4866
|
|
|
|
|
|
else { |
4867
|
|
|
|
|
|
DEBUG_T({ PerlIO_printf(Perl_debug_log, |
4868
|
|
|
|
|
|
"### Saw case modifier\n"); }); |
4869
|
116098
|
|
|
|
|
s = PL_bufptr + 1; |
4870
|
116098
|
100
|
|
|
|
if (s[1] == '\\' && s[2] == 'E') { |
|
|
100
|
|
|
|
|
4871
|
|
|
|
|
|
#ifdef PERL_MAD |
4872
|
|
|
|
|
|
if (PL_madskills) { |
4873
|
|
|
|
|
|
if (!PL_thiswhite) |
4874
|
|
|
|
|
|
PL_thiswhite = newSVpvs(""); |
4875
|
|
|
|
|
|
sv_catpvn(PL_thiswhite, PL_bufptr, 4); |
4876
|
|
|
|
|
|
} |
4877
|
|
|
|
|
|
#endif |
4878
|
10
|
|
|
|
|
PL_bufptr = s + 3; |
4879
|
10
|
|
|
|
|
PL_lex_state = LEX_INTERPCONCAT; |
4880
|
10
|
|
|
|
|
return yylex(); |
4881
|
|
|
|
|
|
} |
4882
|
|
|
|
|
|
else { |
4883
|
|
|
|
|
|
I32 tmp; |
4884
|
|
|
|
|
|
if (!PL_madskills) /* when just compiling don't need correct */ |
4885
|
116088
|
100
|
|
|
|
if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) |
|
|
100
|
|
|
|
|
4886
|
8
|
|
|
|
|
tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */ |
4887
|
120836
|
100
|
|
|
|
if ((*s == 'L' || *s == 'U' || *s == 'F') && |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4888
|
9496
|
|
|
|
|
(strchr(PL_lex_casestack, 'L') |
4889
|
9492
|
100
|
|
|
|
|| strchr(PL_lex_casestack, 'U') |
4890
|
9490
|
50
|
|
|
|
|| strchr(PL_lex_casestack, 'F'))) { |
4891
|
6
|
|
|
|
|
PL_lex_casestack[--PL_lex_casemods] = '\0'; |
4892
|
6
|
|
|
|
|
PL_lex_allbrackets--; |
4893
|
6
|
|
|
|
|
return REPORT(')'); |
4894
|
|
|
|
|
|
} |
4895
|
116082
|
100
|
|
|
|
if (PL_lex_casemods > 10) |
4896
|
4
|
|
|
|
|
Renew(PL_lex_casestack, PL_lex_casemods + 2, char); |
4897
|
116082
|
|
|
|
|
PL_lex_casestack[PL_lex_casemods++] = *s; |
4898
|
116082
|
|
|
|
|
PL_lex_casestack[PL_lex_casemods] = '\0'; |
4899
|
116082
|
|
|
|
|
PL_lex_state = LEX_INTERPCONCAT; |
4900
|
|
|
|
|
|
start_force(PL_curforce); |
4901
|
116082
|
|
|
|
|
NEXTVAL_NEXTTOKE.ival = 0; |
4902
|
116082
|
|
|
|
|
force_next((2<<24)|'('); |
4903
|
|
|
|
|
|
start_force(PL_curforce); |
4904
|
116082
|
100
|
|
|
|
if (*s == 'l') |
4905
|
26
|
|
|
|
|
NEXTVAL_NEXTTOKE.ival = OP_LCFIRST; |
4906
|
116056
|
100
|
|
|
|
else if (*s == 'u') |
4907
|
10288
|
|
|
|
|
NEXTVAL_NEXTTOKE.ival = OP_UCFIRST; |
4908
|
105768
|
100
|
|
|
|
else if (*s == 'L') |
4909
|
1048
|
|
|
|
|
NEXTVAL_NEXTTOKE.ival = OP_LC; |
4910
|
104720
|
100
|
|
|
|
else if (*s == 'U') |
4911
|
8416
|
|
|
|
|
NEXTVAL_NEXTTOKE.ival = OP_UC; |
4912
|
96304
|
100
|
|
|
|
else if (*s == 'Q') |
4913
|
96278
|
|
|
|
|
NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA; |
4914
|
26
|
50
|
|
|
|
else if (*s == 'F') |
4915
|
26
|
|
|
|
|
NEXTVAL_NEXTTOKE.ival = OP_FC; |
4916
|
|
|
|
|
|
else |
4917
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: yylex, *s=%u", *s); |
4918
|
|
|
|
|
|
if (PL_madskills) { |
4919
|
|
|
|
|
|
SV* const tmpsv = newSVpvs("\\ "); |
4920
|
|
|
|
|
|
/* replace the space with the character we want to escape |
4921
|
|
|
|
|
|
*/ |
4922
|
|
|
|
|
|
SvPVX(tmpsv)[1] = *s; |
4923
|
|
|
|
|
|
curmad('_', tmpsv); |
4924
|
|
|
|
|
|
} |
4925
|
116082
|
|
|
|
|
PL_bufptr = s + 1; |
4926
|
|
|
|
|
|
} |
4927
|
116082
|
|
|
|
|
force_next(FUNC); |
4928
|
116082
|
100
|
|
|
|
if (PL_lex_starts) { |
4929
|
95594
|
|
|
|
|
s = PL_bufptr; |
4930
|
95594
|
|
|
|
|
PL_lex_starts = 0; |
4931
|
|
|
|
|
|
#ifdef PERL_MAD |
4932
|
|
|
|
|
|
if (PL_madskills) { |
4933
|
|
|
|
|
|
if (PL_thistoken) |
4934
|
|
|
|
|
|
sv_free(PL_thistoken); |
4935
|
|
|
|
|
|
PL_thistoken = newSVpvs(""); |
4936
|
|
|
|
|
|
} |
4937
|
|
|
|
|
|
#endif |
4938
|
|
|
|
|
|
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ |
4939
|
95594
|
100
|
|
|
|
if (PL_lex_casemods == 1 && PL_lex_inpat) |
|
|
100
|
|
|
|
|
4940
|
76092
|
|
|
|
|
OPERATOR(','); |
4941
|
|
|
|
|
|
else |
4942
|
19502
|
|
|
|
|
Aop(OP_CONCAT); |
4943
|
|
|
|
|
|
} |
4944
|
|
|
|
|
|
else |
4945
|
20488
|
|
|
|
|
return yylex(); |
4946
|
|
|
|
|
|
} |
4947
|
|
|
|
|
|
|
4948
|
|
|
|
|
|
case LEX_INTERPPUSH: |
4949
|
15196785
|
|
|
|
|
return REPORT(sublex_push()); |
4950
|
|
|
|
|
|
|
4951
|
|
|
|
|
|
case LEX_INTERPSTART: |
4952
|
22509507
|
100
|
|
|
|
if (PL_bufptr == PL_bufend) |
4953
|
13254469
|
|
|
|
|
return REPORT(sublex_done()); |
4954
|
|
|
|
|
|
DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log, |
4955
|
|
|
|
|
|
"### Interpolated variable\n"); }); |
4956
|
9255038
|
|
|
|
|
PL_expect = XTERM; |
4957
|
|
|
|
|
|
/* for /@a/, we leave the joining for the regex engine to do |
4958
|
|
|
|
|
|
* (unless we're within \Q etc) */ |
4959
|
18510076
|
|
|
|
|
PL_lex_dojoin = (*PL_bufptr == '@' |
4960
|
9255038
|
100
|
|
|
|
&& (!PL_lex_inpat || PL_lex_casemods)); |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4961
|
9255038
|
|
|
|
|
PL_lex_state = LEX_INTERPNORMAL; |
4962
|
9255038
|
100
|
|
|
|
if (PL_lex_dojoin) { |
4963
|
|
|
|
|
|
start_force(PL_curforce); |
4964
|
211296
|
|
|
|
|
NEXTVAL_NEXTTOKE.ival = 0; |
4965
|
211296
|
|
|
|
|
force_next(','); |
4966
|
|
|
|
|
|
start_force(PL_curforce); |
4967
|
211296
|
|
|
|
|
force_ident("\"", '$'); |
4968
|
|
|
|
|
|
start_force(PL_curforce); |
4969
|
211296
|
|
|
|
|
NEXTVAL_NEXTTOKE.ival = 0; |
4970
|
211296
|
|
|
|
|
force_next('$'); |
4971
|
|
|
|
|
|
start_force(PL_curforce); |
4972
|
211296
|
|
|
|
|
NEXTVAL_NEXTTOKE.ival = 0; |
4973
|
211296
|
|
|
|
|
force_next((2<<24)|'('); |
4974
|
|
|
|
|
|
start_force(PL_curforce); |
4975
|
211296
|
|
|
|
|
NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */ |
4976
|
211296
|
|
|
|
|
force_next(FUNC); |
4977
|
|
|
|
|
|
} |
4978
|
|
|
|
|
|
/* Convert (?{...}) and friends to 'do {...}' */ |
4979
|
9255038
|
100
|
|
|
|
if (PL_lex_inpat && *PL_bufptr == '(') { |
|
|
100
|
|
|
|
|
4980
|
11150
|
|
|
|
|
PL_parser->lex_shared->re_eval_start = PL_bufptr; |
4981
|
11150
|
|
|
|
|
PL_bufptr += 2; |
4982
|
11150
|
100
|
|
|
|
if (*PL_bufptr != '{') |
4983
|
8734
|
|
|
|
|
PL_bufptr++; |
4984
|
|
|
|
|
|
start_force(PL_curforce); |
4985
|
|
|
|
|
|
/* XXX probably need a CURMAD(something) here */ |
4986
|
11150
|
|
|
|
|
PL_expect = XTERMBLOCK; |
4987
|
11150
|
|
|
|
|
force_next(DO); |
4988
|
|
|
|
|
|
} |
4989
|
|
|
|
|
|
|
4990
|
9255038
|
100
|
|
|
|
if (PL_lex_starts++) { |
4991
|
6967193
|
|
|
|
|
s = PL_bufptr; |
4992
|
|
|
|
|
|
#ifdef PERL_MAD |
4993
|
|
|
|
|
|
if (PL_madskills) { |
4994
|
|
|
|
|
|
if (PL_thistoken) |
4995
|
|
|
|
|
|
sv_free(PL_thistoken); |
4996
|
|
|
|
|
|
PL_thistoken = newSVpvs(""); |
4997
|
|
|
|
|
|
} |
4998
|
|
|
|
|
|
#endif |
4999
|
|
|
|
|
|
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ |
5000
|
6967193
|
100
|
|
|
|
if (!PL_lex_casemods && PL_lex_inpat) |
|
|
100
|
|
|
|
|
5001
|
219736
|
|
|
|
|
OPERATOR(','); |
5002
|
|
|
|
|
|
else |
5003
|
6747457
|
|
|
|
|
Aop(OP_CONCAT); |
5004
|
|
|
|
|
|
} |
5005
|
2287845
|
|
|
|
|
return yylex(); |
5006
|
|
|
|
|
|
|
5007
|
|
|
|
|
|
case LEX_INTERPENDMAYBE: |
5008
|
8464695
|
100
|
|
|
|
if (intuit_more(PL_bufptr)) { |
5009
|
1314496
|
|
|
|
|
PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */ |
5010
|
1314496
|
|
|
|
|
break; |
5011
|
|
|
|
|
|
} |
5012
|
|
|
|
|
|
/* FALL THROUGH */ |
5013
|
|
|
|
|
|
|
5014
|
|
|
|
|
|
case LEX_INTERPEND: |
5015
|
9441451
|
100
|
|
|
|
if (PL_lex_dojoin) { |
5016
|
211296
|
|
|
|
|
PL_lex_dojoin = FALSE; |
5017
|
211296
|
|
|
|
|
PL_lex_state = LEX_INTERPCONCAT; |
5018
|
|
|
|
|
|
#ifdef PERL_MAD |
5019
|
|
|
|
|
|
if (PL_madskills) { |
5020
|
|
|
|
|
|
if (PL_thistoken) |
5021
|
|
|
|
|
|
sv_free(PL_thistoken); |
5022
|
|
|
|
|
|
PL_thistoken = newSVpvs(""); |
5023
|
|
|
|
|
|
} |
5024
|
|
|
|
|
|
#endif |
5025
|
211296
|
|
|
|
|
PL_lex_allbrackets--; |
5026
|
211296
|
|
|
|
|
return REPORT(')'); |
5027
|
|
|
|
|
|
} |
5028
|
9230155
|
100
|
|
|
|
if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl |
|
|
100
|
|
|
|
|
5029
|
175367
|
50
|
|
|
|
&& SvEVALED(PL_lex_repl)) |
5030
|
|
|
|
|
|
{ |
5031
|
175367
|
100
|
|
|
|
if (PL_bufptr != PL_bufend) |
5032
|
6
|
|
|
|
|
Perl_croak(aTHX_ "Bad evalled substitution pattern"); |
5033
|
175361
|
|
|
|
|
PL_lex_repl = NULL; |
5034
|
|
|
|
|
|
} |
5035
|
|
|
|
|
|
/* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets |
5036
|
|
|
|
|
|
re_eval_str. If the here-doc body’s length equals the previous |
5037
|
|
|
|
|
|
value of re_eval_start, re_eval_start will now be null. So |
5038
|
|
|
|
|
|
check re_eval_str as well. */ |
5039
|
9230149
|
100
|
|
|
|
if (PL_parser->lex_shared->re_eval_start |
5040
|
9219029
|
50
|
|
|
|
|| PL_parser->lex_shared->re_eval_str) { |
5041
|
|
|
|
|
|
SV *sv; |
5042
|
11120
|
100
|
|
|
|
if (*PL_bufptr != ')') |
5043
|
30
|
|
|
|
|
Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'"); |
5044
|
11090
|
|
|
|
|
PL_bufptr++; |
5045
|
|
|
|
|
|
/* having compiled a (?{..}) expression, return the original |
5046
|
|
|
|
|
|
* text too, as a const */ |
5047
|
11090
|
100
|
|
|
|
if (PL_parser->lex_shared->re_eval_str) { |
5048
|
6
|
|
|
|
|
sv = PL_parser->lex_shared->re_eval_str; |
5049
|
6
|
|
|
|
|
PL_parser->lex_shared->re_eval_str = NULL; |
5050
|
6
|
|
|
|
|
SvCUR_set(sv, |
5051
|
|
|
|
|
|
PL_bufptr - PL_parser->lex_shared->re_eval_start); |
5052
|
6
|
|
|
|
|
SvPV_shrink_to_cur(sv); |
5053
|
|
|
|
|
|
} |
5054
|
11084
|
|
|
|
|
else sv = newSVpvn(PL_parser->lex_shared->re_eval_start, |
5055
|
|
|
|
|
|
PL_bufptr - PL_parser->lex_shared->re_eval_start); |
5056
|
|
|
|
|
|
start_force(PL_curforce); |
5057
|
|
|
|
|
|
/* XXX probably need a CURMAD(something) here */ |
5058
|
22180
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval = |
5059
|
11090
|
|
|
|
|
(OP*)newSVOP(OP_CONST, 0, |
5060
|
|
|
|
|
|
sv); |
5061
|
11090
|
|
|
|
|
force_next(THING); |
5062
|
11090
|
|
|
|
|
PL_parser->lex_shared->re_eval_start = NULL; |
5063
|
11090
|
|
|
|
|
PL_expect = XTERM; |
5064
|
11090
|
|
|
|
|
return REPORT(','); |
5065
|
|
|
|
|
|
} |
5066
|
|
|
|
|
|
|
5067
|
|
|
|
|
|
/* FALLTHROUGH */ |
5068
|
|
|
|
|
|
case LEX_INTERPCONCAT: |
5069
|
|
|
|
|
|
#ifdef DEBUGGING |
5070
|
|
|
|
|
|
if (PL_lex_brackets) |
5071
|
|
|
|
|
|
Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld", |
5072
|
|
|
|
|
|
(long) PL_lex_brackets); |
5073
|
|
|
|
|
|
#endif |
5074
|
27011408
|
100
|
|
|
|
if (PL_bufptr == PL_bufend) |
5075
|
4301133
|
|
|
|
|
return REPORT(sublex_done()); |
5076
|
|
|
|
|
|
|
5077
|
|
|
|
|
|
/* m'foo' still needs to be parsed for possible (?{...}) */ |
5078
|
22710285
|
100
|
|
|
|
if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) { |
|
|
100
|
|
|
|
|
5079
|
10
|
|
|
|
|
SV *sv = newSVsv(PL_linestr); |
5080
|
10
|
|
|
|
|
sv = tokeq(sv); |
5081
|
10
|
|
|
|
|
pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); |
5082
|
10
|
|
|
|
|
s = PL_bufend; |
5083
|
|
|
|
|
|
} |
5084
|
|
|
|
|
|
else { |
5085
|
22710265
|
|
|
|
|
s = scan_const(PL_bufptr); |
5086
|
22710137
|
100
|
|
|
|
if (*s == '\\') |
5087
|
200626
|
|
|
|
|
PL_lex_state = LEX_INTERPCASEMOD; |
5088
|
|
|
|
|
|
else |
5089
|
22509511
|
|
|
|
|
PL_lex_state = LEX_INTERPSTART; |
5090
|
|
|
|
|
|
} |
5091
|
|
|
|
|
|
|
5092
|
22710147
|
100
|
|
|
|
if (s != PL_bufptr) { |
5093
|
|
|
|
|
|
start_force(PL_curforce); |
5094
|
|
|
|
|
|
if (PL_madskills) { |
5095
|
|
|
|
|
|
curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr)); |
5096
|
|
|
|
|
|
} |
5097
|
19981045
|
|
|
|
|
NEXTVAL_NEXTTOKE = pl_yylval; |
5098
|
19981045
|
|
|
|
|
PL_expect = XTERM; |
5099
|
19981045
|
|
|
|
|
force_next(THING); |
5100
|
19981045
|
100
|
|
|
|
if (PL_lex_starts++) { |
5101
|
|
|
|
|
|
#ifdef PERL_MAD |
5102
|
|
|
|
|
|
if (PL_madskills) { |
5103
|
|
|
|
|
|
if (PL_thistoken) |
5104
|
|
|
|
|
|
sv_free(PL_thistoken); |
5105
|
|
|
|
|
|
PL_thistoken = newSVpvs(""); |
5106
|
|
|
|
|
|
} |
5107
|
|
|
|
|
|
#endif |
5108
|
|
|
|
|
|
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ |
5109
|
6285187
|
100
|
|
|
|
if (!PL_lex_casemods && PL_lex_inpat) |
|
|
100
|
|
|
|
|
5110
|
268320
|
|
|
|
|
OPERATOR(','); |
5111
|
|
|
|
|
|
else |
5112
|
6016867
|
|
|
|
|
Aop(OP_CONCAT); |
5113
|
|
|
|
|
|
} |
5114
|
|
|
|
|
|
else { |
5115
|
13695858
|
|
|
|
|
PL_bufptr = s; |
5116
|
13695858
|
|
|
|
|
return yylex(); |
5117
|
|
|
|
|
|
} |
5118
|
|
|
|
|
|
} |
5119
|
|
|
|
|
|
|
5120
|
2729102
|
|
|
|
|
return yylex(); |
5121
|
|
|
|
|
|
case LEX_FORMLINE: |
5122
|
666
|
|
|
|
|
s = scan_formline(PL_bufptr); |
5123
|
666
|
100
|
|
|
|
if (!PL_lex_formbrack) |
5124
|
|
|
|
|
|
{ |
5125
|
|
|
|
|
|
formbrack = 1; |
5126
|
|
|
|
|
|
goto rightbracket; |
5127
|
|
|
|
|
|
} |
5128
|
384
|
|
|
|
|
PL_bufptr = s; |
5129
|
384
|
|
|
|
|
return yylex(); |
5130
|
|
|
|
|
|
} |
5131
|
|
|
|
|
|
|
5132
|
|
|
|
|
|
/* We really do *not* want PL_linestr ever becoming a COW. */ |
5133
|
|
|
|
|
|
assert (!SvIsCOW(PL_linestr)); |
5134
|
741460976
|
|
|
|
|
s = PL_bufptr; |
5135
|
741460976
|
|
|
|
|
PL_oldoldbufptr = PL_oldbufptr; |
5136
|
741460976
|
|
|
|
|
PL_oldbufptr = s; |
5137
|
741460976
|
|
|
|
|
PL_parser->saw_infix_sigil = 0; |
5138
|
|
|
|
|
|
|
5139
|
|
|
|
|
|
retry: |
5140
|
|
|
|
|
|
#ifdef PERL_MAD |
5141
|
|
|
|
|
|
if (PL_thistoken) { |
5142
|
|
|
|
|
|
sv_free(PL_thistoken); |
5143
|
|
|
|
|
|
PL_thistoken = 0; |
5144
|
|
|
|
|
|
} |
5145
|
|
|
|
|
|
PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */ |
5146
|
|
|
|
|
|
#endif |
5147
|
1931271773
|
|
|
|
|
switch (*s) { |
5148
|
|
|
|
|
|
default: |
5149
|
34708
|
50
|
|
|
|
if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s)) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
5150
|
|
|
|
|
|
goto keylookup; |
5151
|
|
|
|
|
|
{ |
5152
|
34208
|
|
|
|
|
SV *dsv = newSVpvs_flags("", SVs_TEMP); |
5153
|
34342
|
50
|
|
|
|
const char *c = UTF ? savepv(sv_uni_display(dsv, newSVpvn_flags(s, |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
5154
|
|
|
|
|
|
UTF8SKIP(s), |
5155
|
|
|
|
|
|
SVs_TEMP | SVf_UTF8), |
5156
|
|
|
|
|
|
10, UNI_DISPLAY_ISPRINT)) |
5157
|
268
|
|
|
|
|
: Perl_form(aTHX_ "\\x%02X", (unsigned char)*s); |
5158
|
34208
|
50
|
|
|
|
len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
5159
|
34208
|
100
|
|
|
|
if (len > UNRECOGNIZED_PRECEDE_COUNT) { |
5160
|
132
|
50
|
|
|
|
d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT; |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
5161
|
|
|
|
|
|
} else { |
5162
|
34076
|
|
|
|
|
d = PL_linestart; |
5163
|
|
|
|
|
|
} |
5164
|
34208
|
|
|
|
|
*s = '\0'; |
5165
|
34208
|
|
|
|
|
sv_setpv(dsv, d); |
5166
|
34208
|
50
|
|
|
|
if (UTF) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
5167
|
33940
|
|
|
|
|
SvUTF8_on(dsv); |
5168
|
34208
|
|
|
|
|
Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"SVf"<-- HERE near column %d", c, SVfARG(dsv), (int) len + 1); |
5169
|
|
|
|
|
|
} |
5170
|
|
|
|
|
|
case 4: |
5171
|
|
|
|
|
|
case 26: |
5172
|
|
|
|
|
|
goto fake_eof; /* emulate EOF on ^D or ^Z */ |
5173
|
|
|
|
|
|
case 0: |
5174
|
|
|
|
|
|
#ifdef PERL_MAD |
5175
|
|
|
|
|
|
if (PL_madskills) |
5176
|
|
|
|
|
|
PL_faketokens = 0; |
5177
|
|
|
|
|
|
#endif |
5178
|
169828796
|
100
|
|
|
|
if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
5179
|
4312505
|
|
|
|
|
PL_last_uni = 0; |
5180
|
4312505
|
|
|
|
|
PL_last_lop = 0; |
5181
|
4312539
|
100
|
|
|
|
if (PL_lex_brackets && |
|
|
100
|
|
|
|
|
5182
|
68
|
|
|
|
|
PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) { |
5183
|
60
|
100
|
|
|
|
yyerror((const char *) |
5184
|
|
|
|
|
|
(PL_lex_formbrack |
5185
|
|
|
|
|
|
? "Format not terminated" |
5186
|
|
|
|
|
|
: "Missing right curly or square bracket")); |
5187
|
|
|
|
|
|
} |
5188
|
|
|
|
|
|
DEBUG_T( { PerlIO_printf(Perl_debug_log, |
5189
|
|
|
|
|
|
"### Tokener got EOF\n"); |
5190
|
|
|
|
|
|
} ); |
5191
|
4312505
|
|
|
|
|
TOKEN(0); |
5192
|
|
|
|
|
|
} |
5193
|
165516291
|
50
|
|
|
|
if (s++ < PL_bufend) |
5194
|
|
|
|
|
|
goto retry; /* ignore stray nulls */ |
5195
|
165516291
|
|
|
|
|
PL_last_uni = 0; |
5196
|
165516291
|
|
|
|
|
PL_last_lop = 0; |
5197
|
165516291
|
100
|
|
|
|
if (!PL_in_eval && !PL_preambled) { |
|
|
100
|
|
|
|
|
5198
|
24242
|
|
|
|
|
PL_preambled = TRUE; |
5199
|
|
|
|
|
|
#ifdef PERL_MAD |
5200
|
|
|
|
|
|
if (PL_madskills) |
5201
|
|
|
|
|
|
PL_faketokens = 1; |
5202
|
|
|
|
|
|
#endif |
5203
|
24242
|
100
|
|
|
|
if (PL_perldb) { |
5204
|
|
|
|
|
|
/* Generate a string of Perl code to load the debugger. |
5205
|
|
|
|
|
|
* If PERL5DB is set, it will return the contents of that, |
5206
|
|
|
|
|
|
* otherwise a compile-time require of perl5db.pl. */ |
5207
|
|
|
|
|
|
|
5208
|
222
|
|
|
|
|
const char * const pdb = PerlEnv_getenv("PERL5DB"); |
5209
|
|
|
|
|
|
|
5210
|
222
|
100
|
|
|
|
if (pdb) { |
5211
|
18
|
|
|
|
|
sv_setpv(PL_linestr, pdb); |
5212
|
18
|
|
|
|
|
sv_catpvs(PL_linestr,";"); |
5213
|
|
|
|
|
|
} else { |
5214
|
204
|
|
|
|
|
SETERRNO(0,SS_NORMAL); |
5215
|
204
|
|
|
|
|
sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };"); |
5216
|
|
|
|
|
|
} |
5217
|
|
|
|
|
|
} else |
5218
|
24020
|
|
|
|
|
sv_setpvs(PL_linestr,""); |
5219
|
24242
|
100
|
|
|
|
if (PL_preambleav) { |
5220
|
14642
|
|
|
|
|
SV **svp = AvARRAY(PL_preambleav); |
5221
|
14642
|
|
|
|
|
SV **const end = svp + AvFILLp(PL_preambleav); |
5222
|
43335
|
100
|
|
|
|
while(svp <= end) { |
5223
|
21372
|
|
|
|
|
sv_catsv(PL_linestr, *svp); |
5224
|
21372
|
|
|
|
|
++svp; |
5225
|
21372
|
|
|
|
|
sv_catpvs(PL_linestr, ";"); |
5226
|
|
|
|
|
|
} |
5227
|
14642
|
|
|
|
|
sv_free(MUTABLE_SV(PL_preambleav)); |
5228
|
14642
|
|
|
|
|
PL_preambleav = NULL; |
5229
|
|
|
|
|
|
} |
5230
|
24242
|
100
|
|
|
|
if (PL_minus_E) |
5231
|
10
|
|
|
|
|
sv_catpvs(PL_linestr, |
5232
|
|
|
|
|
|
"use feature ':5." STRINGIFY(PERL_VERSION) "';"); |
5233
|
24242
|
100
|
|
|
|
if (PL_minus_n || PL_minus_p) { |
|
|
100
|
|
|
|
|
5234
|
118
|
|
|
|
|
sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/); |
5235
|
118
|
100
|
|
|
|
if (PL_minus_l) |
5236
|
4
|
|
|
|
|
sv_catpvs(PL_linestr,"chomp;"); |
5237
|
118
|
100
|
|
|
|
if (PL_minus_a) { |
5238
|
18
|
100
|
|
|
|
if (PL_minus_F) { |
5239
|
8
|
50
|
|
|
|
if ((*PL_splitstr == '/' || *PL_splitstr == '\'' |
|
|
0
|
|
|
|
|
5240
|
8
|
50
|
|
|
|
|| *PL_splitstr == '"') |
5241
|
0
|
0
|
|
|
|
&& strchr(PL_splitstr + 1, *PL_splitstr)) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
5242
|
0
|
|
|
|
|
Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr); |
5243
|
|
|
|
|
|
else { |
5244
|
|
|
|
|
|
/* "q\0${splitstr}\0" is legal perl. Yes, even NUL |
5245
|
|
|
|
|
|
bytes can be used as quoting characters. :-) */ |
5246
|
8
|
|
|
|
|
const char *splits = PL_splitstr; |
5247
|
8
|
|
|
|
|
sv_catpvs(PL_linestr, "our @F=split(q\0"); |
5248
|
|
|
|
|
|
do { |
5249
|
|
|
|
|
|
/* Need to \ \s */ |
5250
|
38
|
100
|
|
|
|
if (*splits == '\\') |
5251
|
4
|
|
|
|
|
sv_catpvn(PL_linestr, splits, 1); |
5252
|
38
|
|
|
|
|
sv_catpvn(PL_linestr, splits, 1); |
5253
|
38
|
100
|
|
|
|
} while (*splits++); |
5254
|
|
|
|
|
|
/* This loop will embed the trailing NUL of |
5255
|
|
|
|
|
|
PL_linestr as the last thing it does before |
5256
|
|
|
|
|
|
terminating. */ |
5257
|
8
|
|
|
|
|
sv_catpvs(PL_linestr, ");"); |
5258
|
|
|
|
|
|
} |
5259
|
|
|
|
|
|
} |
5260
|
|
|
|
|
|
else |
5261
|
10
|
|
|
|
|
sv_catpvs(PL_linestr,"our @F=split(' ');"); |
5262
|
|
|
|
|
|
} |
5263
|
|
|
|
|
|
} |
5264
|
24242
|
|
|
|
|
sv_catpvs(PL_linestr, "\n"); |
5265
|
24242
|
|
|
|
|
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); |
5266
|
24242
|
|
|
|
|
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); |
5267
|
24242
|
|
|
|
|
PL_last_lop = PL_last_uni = NULL; |
5268
|
24242
|
100
|
|
|
|
if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
5269
|
214
|
|
|
|
|
update_debugger_info(PL_linestr, NULL, 0); |
5270
|
|
|
|
|
|
goto retry; |
5271
|
|
|
|
|
|
} |
5272
|
|
|
|
|
|
do { |
5273
|
|
|
|
|
|
fake_eof = 0; |
5274
|
188730235
|
|
|
|
|
bof = PL_rsfp ? TRUE : FALSE; |
5275
|
|
|
|
|
|
if (0) { |
5276
|
|
|
|
|
|
fake_eof: |
5277
|
|
|
|
|
|
fake_eof = LEX_FAKE_EOF; |
5278
|
|
|
|
|
|
} |
5279
|
189120165
|
|
|
|
|
PL_bufptr = PL_bufend; |
5280
|
189120165
|
100
|
|
|
|
COPLINE_INC_WITH_HERELINES; |
5281
|
189120165
|
50
|
|
|
|
if (!lex_next_chunk(fake_eof)) { |
5282
|
0
|
|
|
|
|
CopLINE_dec(PL_curcop); |
5283
|
0
|
|
|
|
|
s = PL_bufptr; |
5284
|
0
|
|
|
|
|
TOKEN(';'); /* not infinite loop because rsfp is NULL now */ |
5285
|
|
|
|
|
|
} |
5286
|
189120155
|
|
|
|
|
CopLINE_dec(PL_curcop); |
5287
|
|
|
|
|
|
#ifdef PERL_MAD |
5288
|
|
|
|
|
|
if (!PL_rsfp) |
5289
|
|
|
|
|
|
PL_realtokenstart = -1; |
5290
|
|
|
|
|
|
#endif |
5291
|
189120155
|
|
|
|
|
s = PL_bufptr; |
5292
|
|
|
|
|
|
/* If it looks like the start of a BOM or raw UTF-16, |
5293
|
|
|
|
|
|
* check if it in fact is. */ |
5294
|
280157196
|
100
|
|
|
|
if (bof && PL_rsfp && |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
5295
|
279550619
|
100
|
|
|
|
(*s == 0 || |
5296
|
279549585
|
100
|
|
|
|
*(U8*)s == BOM_UTF8_FIRST_BYTE || |
5297
|
279545572
|
100
|
|
|
|
*(U8*)s >= 0xFE || |
5298
|
188509548
|
|
|
|
|
s[1] == 0)) { |
5299
|
34061281
|
|
|
|
|
Off_t offset = (IV)PerlIO_tell(PL_rsfp); |
5300
|
34061281
|
|
|
|
|
bof = (offset == (Off_t)SvCUR(PL_linestr)); |
5301
|
|
|
|
|
|
#if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS) |
5302
|
|
|
|
|
|
/* offset may include swallowed CR */ |
5303
|
|
|
|
|
|
if (!bof) |
5304
|
|
|
|
|
|
bof = (offset == (Off_t)SvCUR(PL_linestr)+1); |
5305
|
|
|
|
|
|
#endif |
5306
|
34061281
|
100
|
|
|
|
if (bof) { |
5307
|
24674
|
|
|
|
|
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); |
5308
|
24674
|
|
|
|
|
s = swallow_bom((U8*)s); |
5309
|
|
|
|
|
|
} |
5310
|
|
|
|
|
|
} |
5311
|
189120155
|
100
|
|
|
|
if (PL_parser->in_pod) { |
5312
|
|
|
|
|
|
/* Incest with pod. */ |
5313
|
|
|
|
|
|
#ifdef PERL_MAD |
5314
|
|
|
|
|
|
if (PL_madskills) |
5315
|
|
|
|
|
|
sv_catsv(PL_thiswhite, PL_linestr); |
5316
|
|
|
|
|
|
#endif |
5317
|
24113065
|
100
|
|
|
|
if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
5318
|
874879
|
|
|
|
|
sv_setpvs(PL_linestr, ""); |
5319
|
874879
|
|
|
|
|
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); |
5320
|
874879
|
|
|
|
|
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); |
5321
|
874879
|
|
|
|
|
PL_last_lop = PL_last_uni = NULL; |
5322
|
874879
|
|
|
|
|
PL_parser->in_pod = 0; |
5323
|
|
|
|
|
|
} |
5324
|
|
|
|
|
|
} |
5325
|
189120155
|
100
|
|
|
|
if (PL_rsfp || PL_parser->filtered) |
|
|
100
|
|
|
|
|
5326
|
188515580
|
|
|
|
|
incline(s); |
5327
|
189120155
|
100
|
|
|
|
} while (PL_parser->in_pod); |
5328
|
165881969
|
|
|
|
|
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; |
5329
|
165881969
|
|
|
|
|
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); |
5330
|
165881969
|
|
|
|
|
PL_last_lop = PL_last_uni = NULL; |
5331
|
165881969
|
100
|
|
|
|
if (CopLINE(PL_curcop) == 1) { |
5332
|
661843
|
100
|
|
|
|
while (s < PL_bufend && isSPACE(*s)) |
|
|
100
|
|
|
|
|
5333
|
41236
|
|
|
|
|
s++; |
5334
|
620607
|
50
|
|
|
|
if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */ |
|
|
0
|
|
|
|
|
5335
|
0
|
|
|
|
|
s++; |
5336
|
|
|
|
|
|
#ifdef PERL_MAD |
5337
|
|
|
|
|
|
if (PL_madskills) |
5338
|
|
|
|
|
|
PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart); |
5339
|
|
|
|
|
|
#endif |
5340
|
|
|
|
|
|
d = NULL; |
5341
|
620607
|
100
|
|
|
|
if (!PL_in_eval) { |
5342
|
29140
|
100
|
|
|
|
if (*s == '#' && *(s+1) == '!') |
|
|
100
|
|
|
|
|
5343
|
5568
|
|
|
|
|
d = s + 2; |
5344
|
|
|
|
|
|
#ifdef ALTERNATE_SHEBANG |
5345
|
|
|
|
|
|
else { |
5346
|
|
|
|
|
|
static char const as[] = ALTERNATE_SHEBANG; |
5347
|
|
|
|
|
|
if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1)) |
5348
|
|
|
|
|
|
d = s + (sizeof(as) - 1); |
5349
|
|
|
|
|
|
} |
5350
|
|
|
|
|
|
#endif /* ALTERNATE_SHEBANG */ |
5351
|
|
|
|
|
|
} |
5352
|
620607
|
100
|
|
|
|
if (d) { |
5353
|
|
|
|
|
|
char *ipath; |
5354
|
|
|
|
|
|
char *ipathend; |
5355
|
|
|
|
|
|
|
5356
|
5734
|
100
|
|
|
|
while (isSPACE(*d)) |
5357
|
166
|
|
|
|
|
d++; |
5358
|
|
|
|
|
|
ipath = d; |
5359
|
87494
|
50
|
|
|
|
while (*d && !isSPACE(*d)) |
|
|
100
|
|
|
|
|
5360
|
81926
|
|
|
|
|
d++; |
5361
|
|
|
|
|
|
ipathend = d; |
5362
|
|
|
|
|
|
|
5363
|
|
|
|
|
|
#ifdef ARG_ZERO_IS_SCRIPT |
5364
|
|
|
|
|
|
if (ipathend > ipath) { |
5365
|
|
|
|
|
|
/* |
5366
|
|
|
|
|
|
* HP-UX (at least) sets argv[0] to the script name, |
5367
|
|
|
|
|
|
* which makes $^X incorrect. And Digital UNIX and Linux, |
5368
|
|
|
|
|
|
* at least, set argv[0] to the basename of the Perl |
5369
|
|
|
|
|
|
* interpreter. So, having found "#!", we'll set it right. |
5370
|
|
|
|
|
|
*/ |
5371
|
|
|
|
|
|
SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, |
5372
|
|
|
|
|
|
SVt_PV)); /* $^X */ |
5373
|
|
|
|
|
|
assert(SvPOK(x) || SvGMAGICAL(x)); |
5374
|
|
|
|
|
|
if (sv_eq(x, CopFILESV(PL_curcop))) { |
5375
|
|
|
|
|
|
sv_setpvn(x, ipath, ipathend - ipath); |
5376
|
|
|
|
|
|
SvSETMAGIC(x); |
5377
|
|
|
|
|
|
} |
5378
|
|
|
|
|
|
else { |
5379
|
|
|
|
|
|
STRLEN blen; |
5380
|
|
|
|
|
|
STRLEN llen; |
5381
|
|
|
|
|
|
const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen); |
5382
|
|
|
|
|
|
const char * const lstart = SvPV_const(x,llen); |
5383
|
|
|
|
|
|
if (llen < blen) { |
5384
|
|
|
|
|
|
bstart += blen - llen; |
5385
|
|
|
|
|
|
if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') { |
5386
|
|
|
|
|
|
sv_setpvn(x, ipath, ipathend - ipath); |
5387
|
|
|
|
|
|
SvSETMAGIC(x); |
5388
|
|
|
|
|
|
} |
5389
|
|
|
|
|
|
} |
5390
|
|
|
|
|
|
} |
5391
|
|
|
|
|
|
TAINT_NOT; /* $^X is always tainted, but that's OK */ |
5392
|
|
|
|
|
|
} |
5393
|
|
|
|
|
|
#endif /* ARG_ZERO_IS_SCRIPT */ |
5394
|
|
|
|
|
|
|
5395
|
|
|
|
|
|
/* |
5396
|
|
|
|
|
|
* Look for options. |
5397
|
|
|
|
|
|
*/ |
5398
|
5568
|
|
|
|
|
d = instr(s,"perl -"); |
5399
|
5568
|
100
|
|
|
|
if (!d) { |
5400
|
3790
|
|
|
|
|
d = instr(s,"perl"); |
5401
|
|
|
|
|
|
#if defined(DOSISH) |
5402
|
|
|
|
|
|
/* avoid getting into infinite loops when shebang |
5403
|
|
|
|
|
|
* line contains "Perl" rather than "perl" */ |
5404
|
|
|
|
|
|
if (!d) { |
5405
|
|
|
|
|
|
for (d = ipathend-4; d >= ipath; --d) { |
5406
|
|
|
|
|
|
if ((*d == 'p' || *d == 'P') |
5407
|
|
|
|
|
|
&& !ibcmp(d, "perl", 4)) |
5408
|
|
|
|
|
|
{ |
5409
|
|
|
|
|
|
break; |
5410
|
|
|
|
|
|
} |
5411
|
|
|
|
|
|
} |
5412
|
|
|
|
|
|
if (d < ipath) |
5413
|
|
|
|
|
|
d = NULL; |
5414
|
|
|
|
|
|
} |
5415
|
|
|
|
|
|
#endif |
5416
|
|
|
|
|
|
} |
5417
|
|
|
|
|
|
#ifdef ALTERNATE_SHEBANG |
5418
|
|
|
|
|
|
/* |
5419
|
|
|
|
|
|
* If the ALTERNATE_SHEBANG on this system starts with a |
5420
|
|
|
|
|
|
* character that can be part of a Perl expression, then if |
5421
|
|
|
|
|
|
* we see it but not "perl", we're probably looking at the |
5422
|
|
|
|
|
|
* start of Perl code, not a request to hand off to some |
5423
|
|
|
|
|
|
* other interpreter. Similarly, if "perl" is there, but |
5424
|
|
|
|
|
|
* not in the first 'word' of the line, we assume the line |
5425
|
|
|
|
|
|
* contains the start of the Perl program. |
5426
|
|
|
|
|
|
*/ |
5427
|
|
|
|
|
|
if (d && *s != '#') { |
5428
|
|
|
|
|
|
const char *c = ipath; |
5429
|
|
|
|
|
|
while (*c && !strchr("; \t\r\n\f\v#", *c)) |
5430
|
|
|
|
|
|
c++; |
5431
|
|
|
|
|
|
if (c < d) |
5432
|
|
|
|
|
|
d = NULL; /* "perl" not in first word; ignore */ |
5433
|
|
|
|
|
|
else |
5434
|
|
|
|
|
|
*s = '#'; /* Don't try to parse shebang line */ |
5435
|
|
|
|
|
|
} |
5436
|
|
|
|
|
|
#endif /* ALTERNATE_SHEBANG */ |
5437
|
5568
|
50
|
|
|
|
if (!d && |
5438
|
0
|
0
|
|
|
|
*s == '#' && |
5439
|
0
|
0
|
|
|
|
ipathend > ipath && |
5440
|
0
|
0
|
|
|
|
!PL_minus_c && |
5441
|
0
|
0
|
|
|
|
!instr(s,"indir") && |
5442
|
0
|
|
|
|
|
instr(PL_origargv[0],"perl")) |
5443
|
|
|
|
|
|
{ |
5444
|
|
|
|
|
|
dVAR; |
5445
|
|
|
|
|
|
char **newargv; |
5446
|
|
|
|
|
|
|
5447
|
0
|
|
|
|
|
*ipathend = '\0'; |
5448
|
0
|
|
|
|
|
s = ipathend + 1; |
5449
|
0
|
0
|
|
|
|
while (s < PL_bufend && isSPACE(*s)) |
|
|
0
|
|
|
|
|
5450
|
0
|
|
|
|
|
s++; |
5451
|
0
|
0
|
|
|
|
if (s < PL_bufend) { |
5452
|
0
|
0
|
|
|
|
Newx(newargv,PL_origargc+3,char*); |
5453
|
0
|
|
|
|
|
newargv[1] = s; |
5454
|
0
|
0
|
|
|
|
while (s < PL_bufend && !isSPACE(*s)) |
|
|
0
|
|
|
|
|
5455
|
0
|
|
|
|
|
s++; |
5456
|
0
|
|
|
|
|
*s = '\0'; |
5457
|
0
|
0
|
|
|
|
Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*); |
5458
|
|
|
|
|
|
} |
5459
|
|
|
|
|
|
else |
5460
|
0
|
|
|
|
|
newargv = PL_origargv; |
5461
|
0
|
|
|
|
|
newargv[0] = ipath; |
5462
|
0
|
|
|
|
|
PERL_FPU_PRE_EXEC |
5463
|
0
|
|
|
|
|
PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv)); |
5464
|
0
|
|
|
|
|
PERL_FPU_POST_EXEC |
5465
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Can't exec %s", ipath); |
5466
|
|
|
|
|
|
} |
5467
|
5568
|
50
|
|
|
|
if (d) { |
5468
|
46136
|
50
|
|
|
|
while (*d && !isSPACE(*d)) |
|
|
100
|
|
|
|
|
5469
|
40568
|
|
|
|
|
d++; |
5470
|
7434
|
100
|
|
|
|
while (SPACE_OR_TAB(*d)) |
5471
|
1866
|
|
|
|
|
d++; |
5472
|
|
|
|
|
|
|
5473
|
5568
|
100
|
|
|
|
if (*d++ == '-') { |
5474
|
1856
|
|
|
|
|
const bool switches_done = PL_doswitches; |
5475
|
1856
|
|
|
|
|
const U32 oldpdb = PL_perldb; |
5476
|
1856
|
|
|
|
|
const bool oldn = PL_minus_n; |
5477
|
1856
|
|
|
|
|
const bool oldp = PL_minus_p; |
5478
|
1856
|
|
|
|
|
const char *d1 = d; |
5479
|
|
|
|
|
|
|
5480
|
|
|
|
|
|
do { |
5481
|
|
|
|
|
|
bool baduni = FALSE; |
5482
|
3692
|
100
|
|
|
|
if (*d1 == 'C') { |
5483
|
10
|
|
|
|
|
const char *d2 = d1 + 1; |
5484
|
15
|
100
|
|
|
|
if (parse_unicode_opts((const char **)&d2) |
5485
|
10
|
|
|
|
|
!= PL_unicode) |
5486
|
|
|
|
|
|
baduni = TRUE; |
5487
|
|
|
|
|
|
} |
5488
|
3692
|
100
|
|
|
|
if (baduni || *d1 == 'M' || *d1 == 'm') { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
5489
|
|
|
|
|
|
const char * const m = d1; |
5490
|
20
|
50
|
|
|
|
while (*d1 && !isSPACE(*d1)) |
|
|
100
|
|
|
|
|
5491
|
12
|
|
|
|
|
d1++; |
5492
|
8
|
|
|
|
|
Perl_croak(aTHX_ "Too late for \"-%.*s\" option", |
5493
|
8
|
|
|
|
|
(int)(d1 - m), m); |
5494
|
|
|
|
|
|
} |
5495
|
3684
|
|
|
|
|
d1 = moreswitches(d1); |
5496
|
3606
|
100
|
|
|
|
} while (d1); |
5497
|
1770
|
100
|
|
|
|
if (PL_doswitches && !switches_done) { |
|
|
50
|
|
|
|
|
5498
|
6
|
|
|
|
|
int argc = PL_origargc; |
5499
|
6
|
|
|
|
|
char **argv = PL_origargv; |
5500
|
|
|
|
|
|
do { |
5501
|
18
|
|
|
|
|
argc--,argv++; |
5502
|
18
|
50
|
|
|
|
} while (argc && argv[0][0] == '-' && argv[0][1]); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
5503
|
6
|
|
|
|
|
init_argv_symbols(argc,argv); |
5504
|
|
|
|
|
|
} |
5505
|
1770
|
100
|
|
|
|
if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) || |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
5506
|
1763
|
100
|
|
|
|
((PL_minus_n || PL_minus_p) && !(oldn || oldp))) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
5507
|
|
|
|
|
|
/* if we have already added "LINE: while (<>) {", |
5508
|
|
|
|
|
|
we must not do it again */ |
5509
|
|
|
|
|
|
{ |
5510
|
14
|
|
|
|
|
sv_setpvs(PL_linestr, ""); |
5511
|
14
|
|
|
|
|
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); |
5512
|
14
|
|
|
|
|
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); |
5513
|
14
|
|
|
|
|
PL_last_lop = PL_last_uni = NULL; |
5514
|
14
|
|
|
|
|
PL_preambled = FALSE; |
5515
|
14
|
100
|
|
|
|
if (PERLDB_LINE || PERLDB_SAVESRC) |
|
|
100
|
|
|
|
|
5516
|
2
|
|
|
|
|
(void)gv_fetchfile(PL_origfilename); |
5517
|
|
|
|
|
|
goto retry; |
5518
|
|
|
|
|
|
} |
5519
|
|
|
|
|
|
} |
5520
|
|
|
|
|
|
} |
5521
|
|
|
|
|
|
} |
5522
|
|
|
|
|
|
} |
5523
|
165881869
|
100
|
|
|
|
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { |
|
|
100
|
|
|
|
|
5524
|
468
|
|
|
|
|
PL_lex_state = LEX_FORMLINE; |
5525
|
|
|
|
|
|
start_force(PL_curforce); |
5526
|
468
|
|
|
|
|
NEXTVAL_NEXTTOKE.ival = 0; |
5527
|
468
|
|
|
|
|
force_next(FORMRBRACK); |
5528
|
468
|
|
|
|
|
TOKEN(';'); |
5529
|
|
|
|
|
|
} |
5530
|
|
|
|
|
|
goto retry; |
5531
|
|
|
|
|
|
case '\r': |
5532
|
|
|
|
|
|
#ifdef PERL_STRICT_CR |
5533
|
|
|
|
|
|
Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r'); |
5534
|
|
|
|
|
|
Perl_croak(aTHX_ |
5535
|
|
|
|
|
|
"\t(Maybe you didn't strip carriage returns after a network transfer?)\n"); |
5536
|
|
|
|
|
|
#endif |
5537
|
|
|
|
|
|
case ' ': case '\t': case '\f': case 013: |
5538
|
|
|
|
|
|
#ifdef PERL_MAD |
5539
|
|
|
|
|
|
PL_realtokenstart = -1; |
5540
|
|
|
|
|
|
if (PL_madskills) { |
5541
|
|
|
|
|
|
if (!PL_thiswhite) |
5542
|
|
|
|
|
|
PL_thiswhite = newSVpvs(""); |
5543
|
|
|
|
|
|
sv_catpvn(PL_thiswhite, s, 1); |
5544
|
|
|
|
|
|
} |
5545
|
|
|
|
|
|
#endif |
5546
|
851402688
|
|
|
|
|
s++; |
5547
|
851402688
|
|
|
|
|
goto retry; |
5548
|
|
|
|
|
|
case '#': |
5549
|
|
|
|
|
|
case '\n': |
5550
|
|
|
|
|
|
#ifdef PERL_MAD |
5551
|
|
|
|
|
|
PL_realtokenstart = -1; |
5552
|
|
|
|
|
|
if (PL_madskills) |
5553
|
|
|
|
|
|
PL_faketokens = 0; |
5554
|
|
|
|
|
|
#endif |
5555
|
338651585
|
100
|
|
|
|
if (PL_lex_state != LEX_NORMAL || |
|
|
100
|
|
|
|
|
5556
|
252776030
|
100
|
|
|
|
(PL_in_eval && !PL_rsfp && !PL_parser->filtered)) { |
|
|
100
|
|
|
|
|
5557
|
7333874
|
100
|
|
|
|
if (*s == '#' && s == PL_linestart && PL_in_eval |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
5558
|
15010
|
50
|
|
|
|
&& !PL_rsfp && !PL_parser->filtered) { |
|
|
50
|
|
|
|
|
5559
|
|
|
|
|
|
/* handle eval qq[#line 1 "foo"\n ...] */ |
5560
|
15010
|
|
|
|
|
CopLINE_dec(PL_curcop); |
5561
|
15010
|
|
|
|
|
incline(s); |
5562
|
|
|
|
|
|
} |
5563
|
|
|
|
|
|
if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) { |
5564
|
|
|
|
|
|
s = SKIPSPACE0(s); |
5565
|
|
|
|
|
|
if (!PL_in_eval || PL_rsfp || PL_parser->filtered) |
5566
|
|
|
|
|
|
incline(s); |
5567
|
|
|
|
|
|
} |
5568
|
|
|
|
|
|
else { |
5569
|
7333874
|
|
|
|
|
const bool in_comment = *s == '#'; |
5570
|
|
|
|
|
|
d = s; |
5571
|
24585596
|
100
|
|
|
|
while (d < PL_bufend && *d != '\n') |
|
|
100
|
|
|
|
|
5572
|
13655338
|
|
|
|
|
d++; |
5573
|
7333874
|
100
|
|
|
|
if (d < PL_bufend) |
5574
|
7333870
|
|
|
|
|
d++; |
5575
|
4
|
50
|
|
|
|
else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */ |
5576
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: input overflow, %p > %p", |
5577
|
0
|
|
|
|
|
d, PL_bufend); |
5578
|
|
|
|
|
|
#ifdef PERL_MAD |
5579
|
|
|
|
|
|
if (PL_madskills) |
5580
|
|
|
|
|
|
PL_thiswhite = newSVpvn(s, d - s); |
5581
|
|
|
|
|
|
#endif |
5582
|
|
|
|
|
|
s = d; |
5583
|
7333874
|
100
|
|
|
|
if (in_comment && d == PL_bufend |
|
|
100
|
|
|
|
|
5584
|
4
|
50
|
|
|
|
&& PL_lex_state == LEX_INTERPNORMAL |
5585
|
4
|
50
|
|
|
|
&& PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr |
|
|
50
|
|
|
|
|
5586
|
4
|
50
|
|
|
|
&& SvEVALED(PL_lex_repl) && d[-1] == '}') s--; |
|
|
50
|
|
|
|
|
5587
|
7333870
|
|
|
|
|
else incline(s); |
5588
|
|
|
|
|
|
} |
5589
|
7333874
|
100
|
|
|
|
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { |
|
|
50
|
|
|
|
|
5590
|
138
|
|
|
|
|
PL_lex_state = LEX_FORMLINE; |
5591
|
|
|
|
|
|
start_force(PL_curforce); |
5592
|
138
|
|
|
|
|
NEXTVAL_NEXTTOKE.ival = 0; |
5593
|
138
|
|
|
|
|
force_next(FORMRBRACK); |
5594
|
138
|
|
|
|
|
TOKEN(';'); |
5595
|
|
|
|
|
|
} |
5596
|
|
|
|
|
|
} |
5597
|
|
|
|
|
|
else { |
5598
|
|
|
|
|
|
#ifdef PERL_MAD |
5599
|
|
|
|
|
|
if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) { |
5600
|
|
|
|
|
|
if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') { |
5601
|
|
|
|
|
|
PL_faketokens = 0; |
5602
|
|
|
|
|
|
s = SKIPSPACE0(s); |
5603
|
|
|
|
|
|
TOKEN(PEG); /* make sure any #! line is accessible */ |
5604
|
|
|
|
|
|
} |
5605
|
|
|
|
|
|
s = SKIPSPACE0(s); |
5606
|
|
|
|
|
|
} |
5607
|
|
|
|
|
|
else { |
5608
|
|
|
|
|
|
#endif |
5609
|
|
|
|
|
|
if (PL_madskills) d = s; |
5610
|
1119912821
|
50
|
|
|
|
while (s < PL_bufend && *s != '\n') |
|
|
100
|
|
|
|
|
5611
|
955628616
|
|
|
|
|
s++; |
5612
|
164284205
|
50
|
|
|
|
if (s < PL_bufend) |
5613
|
|
|
|
|
|
{ |
5614
|
164284205
|
|
|
|
|
s++; |
5615
|
164284205
|
100
|
|
|
|
if (s < PL_bufend) |
5616
|
556890
|
|
|
|
|
incline(s); |
5617
|
|
|
|
|
|
} |
5618
|
0
|
0
|
|
|
|
else if (s > PL_bufend) /* Found by Ilya: feed random input to Perl. */ |
5619
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: input overflow"); |
5620
|
|
|
|
|
|
#ifdef PERL_MAD |
5621
|
|
|
|
|
|
if (PL_madskills && CopLINE(PL_curcop) >= 1) { |
5622
|
|
|
|
|
|
if (!PL_thiswhite) |
5623
|
|
|
|
|
|
PL_thiswhite = newSVpvs(""); |
5624
|
|
|
|
|
|
if (CopLINE(PL_curcop) == 1) { |
5625
|
|
|
|
|
|
sv_setpvs(PL_thiswhite, ""); |
5626
|
|
|
|
|
|
PL_faketokens = 0; |
5627
|
|
|
|
|
|
} |
5628
|
|
|
|
|
|
sv_catpvn(PL_thiswhite, d, s - d); |
5629
|
|
|
|
|
|
} |
5630
|
|
|
|
|
|
} |
5631
|
|
|
|
|
|
#endif |
5632
|
|
|
|
|
|
} |
5633
|
|
|
|
|
|
goto retry; |
5634
|
|
|
|
|
|
case '-': |
5635
|
24288174
|
50
|
|
|
|
if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
5636
|
|
|
|
|
|
I32 ftst = 0; |
5637
|
|
|
|
|
|
char tmp; |
5638
|
|
|
|
|
|
|
5639
|
751256
|
|
|
|
|
s++; |
5640
|
751256
|
|
|
|
|
PL_bufptr = s; |
5641
|
751256
|
|
|
|
|
tmp = *s++; |
5642
|
|
|
|
|
|
|
5643
|
1865678
|
50
|
|
|
|
while (s < PL_bufend && SPACE_OR_TAB(*s)) |
|
|
100
|
|
|
|
|
5644
|
745454
|
|
|
|
|
s++; |
5645
|
|
|
|
|
|
|
5646
|
751256
|
100
|
|
|
|
if (strnEQ(s,"=>",2)) { |
5647
|
50
|
|
|
|
|
s = force_word(PL_bufptr,WORD,FALSE,FALSE); |
5648
|
|
|
|
|
|
DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } ); |
5649
|
50
|
|
|
|
|
OPERATOR('-'); /* unary minus */ |
5650
|
|
|
|
|
|
} |
5651
|
751206
|
|
|
|
|
PL_last_uni = PL_oldbufptr; |
5652
|
751206
|
|
|
|
|
switch (tmp) { |
5653
|
9586
|
|
|
|
|
case 'r': ftst = OP_FTEREAD; break; |
5654
|
32234
|
|
|
|
|
case 'w': ftst = OP_FTEWRITE; break; |
5655
|
23804
|
|
|
|
|
case 'x': ftst = OP_FTEEXEC; break; |
5656
|
174
|
|
|
|
|
case 'o': ftst = OP_FTEOWNED; break; |
5657
|
172
|
|
|
|
|
case 'R': ftst = OP_FTRREAD; break; |
5658
|
176
|
|
|
|
|
case 'W': ftst = OP_FTRWRITE; break; |
5659
|
172
|
|
|
|
|
case 'X': ftst = OP_FTREXEC; break; |
5660
|
172
|
|
|
|
|
case 'O': ftst = OP_FTROWNED; break; |
5661
|
100986
|
|
|
|
|
case 'e': ftst = OP_FTIS; break; |
5662
|
556
|
|
|
|
|
case 'z': ftst = OP_FTZERO; break; |
5663
|
55950
|
|
|
|
|
case 's': ftst = OP_FTSIZE; break; |
5664
|
157360
|
|
|
|
|
case 'f': ftst = OP_FTFILE; break; |
5665
|
300870
|
|
|
|
|
case 'd': ftst = OP_FTDIR; break; |
5666
|
51196
|
|
|
|
|
case 'l': ftst = OP_FTLINK; break; |
5667
|
3340
|
|
|
|
|
case 'p': ftst = OP_FTPIPE; break; |
5668
|
206
|
|
|
|
|
case 'S': ftst = OP_FTSOCK; break; |
5669
|
328
|
|
|
|
|
case 'u': ftst = OP_FTSUID; break; |
5670
|
326
|
|
|
|
|
case 'g': ftst = OP_FTSGID; break; |
5671
|
1096
|
|
|
|
|
case 'k': ftst = OP_FTSVTX; break; |
5672
|
200
|
|
|
|
|
case 'b': ftst = OP_FTBLK; break; |
5673
|
1980
|
|
|
|
|
case 'c': ftst = OP_FTCHR; break; |
5674
|
3870
|
|
|
|
|
case 't': ftst = OP_FTTTY; break; |
5675
|
1140
|
|
|
|
|
case 'T': ftst = OP_FTTEXT; break; |
5676
|
2290
|
|
|
|
|
case 'B': ftst = OP_FTBINARY; break; |
5677
|
|
|
|
|
|
case 'M': case 'A': case 'C': |
5678
|
3018
|
|
|
|
|
gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV); |
5679
|
3018
|
|
|
|
|
switch (tmp) { |
5680
|
2672
|
|
|
|
|
case 'M': ftst = OP_FTMTIME; break; |
5681
|
170
|
|
|
|
|
case 'A': ftst = OP_FTATIME; break; |
5682
|
176
|
|
|
|
|
case 'C': ftst = OP_FTCTIME; break; |
5683
|
|
|
|
|
|
default: break; |
5684
|
|
|
|
|
|
} |
5685
|
|
|
|
|
|
break; |
5686
|
|
|
|
|
|
default: |
5687
|
|
|
|
|
|
break; |
5688
|
|
|
|
|
|
} |
5689
|
751206
|
100
|
|
|
|
if (ftst) { |
5690
|
751202
|
|
|
|
|
PL_last_lop_op = (OPCODE)ftst; |
5691
|
|
|
|
|
|
DEBUG_T( { PerlIO_printf(Perl_debug_log, |
5692
|
|
|
|
|
|
"### Saw file test %c\n", (int)tmp); |
5693
|
|
|
|
|
|
} ); |
5694
|
751202
|
|
|
|
|
FTST(ftst); |
5695
|
|
|
|
|
|
} |
5696
|
|
|
|
|
|
else { |
5697
|
|
|
|
|
|
/* Assume it was a minus followed by a one-letter named |
5698
|
|
|
|
|
|
* subroutine call (or a -bareword), then. */ |
5699
|
|
|
|
|
|
DEBUG_T( { PerlIO_printf(Perl_debug_log, |
5700
|
|
|
|
|
|
"### '-%c' looked like a file test but was not\n", |
5701
|
|
|
|
|
|
(int) tmp); |
5702
|
|
|
|
|
|
} ); |
5703
|
4
|
|
|
|
|
s = --PL_bufptr; |
5704
|
|
|
|
|
|
} |
5705
|
|
|
|
|
|
} |
5706
|
|
|
|
|
|
{ |
5707
|
23536922
|
|
|
|
|
const char tmp = *s++; |
5708
|
23536922
|
100
|
|
|
|
if (*s == tmp) { |
5709
|
330884
|
|
|
|
|
s++; |
5710
|
330884
|
100
|
|
|
|
if (PL_expect == XOPERATOR) |
5711
|
211848
|
|
|
|
|
TERM(POSTDEC); |
5712
|
|
|
|
|
|
else |
5713
|
119036
|
|
|
|
|
OPERATOR(PREDEC); |
5714
|
|
|
|
|
|
} |
5715
|
23206038
|
100
|
|
|
|
else if (*s == '>') { |
5716
|
22223575
|
|
|
|
|
s++; |
5717
|
22223575
|
|
|
|
|
s = SKIPSPACE1(s); |
5718
|
22223575
|
100
|
|
|
|
if (isIDFIRST_lazy_if(s,UTF)) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
5719
|
12627485
|
|
|
|
|
s = force_word(s,METHOD,FALSE,TRUE); |
5720
|
12627485
|
|
|
|
|
TOKEN(ARROW); |
5721
|
|
|
|
|
|
} |
5722
|
9596090
|
100
|
|
|
|
else if (*s == '$') |
5723
|
75294
|
|
|
|
|
OPERATOR(ARROW); |
5724
|
|
|
|
|
|
else |
5725
|
9520796
|
|
|
|
|
TERM(ARROW); |
5726
|
|
|
|
|
|
} |
5727
|
982463
|
100
|
|
|
|
if (PL_expect == XOPERATOR) { |
5728
|
468446
|
100
|
|
|
|
if (*s == '=' && !PL_lex_allbrackets && |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
5729
|
142
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) { |
5730
|
|
|
|
|
|
s--; |
5731
|
0
|
|
|
|
|
TOKEN(0); |
5732
|
|
|
|
|
|
} |
5733
|
468375
|
|
|
|
|
Aop(OP_SUBTRACT); |
5734
|
|
|
|
|
|
} |
5735
|
|
|
|
|
|
else { |
5736
|
514088
|
100
|
|
|
|
if (isSPACE(*s) || !isSPACE(*PL_bufptr)) |
|
|
100
|
|
|
|
|
5737
|
282930
|
|
|
|
|
check_uni(); |
5738
|
514088
|
|
|
|
|
OPERATOR('-'); /* unary minus */ |
5739
|
|
|
|
|
|
} |
5740
|
|
|
|
|
|
} |
5741
|
|
|
|
|
|
|
5742
|
|
|
|
|
|
case '+': |
5743
|
|
|
|
|
|
{ |
5744
|
1638650
|
|
|
|
|
const char tmp = *s++; |
5745
|
1638650
|
100
|
|
|
|
if (*s == tmp) { |
5746
|
794104
|
|
|
|
|
s++; |
5747
|
794104
|
100
|
|
|
|
if (PL_expect == XOPERATOR) |
5748
|
646928
|
|
|
|
|
TERM(POSTINC); |
5749
|
|
|
|
|
|
else |
5750
|
147176
|
|
|
|
|
OPERATOR(PREINC); |
5751
|
|
|
|
|
|
} |
5752
|
844546
|
100
|
|
|
|
if (PL_expect == XOPERATOR) { |
5753
|
777394
|
100
|
|
|
|
if (*s == '=' && !PL_lex_allbrackets && |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
5754
|
332
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) { |
5755
|
|
|
|
|
|
s--; |
5756
|
0
|
|
|
|
|
TOKEN(0); |
5757
|
|
|
|
|
|
} |
5758
|
777228
|
|
|
|
|
Aop(OP_ADD); |
5759
|
|
|
|
|
|
} |
5760
|
|
|
|
|
|
else { |
5761
|
67318
|
100
|
|
|
|
if (isSPACE(*s) || !isSPACE(*PL_bufptr)) |
|
|
100
|
|
|
|
|
5762
|
21708
|
|
|
|
|
check_uni(); |
5763
|
67318
|
|
|
|
|
OPERATOR('+'); |
5764
|
|
|
|
|
|
} |
5765
|
|
|
|
|
|
} |
5766
|
|
|
|
|
|
|
5767
|
|
|
|
|
|
case '*': |
5768
|
1747060
|
100
|
|
|
|
if (PL_expect != XOPERATOR) { |
5769
|
1590884
|
|
|
|
|
s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE); |
5770
|
1590882
|
|
|
|
|
PL_expect = XOPERATOR; |
5771
|
1590882
|
|
|
|
|
force_ident(PL_tokenbuf, '*'); |
5772
|
1590882
|
100
|
|
|
|
if (!*PL_tokenbuf) |
5773
|
721452
|
|
|
|
|
PREREF('*'); |
5774
|
869430
|
|
|
|
|
TERM('*'); |
5775
|
|
|
|
|
|
} |
5776
|
156176
|
|
|
|
|
s++; |
5777
|
156176
|
100
|
|
|
|
if (*s == '*') { |
5778
|
51716
|
|
|
|
|
s++; |
5779
|
51726
|
100
|
|
|
|
if (*s == '=' && !PL_lex_allbrackets && |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
5780
|
20
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) { |
5781
|
|
|
|
|
|
s -= 2; |
5782
|
0
|
|
|
|
|
TOKEN(0); |
5783
|
|
|
|
|
|
} |
5784
|
51716
|
|
|
|
|
PWop(OP_POW); |
5785
|
|
|
|
|
|
} |
5786
|
104500
|
100
|
|
|
|
if (*s == '=' && !PL_lex_allbrackets && |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
5787
|
80
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) { |
5788
|
|
|
|
|
|
s--; |
5789
|
0
|
|
|
|
|
TOKEN(0); |
5790
|
|
|
|
|
|
} |
5791
|
104460
|
|
|
|
|
PL_parser->saw_infix_sigil = 1; |
5792
|
104460
|
|
|
|
|
Mop(OP_MULTIPLY); |
5793
|
|
|
|
|
|
|
5794
|
|
|
|
|
|
case '%': |
5795
|
2408954
|
100
|
|
|
|
if (PL_expect == XOPERATOR) { |
5796
|
38535
|
100
|
|
|
|
if (s[1] == '=' && !PL_lex_allbrackets && |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
5797
|
50
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) |
5798
|
0
|
|
|
|
|
TOKEN(0); |
5799
|
38510
|
|
|
|
|
++s; |
5800
|
38510
|
|
|
|
|
PL_parser->saw_infix_sigil = 1; |
5801
|
38510
|
|
|
|
|
Mop(OP_MODULO); |
5802
|
|
|
|
|
|
} |
5803
|
2370444
|
|
|
|
|
PL_tokenbuf[0] = '%'; |
5804
|
2370444
|
|
|
|
|
s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, |
5805
|
|
|
|
|
|
sizeof PL_tokenbuf - 1, FALSE); |
5806
|
2370442
|
100
|
|
|
|
if (!PL_tokenbuf[1]) { |
5807
|
696098
|
|
|
|
|
PREREF('%'); |
5808
|
|
|
|
|
|
} |
5809
|
1674344
|
|
|
|
|
PL_expect = XOPERATOR; |
5810
|
1674344
|
|
|
|
|
force_ident_maybe_lex('%'); |
5811
|
1674344
|
|
|
|
|
TERM('%'); |
5812
|
|
|
|
|
|
|
5813
|
|
|
|
|
|
case '^': |
5814
|
7736
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= |
|
|
50
|
|
|
|
|
5815
|
450
|
100
|
|
|
|
(s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) |
5816
|
0
|
|
|
|
|
TOKEN(0); |
5817
|
7286
|
|
|
|
|
s++; |
5818
|
7286
|
|
|
|
|
BOop(OP_BIT_XOR); |
5819
|
|
|
|
|
|
case '[': |
5820
|
7417146
|
50
|
|
|
|
if (PL_lex_brackets > 100) |
5821
|
0
|
|
|
|
|
Renew(PL_lex_brackstack, PL_lex_brackets + 10, char); |
5822
|
7417146
|
|
|
|
|
PL_lex_brackstack[PL_lex_brackets++] = 0; |
5823
|
7417146
|
|
|
|
|
PL_lex_allbrackets++; |
5824
|
|
|
|
|
|
{ |
5825
|
7417146
|
|
|
|
|
const char tmp = *s++; |
5826
|
7417146
|
|
|
|
|
OPERATOR(tmp); |
5827
|
|
|
|
|
|
} |
5828
|
|
|
|
|
|
case '~': |
5829
|
188588
|
100
|
|
|
|
if (s[1] == '~' |
5830
|
740
|
100
|
|
|
|
&& (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)) |
5831
|
|
|
|
|
|
{ |
5832
|
724
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) |
|
|
50
|
|
|
|
|
5833
|
0
|
|
|
|
|
TOKEN(0); |
5834
|
724
|
|
|
|
|
s += 2; |
5835
|
724
|
|
|
|
|
Perl_ck_warner_d(aTHX_ |
5836
|
|
|
|
|
|
packWARN(WARN_EXPERIMENTAL__SMARTMATCH), |
5837
|
|
|
|
|
|
"Smartmatch is experimental"); |
5838
|
724
|
|
|
|
|
Eop(OP_SMARTMATCH); |
5839
|
|
|
|
|
|
} |
5840
|
187864
|
|
|
|
|
s++; |
5841
|
187864
|
|
|
|
|
OPERATOR('~'); |
5842
|
|
|
|
|
|
case ',': |
5843
|
39933773
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) |
|
|
100
|
|
|
|
|
5844
|
48
|
|
|
|
|
TOKEN(0); |
5845
|
39933725
|
|
|
|
|
s++; |
5846
|
39933725
|
|
|
|
|
OPERATOR(','); |
5847
|
|
|
|
|
|
case ':': |
5848
|
3006161
|
100
|
|
|
|
if (s[1] == ':') { |
5849
|
832
|
|
|
|
|
len = 0; |
5850
|
832
|
|
|
|
|
goto just_a_word_zero_gv; |
5851
|
|
|
|
|
|
} |
5852
|
3005329
|
|
|
|
|
s++; |
5853
|
3005329
|
|
|
|
|
switch (PL_expect) { |
5854
|
|
|
|
|
|
OP *attrs; |
5855
|
|
|
|
|
|
#ifdef PERL_MAD |
5856
|
|
|
|
|
|
I32 stuffstart; |
5857
|
|
|
|
|
|
#endif |
5858
|
|
|
|
|
|
case XOPERATOR: |
5859
|
2939012
|
100
|
|
|
|
if (!PL_in_my || PL_lex_state != LEX_NORMAL) |
|
|
50
|
|
|
|
|
5860
|
|
|
|
|
|
break; |
5861
|
108
|
|
|
|
|
PL_bufptr = s; /* update in case we back off */ |
5862
|
108
|
50
|
|
|
|
if (*s == '=') { |
5863
|
0
|
|
|
|
|
Perl_croak(aTHX_ |
5864
|
|
|
|
|
|
"Use of := for an empty attribute list is not allowed"); |
5865
|
|
|
|
|
|
} |
5866
|
|
|
|
|
|
goto grabattrs; |
5867
|
|
|
|
|
|
case XATTRBLOCK: |
5868
|
5856
|
|
|
|
|
PL_expect = XBLOCK; |
5869
|
5856
|
|
|
|
|
goto grabattrs; |
5870
|
|
|
|
|
|
case XATTRTERM: |
5871
|
64
|
|
|
|
|
PL_expect = XTERMBLOCK; |
5872
|
|
|
|
|
|
grabattrs: |
5873
|
|
|
|
|
|
#ifdef PERL_MAD |
5874
|
|
|
|
|
|
stuffstart = s - SvPVX(PL_linestr) - 1; |
5875
|
|
|
|
|
|
#endif |
5876
|
6028
|
|
|
|
|
s = PEEKSPACE(s); |
5877
|
|
|
|
|
|
attrs = NULL; |
5878
|
14772
|
100
|
|
|
|
while (isIDFIRST_lazy_if(s,UTF)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
5879
|
|
|
|
|
|
I32 tmp; |
5880
|
|
|
|
|
|
SV *sv; |
5881
|
6034
|
|
|
|
|
d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); |
5882
|
6034
|
100
|
|
|
|
if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) { |
|
|
50
|
|
|
|
|
5883
|
0
|
0
|
|
|
|
if (tmp < 0) tmp = -tmp; |
5884
|
0
|
0
|
|
|
|
switch (tmp) { |
5885
|
|
|
|
|
|
case KEY_or: |
5886
|
|
|
|
|
|
case KEY_and: |
5887
|
|
|
|
|
|
case KEY_for: |
5888
|
|
|
|
|
|
case KEY_foreach: |
5889
|
|
|
|
|
|
case KEY_unless: |
5890
|
|
|
|
|
|
case KEY_if: |
5891
|
|
|
|
|
|
case KEY_while: |
5892
|
|
|
|
|
|
case KEY_until: |
5893
|
|
|
|
|
|
goto got_attrs; |
5894
|
|
|
|
|
|
default: |
5895
|
|
|
|
|
|
break; |
5896
|
|
|
|
|
|
} |
5897
|
|
|
|
|
|
} |
5898
|
6034
|
50
|
|
|
|
sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
5899
|
6034
|
100
|
|
|
|
if (*d == '(') { |
5900
|
146
|
|
|
|
|
d = scan_str(d,TRUE,TRUE,FALSE, FALSE); |
5901
|
146
|
100
|
|
|
|
COPLINE_SET_FROM_MULTI_END; |
5902
|
146
|
50
|
|
|
|
if (!d) { |
5903
|
|
|
|
|
|
/* MUST advance bufptr here to avoid bogus |
5904
|
|
|
|
|
|
"at end of line" context messages from yyerror(). |
5905
|
|
|
|
|
|
*/ |
5906
|
0
|
|
|
|
|
PL_bufptr = s + len; |
5907
|
0
|
|
|
|
|
yyerror("Unterminated attribute parameter in attribute list"); |
5908
|
0
|
0
|
|
|
|
if (attrs) |
5909
|
0
|
|
|
|
|
op_free(attrs); |
5910
|
0
|
|
|
|
|
sv_free(sv); |
5911
|
0
|
|
|
|
|
return REPORT(0); /* EOF indicator */ |
5912
|
|
|
|
|
|
} |
5913
|
|
|
|
|
|
} |
5914
|
6034
|
100
|
|
|
|
if (PL_lex_stuff) { |
5915
|
146
|
|
|
|
|
sv_catsv(sv, PL_lex_stuff); |
5916
|
146
|
|
|
|
|
attrs = op_append_elem(OP_LIST, attrs, |
5917
|
|
|
|
|
|
newSVOP(OP_CONST, 0, sv)); |
5918
|
146
|
|
|
|
|
SvREFCNT_dec(PL_lex_stuff); |
5919
|
146
|
|
|
|
|
PL_lex_stuff = NULL; |
5920
|
|
|
|
|
|
} |
5921
|
|
|
|
|
|
else { |
5922
|
5888
|
100
|
|
|
|
if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
5923
|
4
|
|
|
|
|
sv_free(sv); |
5924
|
8
|
50
|
|
|
|
if (PL_in_my == KEY_our) { |
5925
|
4
|
|
|
|
|
deprecate(":unique"); |
5926
|
|
|
|
|
|
} |
5927
|
|
|
|
|
|
else |
5928
|
0
|
|
|
|
|
Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables"); |
5929
|
|
|
|
|
|
} |
5930
|
|
|
|
|
|
|
5931
|
|
|
|
|
|
/* NOTE: any CV attrs applied here need to be part of |
5932
|
|
|
|
|
|
the CVf_BUILTIN_ATTRS define in cv.h! */ |
5933
|
5884
|
100
|
|
|
|
else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
5934
|
5794
|
|
|
|
|
sv_free(sv); |
5935
|
5794
|
|
|
|
|
CvLVALUE_on(PL_compcv); |
5936
|
|
|
|
|
|
} |
5937
|
90
|
100
|
|
|
|
else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
5938
|
12
|
|
|
|
|
sv_free(sv); |
5939
|
12
|
|
|
|
|
deprecate(":locked"); |
5940
|
|
|
|
|
|
} |
5941
|
78
|
100
|
|
|
|
else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
5942
|
6
|
|
|
|
|
sv_free(sv); |
5943
|
6
|
|
|
|
|
CvMETHOD_on(PL_compcv); |
5944
|
|
|
|
|
|
} |
5945
|
|
|
|
|
|
/* After we've set the flags, it could be argued that |
5946
|
|
|
|
|
|
we don't need to do the attributes.pm-based setting |
5947
|
|
|
|
|
|
process, and shouldn't bother appending recognized |
5948
|
|
|
|
|
|
flags. To experiment with that, uncomment the |
5949
|
|
|
|
|
|
following "else". (Note that's already been |
5950
|
|
|
|
|
|
uncommented. That keeps the above-applied built-in |
5951
|
|
|
|
|
|
attributes from being intercepted (and possibly |
5952
|
|
|
|
|
|
rejected) by a package's attribute routines, but is |
5953
|
|
|
|
|
|
justified by the performance win for the common case |
5954
|
|
|
|
|
|
of applying only built-in attributes.) */ |
5955
|
|
|
|
|
|
else |
5956
|
72
|
|
|
|
|
attrs = op_append_elem(OP_LIST, attrs, |
5957
|
|
|
|
|
|
newSVOP(OP_CONST, 0, |
5958
|
|
|
|
|
|
sv)); |
5959
|
|
|
|
|
|
} |
5960
|
6034
|
|
|
|
|
s = PEEKSPACE(d); |
5961
|
6034
|
100
|
|
|
|
if (*s == ':' && s[1] != ':') |
|
|
50
|
|
|
|
|
5962
|
6
|
|
|
|
|
s = PEEKSPACE(s+1); |
5963
|
6031
|
100
|
|
|
|
else if (s == d) |
5964
|
|
|
|
|
|
break; /* require real whitespace or :'s */ |
5965
|
|
|
|
|
|
/* XXX losing whitespace on sequential attributes here */ |
5966
|
|
|
|
|
|
} |
5967
|
|
|
|
|
|
{ |
5968
|
6028
|
100
|
|
|
|
const char tmp |
5969
|
6028
|
|
|
|
|
= (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */ |
5970
|
6028
|
100
|
|
|
|
if (*s != ';' && *s != '}' && *s != tmp |
|
|
50
|
|
|
|
|
5971
|
0
|
0
|
|
|
|
&& (tmp != '=' || *s != ')')) { |
|
|
0
|
|
|
|
|
5972
|
0
|
0
|
|
|
|
const char q = ((*s == '\'') ? '"' : '\''); |
5973
|
|
|
|
|
|
/* If here for an expression, and parsed no attrs, back |
5974
|
|
|
|
|
|
off. */ |
5975
|
0
|
0
|
|
|
|
if (tmp == '=' && !attrs) { |
5976
|
0
|
|
|
|
|
s = PL_bufptr; |
5977
|
0
|
|
|
|
|
break; |
5978
|
|
|
|
|
|
} |
5979
|
|
|
|
|
|
/* MUST advance bufptr here to avoid bogus "at end of line" |
5980
|
|
|
|
|
|
context messages from yyerror(). |
5981
|
|
|
|
|
|
*/ |
5982
|
0
|
|
|
|
|
PL_bufptr = s; |
5983
|
0
|
0
|
|
|
|
yyerror( (const char *) |
5984
|
|
|
|
|
|
(*s |
5985
|
|
|
|
|
|
? Perl_form(aTHX_ "Invalid separator character " |
5986
|
|
|
|
|
|
"%c%c%c in attribute list", q, *s, q) |
5987
|
|
|
|
|
|
: "Unterminated attribute list" ) ); |
5988
|
0
|
0
|
|
|
|
if (attrs) |
5989
|
0
|
|
|
|
|
op_free(attrs); |
5990
|
0
|
|
|
|
|
OPERATOR(':'); |
5991
|
|
|
|
|
|
} |
5992
|
|
|
|
|
|
} |
5993
|
|
|
|
|
|
got_attrs: |
5994
|
6028
|
100
|
|
|
|
if (attrs) { |
5995
|
|
|
|
|
|
start_force(PL_curforce); |
5996
|
216
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval = attrs; |
5997
|
|
|
|
|
|
CURMAD('_', PL_nextwhite); |
5998
|
216
|
|
|
|
|
force_next(THING); |
5999
|
|
|
|
|
|
} |
6000
|
|
|
|
|
|
#ifdef PERL_MAD |
6001
|
|
|
|
|
|
if (PL_madskills) { |
6002
|
|
|
|
|
|
PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart, |
6003
|
|
|
|
|
|
(s - SvPVX(PL_linestr)) - stuffstart); |
6004
|
|
|
|
|
|
} |
6005
|
|
|
|
|
|
#endif |
6006
|
6028
|
|
|
|
|
TOKEN(COLONATTR); |
6007
|
|
|
|
|
|
} |
6008
|
2999301
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) { |
|
|
100
|
|
|
|
|
6009
|
8
|
|
|
|
|
s--; |
6010
|
8
|
|
|
|
|
TOKEN(0); |
6011
|
|
|
|
|
|
} |
6012
|
2999293
|
|
|
|
|
PL_lex_allbrackets--; |
6013
|
2999293
|
|
|
|
|
OPERATOR(':'); |
6014
|
|
|
|
|
|
case '(': |
6015
|
44303010
|
|
|
|
|
s++; |
6016
|
44303010
|
100
|
|
|
|
if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr) |
|
|
100
|
|
|
|
|
6017
|
6203999
|
|
|
|
|
PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */ |
6018
|
|
|
|
|
|
else |
6019
|
38099011
|
|
|
|
|
PL_expect = XTERM; |
6020
|
44303010
|
|
|
|
|
s = SKIPSPACE1(s); |
6021
|
44303010
|
|
|
|
|
PL_lex_allbrackets++; |
6022
|
44303010
|
|
|
|
|
TOKEN('('); |
6023
|
|
|
|
|
|
case ';': |
6024
|
68586414
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR) |
|
|
100
|
|
|
|
|
6025
|
142
|
|
|
|
|
TOKEN(0); |
6026
|
68586272
|
|
|
|
|
CLINE; |
6027
|
68586272
|
|
|
|
|
s++; |
6028
|
68586272
|
|
|
|
|
OPERATOR(';'); |
6029
|
|
|
|
|
|
case ')': |
6030
|
44301832
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) |
|
|
100
|
|
|
|
|
6031
|
6
|
|
|
|
|
TOKEN(0); |
6032
|
44301826
|
|
|
|
|
s++; |
6033
|
44301826
|
|
|
|
|
PL_lex_allbrackets--; |
6034
|
44301826
|
|
|
|
|
s = SKIPSPACE1(s); |
6035
|
44301826
|
100
|
|
|
|
if (*s == '{') |
6036
|
11885131
|
|
|
|
|
PREBLOCK(')'); |
6037
|
32416695
|
|
|
|
|
TERM(')'); |
6038
|
|
|
|
|
|
case ']': |
6039
|
7417142
|
50
|
|
|
|
if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF) |
|
|
100
|
|
|
|
|
6040
|
2
|
|
|
|
|
TOKEN(0); |
6041
|
7417140
|
|
|
|
|
s++; |
6042
|
7417140
|
50
|
|
|
|
if (PL_lex_brackets <= 0) |
6043
|
0
|
|
|
|
|
yyerror("Unmatched right square bracket"); |
6044
|
|
|
|
|
|
else |
6045
|
7417140
|
|
|
|
|
--PL_lex_brackets; |
6046
|
7417140
|
|
|
|
|
PL_lex_allbrackets--; |
6047
|
7417140
|
100
|
|
|
|
if (PL_lex_state == LEX_INTERPNORMAL) { |
6048
|
280477
|
100
|
|
|
|
if (PL_lex_brackets == 0) { |
6049
|
266279
|
100
|
|
|
|
if (*s == '-' && s[1] == '>') |
|
|
100
|
|
|
|
|
6050
|
68
|
|
|
|
|
PL_lex_state = LEX_INTERPENDMAYBE; |
6051
|
266211
|
100
|
|
|
|
else if (*s != '[' && *s != '{') |
6052
|
225515
|
|
|
|
|
PL_lex_state = LEX_INTERPEND; |
6053
|
|
|
|
|
|
} |
6054
|
|
|
|
|
|
} |
6055
|
7417140
|
|
|
|
|
TERM(']'); |
6056
|
|
|
|
|
|
case '{': |
6057
|
44297193
|
|
|
|
|
s++; |
6058
|
|
|
|
|
|
leftbracket: |
6059
|
44297483
|
100
|
|
|
|
if (PL_lex_brackets > 100) { |
6060
|
100
|
|
|
|
|
Renew(PL_lex_brackstack, PL_lex_brackets + 10, char); |
6061
|
|
|
|
|
|
} |
6062
|
44297483
|
|
|
|
|
switch (PL_expect) { |
6063
|
|
|
|
|
|
case XTERM: |
6064
|
947271
|
|
|
|
|
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; |
6065
|
947271
|
|
|
|
|
PL_lex_allbrackets++; |
6066
|
947271
|
|
|
|
|
OPERATOR(HASHBRACK); |
6067
|
|
|
|
|
|
case XOPERATOR: |
6068
|
15415541
|
50
|
|
|
|
while (s < PL_bufend && SPACE_OR_TAB(*s)) |
|
|
100
|
|
|
|
|
6069
|
198570
|
|
|
|
|
s++; |
6070
|
|
|
|
|
|
d = s; |
6071
|
15216971
|
|
|
|
|
PL_tokenbuf[0] = '\0'; |
6072
|
15216971
|
50
|
|
|
|
if (d < PL_bufend && *d == '-') { |
|
|
100
|
|
|
|
|
6073
|
30328
|
|
|
|
|
PL_tokenbuf[0] = '-'; |
6074
|
30328
|
|
|
|
|
d++; |
6075
|
40812
|
50
|
|
|
|
while (d < PL_bufend && SPACE_OR_TAB(*d)) |
|
|
50
|
|
|
|
|
6076
|
0
|
|
|
|
|
d++; |
6077
|
|
|
|
|
|
} |
6078
|
15216971
|
50
|
|
|
|
if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
6079
|
8894595
|
|
|
|
|
d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, |
6080
|
|
|
|
|
|
FALSE, &len); |
6081
|
13409946
|
50
|
|
|
|
while (d < PL_bufend && SPACE_OR_TAB(*d)) |
|
|
100
|
|
|
|
|
6082
|
210242
|
|
|
|
|
d++; |
6083
|
8894595
|
100
|
|
|
|
if (*d == '}') { |
6084
|
8625674
|
|
|
|
|
const char minus = (PL_tokenbuf[0] == '-'); |
6085
|
8625674
|
|
|
|
|
s = force_word(s + minus, WORD, FALSE, TRUE); |
6086
|
8625674
|
100
|
|
|
|
if (minus) |
6087
|
15232
|
|
|
|
|
force_next('-'); |
6088
|
|
|
|
|
|
} |
6089
|
|
|
|
|
|
} |
6090
|
|
|
|
|
|
/* FALL THROUGH */ |
6091
|
|
|
|
|
|
case XATTRBLOCK: |
6092
|
|
|
|
|
|
case XBLOCK: |
6093
|
38609797
|
|
|
|
|
PL_lex_brackstack[PL_lex_brackets++] = XSTATE; |
6094
|
38609797
|
|
|
|
|
PL_lex_allbrackets++; |
6095
|
38609797
|
|
|
|
|
PL_expect = XSTATE; |
6096
|
38609797
|
|
|
|
|
break; |
6097
|
|
|
|
|
|
case XATTRTERM: |
6098
|
|
|
|
|
|
case XTERMBLOCK: |
6099
|
1557423
|
|
|
|
|
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; |
6100
|
1557423
|
|
|
|
|
PL_lex_allbrackets++; |
6101
|
1557423
|
|
|
|
|
PL_expect = XSTATE; |
6102
|
1557423
|
|
|
|
|
break; |
6103
|
|
|
|
|
|
default: { |
6104
|
|
|
|
|
|
const char *t; |
6105
|
3182992
|
100
|
|
|
|
if (PL_oldoldbufptr == PL_last_lop) |
6106
|
545633
|
|
|
|
|
PL_lex_brackstack[PL_lex_brackets++] = XTERM; |
6107
|
|
|
|
|
|
else |
6108
|
2637359
|
|
|
|
|
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; |
6109
|
3182992
|
|
|
|
|
PL_lex_allbrackets++; |
6110
|
3182992
|
|
|
|
|
s = SKIPSPACE1(s); |
6111
|
3182992
|
100
|
|
|
|
if (*s == '}') { |
6112
|
984
|
100
|
|
|
|
if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) { |
|
|
100
|
|
|
|
|
6113
|
2
|
|
|
|
|
PL_expect = XTERM; |
6114
|
|
|
|
|
|
/* This hack is to get the ${} in the message. */ |
6115
|
2
|
|
|
|
|
PL_bufptr = s+1; |
6116
|
2
|
|
|
|
|
yyerror("syntax error"); |
6117
|
2
|
|
|
|
|
break; |
6118
|
|
|
|
|
|
} |
6119
|
982
|
|
|
|
|
OPERATOR(HASHBRACK); |
6120
|
|
|
|
|
|
} |
6121
|
|
|
|
|
|
/* This hack serves to disambiguate a pair of curlies |
6122
|
|
|
|
|
|
* as being a block or an anon hash. Normally, expectation |
6123
|
|
|
|
|
|
* determines that, but in cases where we're not in a |
6124
|
|
|
|
|
|
* position to expect anything in particular (like inside |
6125
|
|
|
|
|
|
* eval"") we have to resolve the ambiguity. This code |
6126
|
|
|
|
|
|
* covers the case where the first term in the curlies is a |
6127
|
|
|
|
|
|
* quoted string. Most other cases need to be explicitly |
6128
|
|
|
|
|
|
* disambiguated by prepending a "+" before the opening |
6129
|
|
|
|
|
|
* curly in order to force resolution as an anon hash. |
6130
|
|
|
|
|
|
* |
6131
|
|
|
|
|
|
* XXX should probably propagate the outer expectation |
6132
|
|
|
|
|
|
* into eval"" to rely less on this hack, but that could |
6133
|
|
|
|
|
|
* potentially break current behavior of eval"". |
6134
|
|
|
|
|
|
* GSAR 97-07-21 |
6135
|
|
|
|
|
|
*/ |
6136
|
|
|
|
|
|
t = s; |
6137
|
3182008
|
100
|
|
|
|
if (*s == '\'' || *s == '"' || *s == '`') { |
|
|
100
|
|
|
|
|
6138
|
|
|
|
|
|
/* common case: get past first string, handling escapes */ |
6139
|
8083916
|
50
|
|
|
|
for (t++; t < PL_bufend && *t != *s;) |
|
|
100
|
|
|
|
|
6140
|
7292361
|
100
|
|
|
|
if (*t++ == '\\' && (*t == '\\' || *t == *s)) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
6141
|
3768251
|
|
|
|
|
t++; |
6142
|
533223
|
|
|
|
|
t++; |
6143
|
|
|
|
|
|
} |
6144
|
2648785
|
100
|
|
|
|
else if (*s == 'q') { |
6145
|
11330
|
50
|
|
|
|
if (++t < PL_bufend |
6146
|
11330
|
100
|
|
|
|
&& (!isWORDCHAR(*t) |
6147
|
11314
|
100
|
|
|
|
|| ((*t == 'q' || *t == 'x') && ++t < PL_bufend |
|
|
50
|
|
|
|
|
6148
|
7102
|
50
|
|
|
|
&& !isWORDCHAR(*t)))) |
6149
|
1652151
|
|
|
|
|
{ |
6150
|
|
|
|
|
|
/* skip q//-like construct */ |
6151
|
|
|
|
|
|
const char *tmps; |
6152
|
|
|
|
|
|
char open, close, term; |
6153
|
|
|
|
|
|
I32 brackets = 1; |
6154
|
|
|
|
|
|
|
6155
|
7120
|
50
|
|
|
|
while (t < PL_bufend && isSPACE(*t)) |
|
|
100
|
|
|
|
|
6156
|
10
|
|
|
|
|
t++; |
6157
|
|
|
|
|
|
/* check for q => */ |
6158
|
7110
|
50
|
|
|
|
if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
6159
|
4
|
|
|
|
|
OPERATOR(HASHBRACK); |
6160
|
|
|
|
|
|
} |
6161
|
7106
|
|
|
|
|
term = *t; |
6162
|
|
|
|
|
|
open = term; |
6163
|
7106
|
50
|
|
|
|
if (term && (tmps = strchr("([{< )]}> )]}>",term))) |
|
|
100
|
|
|
|
|
6164
|
7072
|
|
|
|
|
term = tmps[5]; |
6165
|
|
|
|
|
|
close = term; |
6166
|
7106
|
100
|
|
|
|
if (open == close) |
6167
|
500
|
50
|
|
|
|
for (t++; t < PL_bufend; t++) { |
6168
|
500
|
50
|
|
|
|
if (*t == '\\' && t+1 < PL_bufend && open != '\\') |
|
|
0
|
|
|
|
|
6169
|
0
|
|
|
|
|
t++; |
6170
|
500
|
100
|
|
|
|
else if (*t == open) |
6171
|
|
|
|
|
|
break; |
6172
|
|
|
|
|
|
} |
6173
|
|
|
|
|
|
else { |
6174
|
50082
|
50
|
|
|
|
for (t++; t < PL_bufend; t++) { |
6175
|
50082
|
50
|
|
|
|
if (*t == '\\' && t+1 < PL_bufend) |
|
|
0
|
|
|
|
|
6176
|
0
|
|
|
|
|
t++; |
6177
|
50082
|
100
|
|
|
|
else if (*t == close && --brackets <= 0) |
|
|
100
|
|
|
|
|
6178
|
|
|
|
|
|
break; |
6179
|
43010
|
100
|
|
|
|
else if (*t == open) |
6180
|
2
|
|
|
|
|
brackets++; |
6181
|
|
|
|
|
|
} |
6182
|
|
|
|
|
|
} |
6183
|
7106
|
|
|
|
|
t++; |
6184
|
|
|
|
|
|
} |
6185
|
|
|
|
|
|
else |
6186
|
|
|
|
|
|
/* skip plain q word */ |
6187
|
30812
|
50
|
|
|
|
while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
6188
|
26592
|
|
|
|
|
t += UTF8SKIP(t); |
6189
|
|
|
|
|
|
} |
6190
|
2637455
|
100
|
|
|
|
else if (isWORDCHAR_lazy_if(t,UTF)) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
6191
|
516718
|
|
|
|
|
t += UTF8SKIP(t); |
6192
|
2655014
|
50
|
|
|
|
while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF)) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
6193
|
1886776
|
|
|
|
|
t += UTF8SKIP(t); |
6194
|
|
|
|
|
|
} |
6195
|
3596107
|
100
|
|
|
|
while (t < PL_bufend && isSPACE(*t)) |
|
|
100
|
|
|
|
|
6196
|
414103
|
|
|
|
|
t++; |
6197
|
|
|
|
|
|
/* if comma follows first term, call it an anon hash */ |
6198
|
|
|
|
|
|
/* XXX it could be a comma expression with loop modifiers */ |
6199
|
3182004
|
100
|
|
|
|
if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s))) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
6200
|
3181000
|
100
|
|
|
|
|| (*t == '=' && t[1] == '>'))) |
|
|
100
|
|
|
|
|
6201
|
11114
|
|
|
|
|
OPERATOR(HASHBRACK); |
6202
|
3170890
|
100
|
|
|
|
if (PL_expect == XREF) |
6203
|
2834128
|
|
|
|
|
PL_expect = XTERM; |
6204
|
|
|
|
|
|
else { |
6205
|
336762
|
|
|
|
|
PL_lex_brackstack[PL_lex_brackets-1] = XSTATE; |
6206
|
336762
|
|
|
|
|
PL_expect = XSTATE; |
6207
|
|
|
|
|
|
} |
6208
|
|
|
|
|
|
} |
6209
|
|
|
|
|
|
break; |
6210
|
|
|
|
|
|
} |
6211
|
43338112
|
|
|
|
|
pl_yylval.ival = CopLINE(PL_curcop); |
6212
|
43338112
|
100
|
|
|
|
if (isSPACE(*s) || *s == '#') |
|
|
100
|
|
|
|
|
6213
|
24677071
|
|
|
|
|
PL_copline = NOLINE; /* invalidate current command line number */ |
6214
|
43338112
|
100
|
|
|
|
TOKEN(formbrack ? '=' : '{'); |
6215
|
|
|
|
|
|
case '}': |
6216
|
44297161
|
100
|
|
|
|
if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF) |
|
|
100
|
|
|
|
|
6217
|
48
|
|
|
|
|
TOKEN(0); |
6218
|
|
|
|
|
|
rightbracket: |
6219
|
44297395
|
|
|
|
|
s++; |
6220
|
44297395
|
100
|
|
|
|
if (PL_lex_brackets <= 0) |
6221
|
12
|
|
|
|
|
yyerror("Unmatched right curly bracket"); |
6222
|
|
|
|
|
|
else |
6223
|
44297383
|
|
|
|
|
PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets]; |
6224
|
44297395
|
|
|
|
|
PL_lex_allbrackets--; |
6225
|
44297395
|
100
|
|
|
|
if (PL_lex_state == LEX_INTERPNORMAL) { |
6226
|
963037
|
100
|
|
|
|
if (PL_lex_brackets == 0) { |
6227
|
883309
|
100
|
|
|
|
if (PL_expect & XFAKEBRACK) { |
6228
|
2
|
|
|
|
|
PL_expect &= XENUMMASK; |
6229
|
2
|
|
|
|
|
PL_lex_state = LEX_INTERPEND; |
6230
|
2
|
|
|
|
|
PL_bufptr = s; |
6231
|
|
|
|
|
|
#if 0 |
6232
|
|
|
|
|
|
if (PL_madskills) { |
6233
|
|
|
|
|
|
if (!PL_thiswhite) |
6234
|
|
|
|
|
|
PL_thiswhite = newSVpvs(""); |
6235
|
|
|
|
|
|
sv_catpvs(PL_thiswhite,"}"); |
6236
|
|
|
|
|
|
} |
6237
|
|
|
|
|
|
#endif |
6238
|
2
|
|
|
|
|
return yylex(); /* ignore fake brackets */ |
6239
|
|
|
|
|
|
} |
6240
|
883307
|
100
|
|
|
|
if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr |
|
|
100
|
|
|
|
|
6241
|
175367
|
50
|
|
|
|
&& SvEVALED(PL_lex_repl)) |
6242
|
175367
|
|
|
|
|
PL_lex_state = LEX_INTERPEND; |
6243
|
707940
|
100
|
|
|
|
else if (*s == '-' && s[1] == '>') |
|
|
100
|
|
|
|
|
6244
|
504
|
|
|
|
|
PL_lex_state = LEX_INTERPENDMAYBE; |
6245
|
707436
|
100
|
|
|
|
else if (*s != '[' && *s != '{') |
6246
|
690748
|
|
|
|
|
PL_lex_state = LEX_INTERPEND; |
6247
|
|
|
|
|
|
} |
6248
|
|
|
|
|
|
} |
6249
|
44297393
|
100
|
|
|
|
if (PL_expect & XFAKEBRACK) { |
6250
|
12
|
|
|
|
|
PL_expect &= XENUMMASK; |
6251
|
12
|
|
|
|
|
PL_bufptr = s; |
6252
|
12
|
|
|
|
|
return yylex(); /* ignore fake brackets */ |
6253
|
|
|
|
|
|
} |
6254
|
|
|
|
|
|
start_force(PL_curforce); |
6255
|
|
|
|
|
|
if (PL_madskills) { |
6256
|
|
|
|
|
|
curmad('X', newSVpvn(s-1,1)); |
6257
|
|
|
|
|
|
CURMAD('_', PL_thiswhite); |
6258
|
|
|
|
|
|
} |
6259
|
44297381
|
100
|
|
|
|
force_next(formbrack ? '.' : '}'); |
6260
|
44297381
|
100
|
|
|
|
if (formbrack) LEAVE; |
6261
|
|
|
|
|
|
#ifdef PERL_MAD |
6262
|
|
|
|
|
|
if (PL_madskills && !PL_thistoken) |
6263
|
|
|
|
|
|
PL_thistoken = newSVpvs(""); |
6264
|
|
|
|
|
|
#endif |
6265
|
44297381
|
50
|
|
|
|
if (formbrack == 2) { /* means . where arguments were expected */ |
6266
|
|
|
|
|
|
start_force(PL_curforce); |
6267
|
0
|
|
|
|
|
force_next(';'); |
6268
|
0
|
|
|
|
|
TOKEN(FORMRBRACK); |
6269
|
|
|
|
|
|
} |
6270
|
44297381
|
|
|
|
|
TOKEN(';'); |
6271
|
|
|
|
|
|
case '&': |
6272
|
|
|
|
|
|
s++; |
6273
|
5862521
|
100
|
|
|
|
if (*s++ == '&') { |
6274
|
2544850
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= |
|
|
50
|
|
|
|
|
6275
|
28234
|
50
|
|
|
|
(*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) { |
6276
|
|
|
|
|
|
s -= 2; |
6277
|
0
|
|
|
|
|
TOKEN(0); |
6278
|
|
|
|
|
|
} |
6279
|
2516616
|
|
|
|
|
AOPERATOR(ANDAND); |
6280
|
|
|
|
|
|
} |
6281
|
3345905
|
|
|
|
|
s--; |
6282
|
3345905
|
100
|
|
|
|
if (PL_expect == XOPERATOR) { |
6283
|
1082861
|
100
|
|
|
|
if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON) |
|
|
100
|
|
|
|
|
6284
|
2
|
50
|
|
|
|
&& isIDFIRST_lazy_if(s,UTF)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
6285
|
|
|
|
|
|
{ |
6286
|
2
|
|
|
|
|
CopLINE_dec(PL_curcop); |
6287
|
2
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi); |
6288
|
2
|
|
|
|
|
CopLINE_inc(PL_curcop); |
6289
|
|
|
|
|
|
} |
6290
|
1088469
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= |
|
|
50
|
|
|
|
|
6291
|
5608
|
100
|
|
|
|
(*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) { |
6292
|
|
|
|
|
|
s--; |
6293
|
0
|
|
|
|
|
TOKEN(0); |
6294
|
|
|
|
|
|
} |
6295
|
1082861
|
|
|
|
|
PL_parser->saw_infix_sigil = 1; |
6296
|
1082861
|
|
|
|
|
BAop(OP_BIT_AND); |
6297
|
|
|
|
|
|
} |
6298
|
|
|
|
|
|
|
6299
|
2263044
|
|
|
|
|
PL_tokenbuf[0] = '&'; |
6300
|
2263044
|
|
|
|
|
s = scan_ident(s - 1, PL_bufend, PL_tokenbuf + 1, |
6301
|
|
|
|
|
|
sizeof PL_tokenbuf - 1, TRUE); |
6302
|
2263042
|
100
|
|
|
|
if (PL_tokenbuf[1]) { |
6303
|
1753210
|
|
|
|
|
PL_expect = XOPERATOR; |
6304
|
1753210
|
|
|
|
|
force_ident_maybe_lex('&'); |
6305
|
|
|
|
|
|
} |
6306
|
|
|
|
|
|
else |
6307
|
509832
|
|
|
|
|
PREREF('&'); |
6308
|
1753210
|
|
|
|
|
pl_yylval.ival = (OPpENTERSUB_AMPER<<8); |
6309
|
1753210
|
|
|
|
|
TERM('&'); |
6310
|
|
|
|
|
|
|
6311
|
|
|
|
|
|
case '|': |
6312
|
|
|
|
|
|
s++; |
6313
|
3027944
|
100
|
|
|
|
if (*s++ == '|') { |
6314
|
2429593
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= |
|
|
100
|
|
|
|
|
6315
|
55598
|
100
|
|
|
|
(*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) { |
6316
|
|
|
|
|
|
s -= 2; |
6317
|
8
|
|
|
|
|
TOKEN(0); |
6318
|
|
|
|
|
|
} |
6319
|
2373987
|
|
|
|
|
AOPERATOR(OROR); |
6320
|
|
|
|
|
|
} |
6321
|
653949
|
|
|
|
|
s--; |
6322
|
709223
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= |
|
|
50
|
|
|
|
|
6323
|
55274
|
100
|
|
|
|
(*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) { |
6324
|
|
|
|
|
|
s--; |
6325
|
0
|
|
|
|
|
TOKEN(0); |
6326
|
|
|
|
|
|
} |
6327
|
653949
|
|
|
|
|
BOop(OP_BIT_OR); |
6328
|
|
|
|
|
|
case '=': |
6329
|
|
|
|
|
|
s++; |
6330
|
|
|
|
|
|
{ |
6331
|
49147590
|
|
|
|
|
const char tmp = *s++; |
6332
|
49147590
|
100
|
|
|
|
if (tmp == '=') { |
6333
|
1028644
|
100
|
|
|
|
if (!PL_lex_allbrackets && |
|
|
50
|
|
|
|
|
6334
|
8026
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) { |
6335
|
|
|
|
|
|
s -= 2; |
6336
|
0
|
|
|
|
|
TOKEN(0); |
6337
|
|
|
|
|
|
} |
6338
|
1024631
|
|
|
|
|
Eop(OP_EQ); |
6339
|
|
|
|
|
|
} |
6340
|
48122959
|
100
|
|
|
|
if (tmp == '>') { |
6341
|
14221703
|
100
|
|
|
|
if (!PL_lex_allbrackets && |
|
|
100
|
|
|
|
|
6342
|
279902
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) { |
6343
|
|
|
|
|
|
s -= 2; |
6344
|
4
|
|
|
|
|
TOKEN(0); |
6345
|
|
|
|
|
|
} |
6346
|
14090568
|
|
|
|
|
OPERATOR(','); |
6347
|
|
|
|
|
|
} |
6348
|
34032387
|
100
|
|
|
|
if (tmp == '~') |
6349
|
3598441
|
|
|
|
|
PMop(OP_MATCH); |
6350
|
30433946
|
50
|
|
|
|
if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
6351
|
27158
|
100
|
|
|
|
&& strchr("+-*/%.^&|<",tmp)) |
6352
|
106
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), |
6353
|
|
|
|
|
|
"Reversed %c= operator",(int)tmp); |
6354
|
30433928
|
|
|
|
|
s--; |
6355
|
30870424
|
100
|
|
|
|
if (PL_expect == XSTATE && isALPHA(tmp) && |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
6356
|
436500
|
50
|
|
|
|
(s == PL_linestart+1 || s[-2] == '\n') ) |
6357
|
|
|
|
|
|
{ |
6358
|
884511
|
100
|
|
|
|
if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
6359
|
884509
|
100
|
|
|
|
|| PL_lex_state != LEX_NORMAL) { |
6360
|
4
|
|
|
|
|
d = PL_bufend; |
6361
|
22
|
50
|
|
|
|
while (s < d) { |
6362
|
20
|
100
|
|
|
|
if (*s++ == '\n') { |
6363
|
8
|
|
|
|
|
incline(s); |
6364
|
8
|
100
|
|
|
|
if (strnEQ(s,"=cut",4)) { |
6365
|
4
|
|
|
|
|
s = strchr(s,'\n'); |
6366
|
4
|
50
|
|
|
|
if (s) |
6367
|
4
|
|
|
|
|
s++; |
6368
|
|
|
|
|
|
else |
6369
|
|
|
|
|
|
s = d; |
6370
|
12
|
|
|
|
|
incline(s); |
6371
|
616692275
|
|
|
|
|
goto retry; |
6372
|
|
|
|
|
|
} |
6373
|
|
|
|
|
|
} |
6374
|
|
|
|
|
|
} |
6375
|
|
|
|
|
|
goto retry; |
6376
|
|
|
|
|
|
} |
6377
|
|
|
|
|
|
#ifdef PERL_MAD |
6378
|
|
|
|
|
|
if (PL_madskills) { |
6379
|
|
|
|
|
|
if (!PL_thiswhite) |
6380
|
|
|
|
|
|
PL_thiswhite = newSVpvs(""); |
6381
|
|
|
|
|
|
sv_catpvn(PL_thiswhite, PL_linestart, |
6382
|
|
|
|
|
|
PL_bufend - PL_linestart); |
6383
|
|
|
|
|
|
} |
6384
|
|
|
|
|
|
#endif |
6385
|
884507
|
|
|
|
|
s = PL_bufend; |
6386
|
884507
|
|
|
|
|
PL_parser->in_pod = 1; |
6387
|
884507
|
|
|
|
|
goto retry; |
6388
|
|
|
|
|
|
} |
6389
|
|
|
|
|
|
} |
6390
|
29549417
|
100
|
|
|
|
if (PL_expect == XBLOCK) { |
6391
|
|
|
|
|
|
const char *t = s; |
6392
|
|
|
|
|
|
#ifdef PERL_STRICT_CR |
6393
|
|
|
|
|
|
while (SPACE_OR_TAB(*t)) |
6394
|
|
|
|
|
|
#else |
6395
|
302
|
100
|
|
|
|
while (SPACE_OR_TAB(*t) || *t == '\r') |
|
|
50
|
|
|
|
|
6396
|
|
|
|
|
|
#endif |
6397
|
12
|
|
|
|
|
t++; |
6398
|
290
|
50
|
|
|
|
if (*t == '\n' || *t == '#') { |
6399
|
|
|
|
|
|
formbrack = 1; |
6400
|
290
|
|
|
|
|
ENTER; |
6401
|
290
|
|
|
|
|
SAVEI8(PL_parser->form_lex_state); |
6402
|
290
|
|
|
|
|
SAVEI32(PL_lex_formbrack); |
6403
|
290
|
|
|
|
|
PL_parser->form_lex_state = PL_lex_state; |
6404
|
290
|
|
|
|
|
PL_lex_formbrack = PL_lex_brackets + 1; |
6405
|
290
|
|
|
|
|
goto leftbracket; |
6406
|
|
|
|
|
|
} |
6407
|
|
|
|
|
|
} |
6408
|
29549127
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) { |
|
|
50
|
|
|
|
|
6409
|
|
|
|
|
|
s--; |
6410
|
0
|
|
|
|
|
TOKEN(0); |
6411
|
|
|
|
|
|
} |
6412
|
29549127
|
|
|
|
|
pl_yylval.ival = 0; |
6413
|
29549127
|
|
|
|
|
OPERATOR(ASSIGNOP); |
6414
|
|
|
|
|
|
case '!': |
6415
|
|
|
|
|
|
s++; |
6416
|
|
|
|
|
|
{ |
6417
|
2749151
|
|
|
|
|
const char tmp = *s++; |
6418
|
2749151
|
100
|
|
|
|
if (tmp == '=') { |
6419
|
|
|
|
|
|
/* was this !=~ where !~ was meant? |
6420
|
|
|
|
|
|
* warn on m:!=~\s+([/?]|[msy]\W|tr\W): */ |
6421
|
|
|
|
|
|
|
6422
|
370193
|
100
|
|
|
|
if (*s == '~' && ckWARN(WARN_SYNTAX)) { |
|
|
100
|
|
|
|
|
6423
|
14
|
|
|
|
|
const char *t = s+1; |
6424
|
|
|
|
|
|
|
6425
|
35
|
50
|
|
|
|
while (t < PL_bufend && isSPACE(*t)) |
|
|
100
|
|
|
|
|
6426
|
14
|
|
|
|
|
++t; |
6427
|
|
|
|
|
|
|
6428
|
18
|
100
|
|
|
|
if (*t == '/' || *t == '?' || |
|
|
100
|
|
|
|
|
6429
|
8
|
100
|
|
|
|
((*t == 'm' || *t == 's' || *t == 'y') |
6430
|
8
|
50
|
|
|
|
&& !isWORDCHAR(t[1])) || |
|
|
50
|
|
|
|
|
6431
|
3
|
50
|
|
|
|
(*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2]))) |
|
|
50
|
|
|
|
|
6432
|
14
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), |
6433
|
|
|
|
|
|
"!=~ should be !~"); |
6434
|
|
|
|
|
|
} |
6435
|
370247
|
100
|
|
|
|
if (!PL_lex_allbrackets && |
|
|
50
|
|
|
|
|
6436
|
108
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) { |
6437
|
|
|
|
|
|
s -= 2; |
6438
|
0
|
|
|
|
|
TOKEN(0); |
6439
|
|
|
|
|
|
} |
6440
|
370193
|
|
|
|
|
Eop(OP_NE); |
6441
|
|
|
|
|
|
} |
6442
|
2378958
|
100
|
|
|
|
if (tmp == '~') |
6443
|
297088
|
|
|
|
|
PMop(OP_NOT); |
6444
|
|
|
|
|
|
} |
6445
|
2081870
|
|
|
|
|
s--; |
6446
|
2081870
|
|
|
|
|
OPERATOR('!'); |
6447
|
|
|
|
|
|
case '<': |
6448
|
1327904
|
100
|
|
|
|
if (PL_expect != XOPERATOR) { |
6449
|
447311
|
100
|
|
|
|
if (s[1] != '<' && !strchr(s,'>')) |
|
|
100
|
|
|
|
|
6450
|
4
|
|
|
|
|
check_uni(); |
6451
|
447311
|
100
|
|
|
|
if (s[1] == '<') |
6452
|
356411
|
|
|
|
|
s = scan_heredoc(s); |
6453
|
|
|
|
|
|
else |
6454
|
90900
|
|
|
|
|
s = scan_inputsymbol(s); |
6455
|
447219
|
|
|
|
|
PL_expect = XOPERATOR; |
6456
|
447219
|
|
|
|
|
TOKEN(sublex_start()); |
6457
|
|
|
|
|
|
} |
6458
|
|
|
|
|
|
s++; |
6459
|
|
|
|
|
|
{ |
6460
|
880593
|
|
|
|
|
char tmp = *s++; |
6461
|
880593
|
100
|
|
|
|
if (tmp == '<') { |
6462
|
39788
|
100
|
|
|
|
if (*s == '=' && !PL_lex_allbrackets && |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
6463
|
10
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) { |
6464
|
|
|
|
|
|
s -= 2; |
6465
|
0
|
|
|
|
|
TOKEN(0); |
6466
|
|
|
|
|
|
} |
6467
|
39783
|
|
|
|
|
SHop(OP_LEFT_SHIFT); |
6468
|
|
|
|
|
|
} |
6469
|
840810
|
100
|
|
|
|
if (tmp == '=') { |
6470
|
155336
|
|
|
|
|
tmp = *s++; |
6471
|
155336
|
100
|
|
|
|
if (tmp == '>') { |
6472
|
30514
|
100
|
|
|
|
if (!PL_lex_allbrackets && |
|
|
50
|
|
|
|
|
6473
|
28
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) { |
6474
|
|
|
|
|
|
s -= 3; |
6475
|
0
|
|
|
|
|
TOKEN(0); |
6476
|
|
|
|
|
|
} |
6477
|
30500
|
|
|
|
|
Eop(OP_NCMP); |
6478
|
|
|
|
|
|
} |
6479
|
124836
|
|
|
|
|
s--; |
6480
|
130184
|
100
|
|
|
|
if (!PL_lex_allbrackets && |
|
|
50
|
|
|
|
|
6481
|
10696
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) { |
6482
|
|
|
|
|
|
s -= 2; |
6483
|
0
|
|
|
|
|
TOKEN(0); |
6484
|
|
|
|
|
|
} |
6485
|
124836
|
|
|
|
|
Rop(OP_LE); |
6486
|
|
|
|
|
|
} |
6487
|
|
|
|
|
|
} |
6488
|
685474
|
|
|
|
|
s--; |
6489
|
685474
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) { |
|
|
100
|
|
|
|
|
6490
|
|
|
|
|
|
s--; |
6491
|
2
|
|
|
|
|
TOKEN(0); |
6492
|
|
|
|
|
|
} |
6493
|
685472
|
|
|
|
|
Rop(OP_LT); |
6494
|
|
|
|
|
|
case '>': |
6495
|
|
|
|
|
|
s++; |
6496
|
|
|
|
|
|
{ |
6497
|
1152857
|
|
|
|
|
const char tmp = *s++; |
6498
|
1152857
|
100
|
|
|
|
if (tmp == '>') { |
6499
|
31481
|
100
|
|
|
|
if (*s == '=' && !PL_lex_allbrackets && |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
6500
|
4
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) { |
6501
|
|
|
|
|
|
s -= 2; |
6502
|
0
|
|
|
|
|
TOKEN(0); |
6503
|
|
|
|
|
|
} |
6504
|
31479
|
|
|
|
|
SHop(OP_RIGHT_SHIFT); |
6505
|
|
|
|
|
|
} |
6506
|
1121378
|
100
|
|
|
|
else if (tmp == '=') { |
6507
|
356644
|
100
|
|
|
|
if (!PL_lex_allbrackets && |
|
|
50
|
|
|
|
|
6508
|
18160
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) { |
6509
|
|
|
|
|
|
s -= 2; |
6510
|
0
|
|
|
|
|
TOKEN(0); |
6511
|
|
|
|
|
|
} |
6512
|
348104
|
|
|
|
|
Rop(OP_GE); |
6513
|
|
|
|
|
|
} |
6514
|
|
|
|
|
|
} |
6515
|
773274
|
|
|
|
|
s--; |
6516
|
773274
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) { |
|
|
50
|
|
|
|
|
6517
|
|
|
|
|
|
s--; |
6518
|
0
|
|
|
|
|
TOKEN(0); |
6519
|
|
|
|
|
|
} |
6520
|
773274
|
|
|
|
|
Rop(OP_GT); |
6521
|
|
|
|
|
|
|
6522
|
|
|
|
|
|
case '$': |
6523
|
117171704
|
|
|
|
|
CLINE; |
6524
|
|
|
|
|
|
|
6525
|
117171704
|
100
|
|
|
|
if (PL_expect == XOPERATOR) { |
6526
|
8
|
100
|
|
|
|
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { |
|
|
50
|
|
|
|
|
6527
|
4
|
|
|
|
|
return deprecate_commaless_var_list(); |
6528
|
|
|
|
|
|
} |
6529
|
|
|
|
|
|
} |
6530
|
|
|
|
|
|
|
6531
|
117171700
|
100
|
|
|
|
if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
6532
|
219482
|
|
|
|
|
PL_tokenbuf[0] = '@'; |
6533
|
219482
|
|
|
|
|
s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, |
6534
|
|
|
|
|
|
sizeof PL_tokenbuf - 1, FALSE); |
6535
|
219480
|
50
|
|
|
|
if (PL_expect == XOPERATOR) |
6536
|
0
|
|
|
|
|
no_op("Array length", s); |
6537
|
219480
|
100
|
|
|
|
if (!PL_tokenbuf[1]) |
6538
|
92314
|
|
|
|
|
PREREF(DOLSHARP); |
6539
|
127166
|
|
|
|
|
PL_expect = XOPERATOR; |
6540
|
127166
|
|
|
|
|
force_ident_maybe_lex('#'); |
6541
|
127166
|
|
|
|
|
TOKEN(DOLSHARP); |
6542
|
|
|
|
|
|
} |
6543
|
|
|
|
|
|
|
6544
|
116952218
|
|
|
|
|
PL_tokenbuf[0] = '$'; |
6545
|
116952218
|
|
|
|
|
s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, |
6546
|
|
|
|
|
|
sizeof PL_tokenbuf - 1, FALSE); |
6547
|
116952216
|
100
|
|
|
|
if (PL_expect == XOPERATOR) |
6548
|
4
|
|
|
|
|
no_op("Scalar", s); |
6549
|
116952216
|
100
|
|
|
|
if (!PL_tokenbuf[1]) { |
6550
|
1139352
|
100
|
|
|
|
if (s == PL_bufend) |
6551
|
2
|
|
|
|
|
yyerror("Final $ should be \\$ or $name"); |
6552
|
1139352
|
|
|
|
|
PREREF('$'); |
6553
|
|
|
|
|
|
} |
6554
|
|
|
|
|
|
|
6555
|
|
|
|
|
|
d = s; |
6556
|
|
|
|
|
|
{ |
6557
|
115812864
|
|
|
|
|
const char tmp = *s; |
6558
|
115812864
|
100
|
|
|
|
if (PL_lex_state == LEX_NORMAL || PL_lex_brackets) |
|
|
100
|
|
|
|
|
6559
|
106850594
|
|
|
|
|
s = SKIPSPACE1(s); |
6560
|
|
|
|
|
|
|
6561
|
115812864
|
100
|
|
|
|
if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) |
|
|
100
|
|
|
|
|
6562
|
112840219
|
100
|
|
|
|
&& intuit_more(s)) { |
6563
|
100458234
|
100
|
|
|
|
if (*s == '[') { |
6564
|
3802163
|
|
|
|
|
PL_tokenbuf[0] = '@'; |
6565
|
3802163
|
100
|
|
|
|
if (ckWARN(WARN_SYNTAX)) { |
6566
|
1192381
|
|
|
|
|
char *t = s+1; |
6567
|
|
|
|
|
|
|
6568
|
3108548
|
100
|
|
|
|
while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$') |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
6569
|
1335095
|
|
|
|
|
t++; |
6570
|
1192381
|
100
|
|
|
|
if (*t++ == ',') { |
6571
|
2
|
|
|
|
|
PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */ |
6572
|
5
|
50
|
|
|
|
while (t < PL_bufend && *t != ']') |
|
|
100
|
|
|
|
|
6573
|
2
|
|
|
|
|
t++; |
6574
|
2
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), |
6575
|
|
|
|
|
|
"Multidimensional syntax %.*s not supported", |
6576
|
2
|
|
|
|
|
(int)((t - PL_bufptr) + 1), PL_bufptr); |
6577
|
|
|
|
|
|
} |
6578
|
|
|
|
|
|
} |
6579
|
|
|
|
|
|
} |
6580
|
96656071
|
100
|
|
|
|
else if (*s == '{') { |
6581
|
|
|
|
|
|
char *t; |
6582
|
5156890
|
|
|
|
|
PL_tokenbuf[0] = '%'; |
6583
|
5156890
|
100
|
|
|
|
if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
6584
|
81990
|
50
|
|
|
|
&& (t = strchr(s, '}')) && (t = strchr(t, '='))) |
|
|
100
|
|
|
|
|
6585
|
|
|
|
|
|
{ |
6586
|
|
|
|
|
|
char tmpbuf[sizeof PL_tokenbuf]; |
6587
|
|
|
|
|
|
do { |
6588
|
80672
|
|
|
|
|
t++; |
6589
|
80672
|
100
|
|
|
|
} while (isSPACE(*t)); |
6590
|
40012
|
50
|
|
|
|
if (isIDFIRST_lazy_if(t,UTF)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
6591
|
|
|
|
|
|
STRLEN len; |
6592
|
34406
|
|
|
|
|
t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, |
6593
|
|
|
|
|
|
&len); |
6594
|
56019
|
100
|
|
|
|
while (isSPACE(*t)) |
6595
|
4770
|
|
|
|
|
t++; |
6596
|
34406
|
100
|
|
|
|
if (*t == ';' |
6597
|
110
|
50
|
|
|
|
&& get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0)) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
6598
|
21
|
50
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), |
|
|
50
|
|
|
|
|
6599
|
|
|
|
|
|
"You need to quote \"%"UTF8f"\"", |
6600
|
15
|
50
|
|
|
|
UTF8fARG(UTF, len, tmpbuf)); |
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
6601
|
|
|
|
|
|
} |
6602
|
|
|
|
|
|
} |
6603
|
|
|
|
|
|
} |
6604
|
|
|
|
|
|
} |
6605
|
|
|
|
|
|
|
6606
|
115812864
|
|
|
|
|
PL_expect = XOPERATOR; |
6607
|
115812864
|
100
|
|
|
|
if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) { |
|
|
100
|
|
|
|
|
6608
|
38247285
|
|
|
|
|
const bool islop = (PL_last_lop == PL_oldoldbufptr); |
6609
|
38247285
|
100
|
|
|
|
if (!islop || PL_last_lop_op == OP_GREPSTART) |
|
|
100
|
|
|
|
|
6610
|
37986938
|
|
|
|
|
PL_expect = XOPERATOR; |
6611
|
260347
|
100
|
|
|
|
else if (strchr("$@\"'`q", *s)) |
6612
|
91017
|
|
|
|
|
PL_expect = XTERM; /* e.g. print $fh "foo" */ |
6613
|
169330
|
100
|
|
|
|
else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF)) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
6614
|
40
|
|
|
|
|
PL_expect = XTERM; /* e.g. print $fh &sub */ |
6615
|
169290
|
100
|
|
|
|
else if (isIDFIRST_lazy_if(s,UTF)) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
6616
|
|
|
|
|
|
char tmpbuf[sizeof PL_tokenbuf]; |
6617
|
|
|
|
|
|
int t2; |
6618
|
105508
|
|
|
|
|
scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); |
6619
|
105508
|
100
|
|
|
|
if ((t2 = keyword(tmpbuf, len, 0))) { |
6620
|
|
|
|
|
|
/* binary operators exclude handle interpretations */ |
6621
|
104828
|
100
|
|
|
|
switch (t2) { |
6622
|
|
|
|
|
|
case -KEY_x: |
6623
|
|
|
|
|
|
case -KEY_eq: |
6624
|
|
|
|
|
|
case -KEY_ne: |
6625
|
|
|
|
|
|
case -KEY_gt: |
6626
|
|
|
|
|
|
case -KEY_lt: |
6627
|
|
|
|
|
|
case -KEY_ge: |
6628
|
|
|
|
|
|
case -KEY_le: |
6629
|
|
|
|
|
|
case -KEY_cmp: |
6630
|
|
|
|
|
|
break; |
6631
|
|
|
|
|
|
default: |
6632
|
103396
|
|
|
|
|
PL_expect = XTERM; /* e.g. print $fh length() */ |
6633
|
103396
|
|
|
|
|
break; |
6634
|
|
|
|
|
|
} |
6635
|
|
|
|
|
|
} |
6636
|
|
|
|
|
|
else { |
6637
|
680
|
|
|
|
|
PL_expect = XTERM; /* e.g. print $fh subr() */ |
6638
|
|
|
|
|
|
} |
6639
|
|
|
|
|
|
} |
6640
|
63782
|
100
|
|
|
|
else if (isDIGIT(*s)) |
6641
|
620
|
|
|
|
|
PL_expect = XTERM; /* e.g. print $fh 3 */ |
6642
|
63162
|
100
|
|
|
|
else if (*s == '.' && isDIGIT(s[1])) |
|
|
50
|
|
|
|
|
6643
|
0
|
|
|
|
|
PL_expect = XTERM; /* e.g. print $fh .3 */ |
6644
|
63162
|
100
|
|
|
|
else if ((*s == '?' || *s == '-' || *s == '+') |
|
|
100
|
|
|
|
|
6645
|
5920
|
100
|
|
|
|
&& !isSPACE(s[1]) && s[1] != '=') |
|
|
50
|
|
|
|
|
6646
|
4
|
|
|
|
|
PL_expect = XTERM; /* e.g. print $fh -1 */ |
6647
|
63158
|
100
|
|
|
|
else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
6648
|
4
|
50
|
|
|
|
&& s[1] != '/') |
6649
|
4
|
|
|
|
|
PL_expect = XTERM; /* e.g. print $fh /.../ |
6650
|
|
|
|
|
|
XXX except DORDOR operator |
6651
|
|
|
|
|
|
*/ |
6652
|
63154
|
100
|
|
|
|
else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
6653
|
5972
|
50
|
|
|
|
&& s[2] != '=') |
6654
|
5972
|
|
|
|
|
PL_expect = XTERM; /* print $fh <<"EOF" */ |
6655
|
|
|
|
|
|
} |
6656
|
|
|
|
|
|
} |
6657
|
115812864
|
|
|
|
|
force_ident_maybe_lex('$'); |
6658
|
115812864
|
|
|
|
|
TOKEN('$'); |
6659
|
|
|
|
|
|
|
6660
|
|
|
|
|
|
case '@': |
6661
|
15888234
|
100
|
|
|
|
if (PL_expect == XOPERATOR) |
6662
|
6
|
|
|
|
|
no_op("Array", s); |
6663
|
15888234
|
|
|
|
|
PL_tokenbuf[0] = '@'; |
6664
|
15888234
|
|
|
|
|
s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); |
6665
|
15888234
|
100
|
|
|
|
if (!PL_tokenbuf[1]) { |
6666
|
1759319
|
|
|
|
|
PREREF('@'); |
6667
|
|
|
|
|
|
} |
6668
|
14128915
|
100
|
|
|
|
if (PL_lex_state == LEX_NORMAL) |
6669
|
13933861
|
|
|
|
|
s = SKIPSPACE1(s); |
6670
|
14128915
|
100
|
|
|
|
if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
6671
|
13001318
|
100
|
|
|
|
if (*s == '{') |
6672
|
144931
|
|
|
|
|
PL_tokenbuf[0] = '%'; |
6673
|
|
|
|
|
|
|
6674
|
|
|
|
|
|
/* Warn about @ where they meant $. */ |
6675
|
13001318
|
100
|
|
|
|
if (*s == '[' || *s == '{') { |
6676
|
189799
|
100
|
|
|
|
if (ckWARN(WARN_SYNTAX)) { |
6677
|
49702
|
|
|
|
|
const char *t = s + 1; |
6678
|
128565
|
50
|
|
|
|
while (*t && (isWORDCHAR_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t))) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
6679
|
54372
|
50
|
|
|
|
t += UTF ? UTF8SKIP(t) : 1; |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
6680
|
49702
|
100
|
|
|
|
if (*t == '}' || *t == ']') { |
6681
|
12
|
|
|
|
|
t++; |
6682
|
12
|
|
|
|
|
PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */ |
6683
|
|
|
|
|
|
/* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */ |
6684
|
78
|
50
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
6685
|
|
|
|
|
|
"Scalar value %"UTF8f" better written as $%"UTF8f, |
6686
|
36
|
50
|
|
|
|
UTF8fARG(UTF, t-PL_bufptr, PL_bufptr), |
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
6687
|
42
|
50
|
|
|
|
UTF8fARG(UTF, t-PL_bufptr-1, PL_bufptr+1)); |
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
6688
|
|
|
|
|
|
} |
6689
|
|
|
|
|
|
} |
6690
|
|
|
|
|
|
} |
6691
|
|
|
|
|
|
} |
6692
|
14128915
|
|
|
|
|
PL_expect = XOPERATOR; |
6693
|
14128915
|
|
|
|
|
force_ident_maybe_lex('@'); |
6694
|
14128915
|
|
|
|
|
TERM('@'); |
6695
|
|
|
|
|
|
|
6696
|
|
|
|
|
|
case '/': /* may be division, defined-or, or pattern */ |
6697
|
2425577
|
100
|
|
|
|
if (PL_expect == XTERMORDORDOR && s[1] == '/') { |
|
|
50
|
|
|
|
|
6698
|
22
|
50
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= |
|
|
0
|
|
|
|
|
6699
|
0
|
0
|
|
|
|
(s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) |
6700
|
0
|
|
|
|
|
TOKEN(0); |
6701
|
22
|
|
|
|
|
s += 2; |
6702
|
22
|
|
|
|
|
AOPERATOR(DORDOR); |
6703
|
|
|
|
|
|
} |
6704
|
|
|
|
|
|
case '?': /* may either be conditional or pattern */ |
6705
|
5424824
|
100
|
|
|
|
if (PL_expect == XOPERATOR) { |
6706
|
3141419
|
|
|
|
|
char tmp = *s++; |
6707
|
3141419
|
100
|
|
|
|
if(tmp == '?') { |
6708
|
3113078
|
100
|
|
|
|
if (!PL_lex_allbrackets && |
|
|
100
|
|
|
|
|
6709
|
229074
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) { |
6710
|
|
|
|
|
|
s--; |
6711
|
4
|
|
|
|
|
TOKEN(0); |
6712
|
|
|
|
|
|
} |
6713
|
2999257
|
|
|
|
|
PL_lex_allbrackets++; |
6714
|
2999257
|
|
|
|
|
OPERATOR('?'); |
6715
|
|
|
|
|
|
} |
6716
|
|
|
|
|
|
else { |
6717
|
142158
|
|
|
|
|
tmp = *s++; |
6718
|
142158
|
100
|
|
|
|
if(tmp == '/') { |
6719
|
|
|
|
|
|
/* A // operator. */ |
6720
|
56866
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= |
|
|
50
|
|
|
|
|
6721
|
18
|
100
|
|
|
|
(*s == '=' ? LEX_FAKEEOF_ASSIGN : |
6722
|
|
|
|
|
|
LEX_FAKEEOF_LOGIC)) { |
6723
|
|
|
|
|
|
s -= 2; |
6724
|
0
|
|
|
|
|
TOKEN(0); |
6725
|
|
|
|
|
|
} |
6726
|
56848
|
|
|
|
|
AOPERATOR(DORDOR); |
6727
|
|
|
|
|
|
} |
6728
|
|
|
|
|
|
else { |
6729
|
85310
|
|
|
|
|
s--; |
6730
|
85334
|
100
|
|
|
|
if (*s == '=' && !PL_lex_allbrackets && |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
6731
|
48
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) { |
6732
|
|
|
|
|
|
s--; |
6733
|
0
|
|
|
|
|
TOKEN(0); |
6734
|
|
|
|
|
|
} |
6735
|
85310
|
|
|
|
|
Mop(OP_DIVIDE); |
6736
|
|
|
|
|
|
} |
6737
|
|
|
|
|
|
} |
6738
|
|
|
|
|
|
} |
6739
|
|
|
|
|
|
else { |
6740
|
|
|
|
|
|
/* Disable warning on "study /blah/" */ |
6741
|
2283405
|
100
|
|
|
|
if (PL_oldoldbufptr == PL_last_uni |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
6742
|
2
|
50
|
|
|
|
&& (*PL_last_uni != 's' || s - PL_last_uni < 5 |
|
|
0
|
|
|
|
|
6743
|
0
|
0
|
|
|
|
|| memNE(PL_last_uni, "study", 5) |
6744
|
0
|
0
|
|
|
|
|| isWORDCHAR_lazy_if(PL_last_uni+5,UTF) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
6745
|
|
|
|
|
|
)) |
6746
|
2
|
|
|
|
|
check_uni(); |
6747
|
2283405
|
100
|
|
|
|
if (*s == '?') |
6748
|
8
|
|
|
|
|
deprecate("?PATTERN? without explicit operator"); |
6749
|
2283405
|
|
|
|
|
s = scan_pat(s,OP_MATCH); |
6750
|
2283395
|
|
|
|
|
TERM(sublex_start()); |
6751
|
|
|
|
|
|
} |
6752
|
|
|
|
|
|
|
6753
|
|
|
|
|
|
case '.': |
6754
|
4493129
|
100
|
|
|
|
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack |
|
|
100
|
|
|
|
|
6755
|
|
|
|
|
|
#ifdef PERL_STRICT_CR |
6756
|
|
|
|
|
|
&& s[1] == '\n' |
6757
|
|
|
|
|
|
#else |
6758
|
10
|
50
|
|
|
|
&& (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n')) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
6759
|
|
|
|
|
|
#endif |
6760
|
0
|
0
|
|
|
|
&& (s == PL_linestart || s[-1] == '\n') ) |
|
|
0
|
|
|
|
|
6761
|
|
|
|
|
|
{ |
6762
|
0
|
|
|
|
|
PL_expect = XSTATE; |
6763
|
|
|
|
|
|
formbrack = 2; /* dot seen where arguments expected */ |
6764
|
0
|
|
|
|
|
goto rightbracket; |
6765
|
|
|
|
|
|
} |
6766
|
4493129
|
100
|
|
|
|
if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
6767
|
2
|
|
|
|
|
s += 3; |
6768
|
2
|
|
|
|
|
OPERATOR(YADAYADA); |
6769
|
|
|
|
|
|
} |
6770
|
4493127
|
100
|
|
|
|
if (PL_expect == XOPERATOR || !isDIGIT(s[1])) { |
|
|
100
|
|
|
|
|
6771
|
4483125
|
|
|
|
|
char tmp = *s++; |
6772
|
4483125
|
100
|
|
|
|
if (*s == tmp) { |
6773
|
183189
|
100
|
|
|
|
if (!PL_lex_allbrackets && |
|
|
50
|
|
|
|
|
6774
|
306
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) { |
6775
|
|
|
|
|
|
s--; |
6776
|
0
|
|
|
|
|
TOKEN(0); |
6777
|
|
|
|
|
|
} |
6778
|
183036
|
|
|
|
|
s++; |
6779
|
183036
|
100
|
|
|
|
if (*s == tmp) { |
6780
|
344
|
|
|
|
|
s++; |
6781
|
344
|
|
|
|
|
pl_yylval.ival = OPf_SPECIAL; |
6782
|
|
|
|
|
|
} |
6783
|
|
|
|
|
|
else |
6784
|
182692
|
|
|
|
|
pl_yylval.ival = 0; |
6785
|
183036
|
|
|
|
|
OPERATOR(DOTDOT); |
6786
|
|
|
|
|
|
} |
6787
|
4300765
|
100
|
|
|
|
if (*s == '=' && !PL_lex_allbrackets && |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
6788
|
1352
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) { |
6789
|
|
|
|
|
|
s--; |
6790
|
0
|
|
|
|
|
TOKEN(0); |
6791
|
|
|
|
|
|
} |
6792
|
4300089
|
|
|
|
|
Aop(OP_CONCAT); |
6793
|
|
|
|
|
|
} |
6794
|
|
|
|
|
|
/* FALL THROUGH */ |
6795
|
|
|
|
|
|
case '0': case '1': case '2': case '3': case '4': |
6796
|
|
|
|
|
|
case '5': case '6': case '7': case '8': case '9': |
6797
|
24486895
|
|
|
|
|
s = scan_num(s, &pl_yylval); |
6798
|
|
|
|
|
|
DEBUG_T( { printbuf("### Saw number in %s\n", s); } ); |
6799
|
24486881
|
100
|
|
|
|
if (PL_expect == XOPERATOR) |
6800
|
40
|
|
|
|
|
no_op("Number",s); |
6801
|
24486881
|
|
|
|
|
TERM(THING); |
6802
|
|
|
|
|
|
|
6803
|
|
|
|
|
|
case '\'': |
6804
|
27135418
|
|
|
|
|
s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); |
6805
|
27135418
|
100
|
|
|
|
COPLINE_SET_FROM_MULTI_END; |
6806
|
|
|
|
|
|
DEBUG_T( { printbuf("### Saw string before %s\n", s); } ); |
6807
|
27135418
|
100
|
|
|
|
if (PL_expect == XOPERATOR) { |
6808
|
8
|
100
|
|
|
|
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { |
|
|
50
|
|
|
|
|
6809
|
4
|
|
|
|
|
return deprecate_commaless_var_list(); |
6810
|
|
|
|
|
|
} |
6811
|
|
|
|
|
|
else |
6812
|
4
|
|
|
|
|
no_op("String",s); |
6813
|
|
|
|
|
|
} |
6814
|
27135414
|
50
|
|
|
|
if (!s) |
6815
|
0
|
|
|
|
|
missingterm(NULL); |
6816
|
27135414
|
|
|
|
|
pl_yylval.ival = OP_CONST; |
6817
|
27135414
|
|
|
|
|
TERM(sublex_start()); |
6818
|
|
|
|
|
|
|
6819
|
|
|
|
|
|
case '"': |
6820
|
19024121
|
|
|
|
|
s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); |
6821
|
|
|
|
|
|
DEBUG_T( { printbuf("### Saw string before %s\n", s); } ); |
6822
|
19024121
|
100
|
|
|
|
if (PL_expect == XOPERATOR) { |
6823
|
12
|
100
|
|
|
|
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { |
|
|
50
|
|
|
|
|
6824
|
4
|
|
|
|
|
return deprecate_commaless_var_list(); |
6825
|
|
|
|
|
|
} |
6826
|
|
|
|
|
|
else |
6827
|
8
|
|
|
|
|
no_op("String",s); |
6828
|
|
|
|
|
|
} |
6829
|
19024117
|
50
|
|
|
|
if (!s) |
6830
|
0
|
|
|
|
|
missingterm(NULL); |
6831
|
19024117
|
|
|
|
|
pl_yylval.ival = OP_CONST; |
6832
|
|
|
|
|
|
/* FIXME. I think that this can be const if char *d is replaced by |
6833
|
|
|
|
|
|
more localised variables. */ |
6834
|
151854520
|
50
|
|
|
|
for (d = SvPV(PL_lex_stuff, len); len; len--, d++) { |
|
|
100
|
|
|
|
|
6835
|
142694465
|
100
|
|
|
|
if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
6836
|
9864062
|
|
|
|
|
pl_yylval.ival = OP_STRINGIFY; |
6837
|
9864062
|
|
|
|
|
break; |
6838
|
|
|
|
|
|
} |
6839
|
|
|
|
|
|
} |
6840
|
19024117
|
100
|
|
|
|
if (pl_yylval.ival == OP_CONST) |
6841
|
9160055
|
100
|
|
|
|
COPLINE_SET_FROM_MULTI_END; |
6842
|
19024117
|
|
|
|
|
TERM(sublex_start()); |
6843
|
|
|
|
|
|
|
6844
|
|
|
|
|
|
case '`': |
6845
|
74810
|
|
|
|
|
s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); |
6846
|
|
|
|
|
|
DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } ); |
6847
|
74810
|
50
|
|
|
|
if (PL_expect == XOPERATOR) |
6848
|
0
|
|
|
|
|
no_op("Backticks",s); |
6849
|
74810
|
50
|
|
|
|
if (!s) |
6850
|
0
|
|
|
|
|
missingterm(NULL); |
6851
|
74810
|
|
|
|
|
readpipe_override(); |
6852
|
74810
|
|
|
|
|
TERM(sublex_start()); |
6853
|
|
|
|
|
|
|
6854
|
|
|
|
|
|
case '\\': |
6855
|
2439744
|
|
|
|
|
s++; |
6856
|
2439744
|
100
|
|
|
|
if (PL_lex_inwhat && isDIGIT(*s)) |
|
|
100
|
|
|
|
|
6857
|
4
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression", |
6858
|
4
|
|
|
|
|
*s, *s); |
6859
|
2439744
|
50
|
|
|
|
if (PL_expect == XOPERATOR) |
6860
|
0
|
|
|
|
|
no_op("Backslash",s); |
6861
|
2439744
|
|
|
|
|
OPERATOR(REFGEN); |
6862
|
|
|
|
|
|
|
6863
|
|
|
|
|
|
case 'v': |
6864
|
547673
|
100
|
|
|
|
if (isDIGIT(s[1]) && PL_expect != XOPERATOR) { |
|
|
50
|
|
|
|
|
6865
|
6478
|
|
|
|
|
char *start = s + 2; |
6866
|
11145
|
100
|
|
|
|
while (isDIGIT(*start) || *start == '_') |
|
|
50
|
|
|
|
|
6867
|
1428
|
|
|
|
|
start++; |
6868
|
6478
|
100
|
|
|
|
if (*start == '.' && isDIGIT(start[1])) { |
|
|
100
|
|
|
|
|
6869
|
1116
|
|
|
|
|
s = scan_num(s, &pl_yylval); |
6870
|
1116
|
|
|
|
|
TERM(THING); |
6871
|
|
|
|
|
|
} |
6872
|
5362
|
100
|
|
|
|
else if ((*start == ':' && start[1] == ':') |
|
|
100
|
|
|
|
|
6873
|
5358
|
100
|
|
|
|
|| (PL_expect == XSTATE && *start == ':')) |
|
|
100
|
|
|
|
|
6874
|
|
|
|
|
|
goto keylookup; |
6875
|
5356
|
100
|
|
|
|
else if (PL_expect == XSTATE) { |
6876
|
|
|
|
|
|
d = start; |
6877
|
27
|
50
|
|
|
|
while (d < PL_bufend && isSPACE(*d)) d++; |
|
|
100
|
|
|
|
|
6878
|
18
|
100
|
|
|
|
if (*d == ':') goto keylookup; |
6879
|
|
|
|
|
|
} |
6880
|
|
|
|
|
|
/* avoid v123abc() or $h{v1}, allow C */ |
6881
|
8031
|
50
|
|
|
|
if (!isALPHA(*start) && (PL_expect == XTERM |
|
|
100
|
|
|
|
|
6882
|
|
|
|
|
|
|| PL_expect == XREF || PL_expect == XSTATE |
6883
|
5354
|
|
|
|
|
|| PL_expect == XTERMORDORDOR)) { |
6884
|
5342
|
50
|
|
|
|
GV *const gv = gv_fetchpvn_flags(s, start - s, |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
6885
|
|
|
|
|
|
UTF ? SVf_UTF8 : 0, SVt_PVCV); |
6886
|
5342
|
100
|
|
|
|
if (!gv) { |
6887
|
5340
|
|
|
|
|
s = scan_num(s, &pl_yylval); |
6888
|
5336
|
|
|
|
|
TERM(THING); |
6889
|
|
|
|
|
|
} |
6890
|
|
|
|
|
|
} |
6891
|
|
|
|
|
|
} |
6892
|
|
|
|
|
|
goto keylookup; |
6893
|
|
|
|
|
|
case 'x': |
6894
|
282234
|
100
|
|
|
|
if (isDIGIT(s[1]) && PL_expect == XOPERATOR) { |
|
|
100
|
|
|
|
|
6895
|
834
|
|
|
|
|
s++; |
6896
|
834
|
|
|
|
|
Mop(OP_REPEAT); |
6897
|
|
|
|
|
|
} |
6898
|
|
|
|
|
|
goto keylookup; |
6899
|
|
|
|
|
|
|
6900
|
|
|
|
|
|
case '_': |
6901
|
|
|
|
|
|
case 'a': case 'A': |
6902
|
|
|
|
|
|
case 'b': case 'B': |
6903
|
|
|
|
|
|
case 'c': case 'C': |
6904
|
|
|
|
|
|
case 'd': case 'D': |
6905
|
|
|
|
|
|
case 'e': case 'E': |
6906
|
|
|
|
|
|
case 'f': case 'F': |
6907
|
|
|
|
|
|
case 'g': case 'G': |
6908
|
|
|
|
|
|
case 'h': case 'H': |
6909
|
|
|
|
|
|
case 'i': case 'I': |
6910
|
|
|
|
|
|
case 'j': case 'J': |
6911
|
|
|
|
|
|
case 'k': case 'K': |
6912
|
|
|
|
|
|
case 'l': case 'L': |
6913
|
|
|
|
|
|
case 'm': case 'M': |
6914
|
|
|
|
|
|
case 'n': case 'N': |
6915
|
|
|
|
|
|
case 'o': case 'O': |
6916
|
|
|
|
|
|
case 'p': case 'P': |
6917
|
|
|
|
|
|
case 'q': case 'Q': |
6918
|
|
|
|
|
|
case 'r': case 'R': |
6919
|
|
|
|
|
|
case 's': case 'S': |
6920
|
|
|
|
|
|
case 't': case 'T': |
6921
|
|
|
|
|
|
case 'u': case 'U': |
6922
|
|
|
|
|
|
case 'V': |
6923
|
|
|
|
|
|
case 'w': case 'W': |
6924
|
|
|
|
|
|
case 'X': |
6925
|
|
|
|
|
|
case 'y': case 'Y': |
6926
|
|
|
|
|
|
case 'z': case 'Z': |
6927
|
|
|
|
|
|
|
6928
|
|
|
|
|
|
keylookup: { |
6929
|
|
|
|
|
|
bool anydelim; |
6930
|
|
|
|
|
|
bool lex; |
6931
|
|
|
|
|
|
I32 tmp; |
6932
|
|
|
|
|
|
SV *sv; |
6933
|
|
|
|
|
|
CV *cv; |
6934
|
|
|
|
|
|
PADOFFSET off; |
6935
|
|
|
|
|
|
OP *rv2cv_op; |
6936
|
|
|
|
|
|
|
6937
|
|
|
|
|
|
lex = FALSE; |
6938
|
|
|
|
|
|
orig_keyword = 0; |
6939
|
|
|
|
|
|
off = 0; |
6940
|
|
|
|
|
|
sv = NULL; |
6941
|
|
|
|
|
|
cv = NULL; |
6942
|
|
|
|
|
|
gv = NULL; |
6943
|
|
|
|
|
|
gvp = NULL; |
6944
|
|
|
|
|
|
rv2cv_op = NULL; |
6945
|
|
|
|
|
|
|
6946
|
125145302
|
|
|
|
|
PL_bufptr = s; |
6947
|
125145302
|
|
|
|
|
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); |
6948
|
|
|
|
|
|
|
6949
|
|
|
|
|
|
/* Some keywords can be followed by any delimiter, including ':' */ |
6950
|
125145302
|
|
|
|
|
anydelim = word_takes_any_delimeter(PL_tokenbuf, len); |
6951
|
|
|
|
|
|
|
6952
|
|
|
|
|
|
/* x::* is just a word, unless x is "CORE" */ |
6953
|
125145302
|
100
|
|
|
|
if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE")) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
6954
|
|
|
|
|
|
goto just_a_word; |
6955
|
|
|
|
|
|
|
6956
|
|
|
|
|
|
d = s; |
6957
|
224269481
|
100
|
|
|
|
while (d < PL_bufend && isSPACE(*d)) |
|
|
100
|
|
|
|
|
6958
|
102138280
|
|
|
|
|
d++; /* no comments skipped here, or s### is misparsed */ |
6959
|
|
|
|
|
|
|
6960
|
|
|
|
|
|
/* Is this a word before a => operator? */ |
6961
|
122131201
|
100
|
|
|
|
if (*d == '=' && d[1] == '>') { |
|
|
100
|
|
|
|
|
6962
|
|
|
|
|
|
fat_arrow: |
6963
|
4159002
|
|
|
|
|
CLINE; |
6964
|
|
|
|
|
|
pl_yylval.opval |
6965
|
4159002
|
|
|
|
|
= (OP*)newSVOP(OP_CONST, 0, |
6966
|
|
|
|
|
|
S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len)); |
6967
|
4159002
|
|
|
|
|
pl_yylval.opval->op_private = OPpCONST_BARE; |
6968
|
4159002
|
|
|
|
|
TERM(WORD); |
6969
|
|
|
|
|
|
} |
6970
|
|
|
|
|
|
|
6971
|
|
|
|
|
|
/* Check for plugged-in keyword */ |
6972
|
|
|
|
|
|
{ |
6973
|
|
|
|
|
|
OP *o; |
6974
|
|
|
|
|
|
int result; |
6975
|
117972201
|
|
|
|
|
char *saved_bufptr = PL_bufptr; |
6976
|
117972201
|
|
|
|
|
PL_bufptr = s; |
6977
|
117972201
|
|
|
|
|
result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o); |
6978
|
117972197
|
|
|
|
|
s = PL_bufptr; |
6979
|
117972197
|
100
|
|
|
|
if (result == KEYWORD_PLUGIN_DECLINE) { |
6980
|
|
|
|
|
|
/* not a plugged-in keyword */ |
6981
|
117971631
|
|
|
|
|
PL_bufptr = saved_bufptr; |
6982
|
566
|
100
|
|
|
|
} else if (result == KEYWORD_PLUGIN_STMT) { |
6983
|
188
|
|
|
|
|
pl_yylval.opval = o; |
6984
|
188
|
|
|
|
|
CLINE; |
6985
|
188
|
|
|
|
|
PL_expect = XSTATE; |
6986
|
188
|
|
|
|
|
return REPORT(PLUGSTMT); |
6987
|
378
|
50
|
|
|
|
} else if (result == KEYWORD_PLUGIN_EXPR) { |
6988
|
378
|
|
|
|
|
pl_yylval.opval = o; |
6989
|
378
|
|
|
|
|
CLINE; |
6990
|
378
|
|
|
|
|
PL_expect = XOPERATOR; |
6991
|
378
|
|
|
|
|
return REPORT(PLUGEXPR); |
6992
|
|
|
|
|
|
} else { |
6993
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'", |
6994
|
0
|
|
|
|
|
PL_tokenbuf); |
6995
|
|
|
|
|
|
} |
6996
|
|
|
|
|
|
} |
6997
|
|
|
|
|
|
|
6998
|
|
|
|
|
|
/* Check for built-in keyword */ |
6999
|
117971631
|
|
|
|
|
tmp = keyword(PL_tokenbuf, len, 0); |
7000
|
|
|
|
|
|
|
7001
|
|
|
|
|
|
/* Is this a label? */ |
7002
|
172320496
|
100
|
|
|
|
if (!anydelim && PL_expect == XSTATE |
|
|
100
|
|
|
|
|
7003
|
69117547
|
100
|
|
|
|
&& d < PL_bufend && *d == ':' && *(d + 1) != ':') { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
7004
|
92362
|
|
|
|
|
s = d + 1; |
7005
|
92362
|
|
|
|
|
pl_yylval.pval = savepvn(PL_tokenbuf, len+1); |
7006
|
92362
|
|
|
|
|
pl_yylval.pval[len] = '\0'; |
7007
|
92362
|
50
|
|
|
|
pl_yylval.pval[len+1] = UTF ? 1 : 0; |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
7008
|
92362
|
|
|
|
|
CLINE; |
7009
|
92362
|
|
|
|
|
TOKEN(LABEL); |
7010
|
|
|
|
|
|
} |
7011
|
|
|
|
|
|
|
7012
|
|
|
|
|
|
/* Check for lexical sub */ |
7013
|
117879269
|
100
|
|
|
|
if (PL_expect != XOPERATOR) { |
7014
|
|
|
|
|
|
char tmpbuf[sizeof PL_tokenbuf + 1]; |
7015
|
103124075
|
|
|
|
|
*tmpbuf = '&'; |
7016
|
103124075
|
|
|
|
|
Copy(PL_tokenbuf, tmpbuf+1, len, char); |
7017
|
103124075
|
50
|
|
|
|
off = pad_findmy_pvn(tmpbuf, len+1, UTF ? SVf_UTF8 : 0); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
7018
|
103124075
|
100
|
|
|
|
if (off != NOT_IN_PAD) { |
7019
|
|
|
|
|
|
assert(off); /* we assume this is boolean-true below */ |
7020
|
154
|
100
|
|
|
|
if (PAD_COMPNAME_FLAGS_isOUR(off)) { |
7021
|
22
|
50
|
|
|
|
HV * const stash = PAD_COMPNAME_OURSTASH(off); |
7022
|
22
|
50
|
|
|
|
HEK * const stashname = HvNAME_HEK(stash); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
7023
|
22
|
|
|
|
|
sv = newSVhek(stashname); |
7024
|
22
|
|
|
|
|
sv_catpvs(sv, "::"); |
7025
|
22
|
50
|
|
|
|
sv_catpvn_flags(sv, PL_tokenbuf, len, |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
7026
|
|
|
|
|
|
(UTF ? SV_CATUTF8 : SV_CATBYTES)); |
7027
|
22
|
|
|
|
|
gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv), |
7028
|
|
|
|
|
|
SVt_PVCV); |
7029
|
|
|
|
|
|
off = 0; |
7030
|
22
|
50
|
|
|
|
if (!gv) { |
7031
|
0
|
|
|
|
|
sv_free(sv); |
7032
|
|
|
|
|
|
sv = NULL; |
7033
|
0
|
|
|
|
|
goto just_a_word; |
7034
|
|
|
|
|
|
} |
7035
|
|
|
|
|
|
} |
7036
|
|
|
|
|
|
else { |
7037
|
132
|
|
|
|
|
rv2cv_op = newOP(OP_PADANY, 0); |
7038
|
132
|
|
|
|
|
rv2cv_op->op_targ = off; |
7039
|
132
|
|
|
|
|
cv = find_lexical_cv(off); |
7040
|
|
|
|
|
|
} |
7041
|
|
|
|
|
|
lex = TRUE; |
7042
|
|
|
|
|
|
goto just_a_word; |
7043
|
|
|
|
|
|
} |
7044
|
|
|
|
|
|
off = 0; |
7045
|
|
|
|
|
|
} |
7046
|
|
|
|
|
|
|
7047
|
117879115
|
100
|
|
|
|
if (tmp < 0) { /* second-class keyword? */ |
7048
|
|
|
|
|
|
GV *ogv = NULL; /* override (winner) */ |
7049
|
|
|
|
|
|
GV *hgv = NULL; /* hidden (loser) */ |
7050
|
23347380
|
100
|
|
|
|
if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
7051
|
|
|
|
|
|
CV *cv; |
7052
|
14604801
|
50
|
|
|
|
if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
7053
|
14186
|
100
|
|
|
|
UTF ? SVf_UTF8 : 0, SVt_PVCV)) && |
7054
|
14186
|
50
|
|
|
|
(cv = GvCVu(gv))) |
7055
|
|
|
|
|
|
{ |
7056
|
11770
|
100
|
|
|
|
if (GvIMPORTED_CV(gv)) |
7057
|
|
|
|
|
|
ogv = gv; |
7058
|
10550
|
50
|
|
|
|
else if (! CvMETHOD(cv)) |
7059
|
|
|
|
|
|
hgv = gv; |
7060
|
|
|
|
|
|
} |
7061
|
29208382
|
100
|
|
|
|
if (!ogv && |
|
|
100
|
|
|
|
|
7062
|
14603581
|
50
|
|
|
|
(gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf, |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
7063
|
368
|
50
|
|
|
|
UTF ? -(I32)len : (I32)len, FALSE)) && |
7064
|
918
|
100
|
|
|
|
(gv = *gvp) && isGV_with_GP(gv) && |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
7065
|
692
|
50
|
|
|
|
GvCVu(gv) && GvIMPORTED_CV(gv)) |
7066
|
|
|
|
|
|
{ |
7067
|
|
|
|
|
|
ogv = gv; |
7068
|
|
|
|
|
|
} |
7069
|
|
|
|
|
|
} |
7070
|
23347380
|
100
|
|
|
|
if (ogv) { |
7071
|
|
|
|
|
|
orig_keyword = tmp; |
7072
|
|
|
|
|
|
tmp = 0; /* overridden by import or by GLOBAL */ |
7073
|
|
|
|
|
|
} |
7074
|
23345834
|
100
|
|
|
|
else if (gv && !gvp |
7075
|
12966
|
100
|
|
|
|
&& -tmp==KEY_lock /* XXX generalizable kludge */ |
7076
|
10448
|
50
|
|
|
|
&& GvCVu(gv)) |
|
|
50
|
|
|
|
|
7077
|
|
|
|
|
|
{ |
7078
|
|
|
|
|
|
tmp = 0; /* any sub overrides "weak" keyword */ |
7079
|
|
|
|
|
|
} |
7080
|
|
|
|
|
|
else { /* no override */ |
7081
|
23335386
|
|
|
|
|
tmp = -tmp; |
7082
|
23335386
|
100
|
|
|
|
if (tmp == KEY_dump) { |
7083
|
6
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), |
7084
|
|
|
|
|
|
"dump() better written as CORE::dump()"); |
7085
|
|
|
|
|
|
} |
7086
|
|
|
|
|
|
gv = NULL; |
7087
|
|
|
|
|
|
gvp = 0; |
7088
|
23335386
|
100
|
|
|
|
if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */ |
|
|
50
|
|
|
|
|
7089
|
8
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), |
7090
|
|
|
|
|
|
"Ambiguous call resolved as CORE::%s(), " |
7091
|
|
|
|
|
|
"qualify as such or use &", |
7092
|
8
|
50
|
|
|
|
GvENAME(hgv)); |
7093
|
|
|
|
|
|
} |
7094
|
|
|
|
|
|
} |
7095
|
|
|
|
|
|
|
7096
|
117879115
|
100
|
|
|
|
if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__ |
|
|
100
|
|
|
|
|
7097
|
106121617
|
100
|
|
|
|
&& (!anydelim || *s != '#')) { |
|
|
100
|
|
|
|
|
7098
|
|
|
|
|
|
/* no override, and not s### either; skipspace is safe here |
7099
|
|
|
|
|
|
* check for => on following line */ |
7100
|
106017995
|
|
|
|
|
STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr); |
7101
|
106017995
|
|
|
|
|
STRLEN soff = s - SvPVX(PL_linestr); |
7102
|
106017995
|
|
|
|
|
s = skipspace_flags(s, LEX_NO_INCLINE); |
7103
|
106017995
|
100
|
|
|
|
if (*s == '=' && s[1] == '>') goto fat_arrow; |
|
|
100
|
|
|
|
|
7104
|
106017993
|
|
|
|
|
PL_bufptr = SvPVX(PL_linestr) + bufoff; |
7105
|
112190057
|
|
|
|
|
s = SvPVX(PL_linestr) + soff; |
7106
|
|
|
|
|
|
} |
7107
|
|
|
|
|
|
|
7108
|
|
|
|
|
|
reserved_word: |
7109
|
117972657
|
|
|
|
|
switch (tmp) { |
7110
|
|
|
|
|
|
|
7111
|
|
|
|
|
|
default: /* not a keyword */ |
7112
|
|
|
|
|
|
/* Trade off - by using this evil construction we can pull the |
7113
|
|
|
|
|
|
variable gv into the block labelled keylookup. If not, then |
7114
|
|
|
|
|
|
we have to give it function scope so that the goto from the |
7115
|
|
|
|
|
|
earlier ':' case doesn't bypass the initialisation. */ |
7116
|
|
|
|
|
|
if (0) { |
7117
|
|
|
|
|
|
just_a_word_zero_gv: |
7118
|
|
|
|
|
|
sv = NULL; |
7119
|
|
|
|
|
|
cv = NULL; |
7120
|
|
|
|
|
|
gv = NULL; |
7121
|
|
|
|
|
|
gvp = NULL; |
7122
|
|
|
|
|
|
rv2cv_op = NULL; |
7123
|
|
|
|
|
|
orig_keyword = 0; |
7124
|
|
|
|
|
|
lex = 0; |
7125
|
|
|
|
|
|
off = 0; |
7126
|
|
|
|
|
|
} |
7127
|
|
|
|
|
|
just_a_word: { |
7128
|
|
|
|
|
|
int pkgname = 0; |
7129
|
14382783
|
100
|
|
|
|
const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); |
7130
|
28004474
|
100
|
|
|
|
const char penultchar = |
7131
|
13943339
|
100
|
|
|
|
lastchar && PL_bufptr - 2 >= PL_linestart |
7132
|
13621691
|
|
|
|
|
? PL_bufptr[-2] |
7133
|
|
|
|
|
|
: 0; |
7134
|
|
|
|
|
|
#ifdef PERL_MAD |
7135
|
|
|
|
|
|
SV *nextPL_nextwhite = 0; |
7136
|
|
|
|
|
|
#endif |
7137
|
|
|
|
|
|
|
7138
|
|
|
|
|
|
|
7139
|
|
|
|
|
|
/* Get the rest if it looks like a package qualifier */ |
7140
|
|
|
|
|
|
|
7141
|
14382783
|
100
|
|
|
|
if (*s == '\'' || (*s == ':' && s[1] == ':')) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
7142
|
|
|
|
|
|
STRLEN morelen; |
7143
|
3014955
|
|
|
|
|
s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len, |
7144
|
|
|
|
|
|
TRUE, &morelen); |
7145
|
3014955
|
100
|
|
|
|
if (!morelen) |
7146
|
28
|
100
|
|
|
|
Perl_croak(aTHX_ "Bad name after %"UTF8f"%s", |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
7147
|
20
|
100
|
|
|
|
UTF8fARG(UTF, len, PL_tokenbuf), |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
7148
|
8
|
|
|
|
|
*s == '\'' ? "'" : "::"); |
7149
|
3014947
|
|
|
|
|
len += morelen; |
7150
|
|
|
|
|
|
pkgname = 1; |
7151
|
|
|
|
|
|
} |
7152
|
|
|
|
|
|
|
7153
|
14382775
|
100
|
|
|
|
if (PL_expect == XOPERATOR) { |
7154
|
46
|
50
|
|
|
|
if (PL_bufptr == PL_linestart) { |
7155
|
0
|
|
|
|
|
CopLINE_dec(PL_curcop); |
7156
|
0
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi); |
7157
|
0
|
|
|
|
|
CopLINE_inc(PL_curcop); |
7158
|
|
|
|
|
|
} |
7159
|
|
|
|
|
|
else |
7160
|
46
|
|
|
|
|
no_op("Bareword",s); |
7161
|
|
|
|
|
|
} |
7162
|
|
|
|
|
|
|
7163
|
|
|
|
|
|
/* Look for a subroutine with this name in current package, |
7164
|
|
|
|
|
|
unless this is a lexical sub, or name is "Foo::", |
7165
|
|
|
|
|
|
in which case Foo is a bareword |
7166
|
|
|
|
|
|
(and a package name). */ |
7167
|
|
|
|
|
|
|
7168
|
21202669
|
100
|
|
|
|
if (len > 2 && !PL_madskills && |
|
|
100
|
|
|
|
|
7169
|
6866345
|
100
|
|
|
|
PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':') |
7170
|
|
|
|
|
|
{ |
7171
|
4862
|
100
|
|
|
|
if (ckWARN(WARN_BAREWORD) |
7172
|
1394
|
50
|
|
|
|
&& ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV)) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
7173
|
21
|
50
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_BAREWORD), |
|
|
50
|
|
|
|
|
7174
|
|
|
|
|
|
"Bareword \"%"UTF8f"\" refers to nonexistent package", |
7175
|
18
|
50
|
|
|
|
UTF8fARG(UTF, len, PL_tokenbuf)); |
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
7176
|
4862
|
|
|
|
|
len -= 2; |
7177
|
4862
|
|
|
|
|
PL_tokenbuf[len] = '\0'; |
7178
|
|
|
|
|
|
gv = NULL; |
7179
|
4862
|
|
|
|
|
gvp = 0; |
7180
|
|
|
|
|
|
} |
7181
|
|
|
|
|
|
else { |
7182
|
14377913
|
100
|
|
|
|
if (!lex && !gv) { |
|
|
100
|
|
|
|
|
7183
|
|
|
|
|
|
/* Mustn't actually add anything to a symbol table. |
7184
|
|
|
|
|
|
But also don't want to "initialise" any placeholder |
7185
|
|
|
|
|
|
constants that might already be there into full |
7186
|
|
|
|
|
|
blown PVGVs with attached PVCV. */ |
7187
|
14365765
|
50
|
|
|
|
gv = gv_fetchpvn_flags(PL_tokenbuf, len, |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
7188
|
|
|
|
|
|
GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ), |
7189
|
|
|
|
|
|
SVt_PVCV); |
7190
|
|
|
|
|
|
} |
7191
|
14377913
|
|
|
|
|
len = 0; |
7192
|
|
|
|
|
|
} |
7193
|
|
|
|
|
|
|
7194
|
|
|
|
|
|
/* if we saw a global override before, get the right name */ |
7195
|
|
|
|
|
|
|
7196
|
14382775
|
100
|
|
|
|
if (!sv) |
7197
|
21339353
|
100
|
|
|
|
sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, |
7198
|
28760644
|
|
|
|
|
len ? len : strlen(PL_tokenbuf)); |
7199
|
14382775
|
100
|
|
|
|
if (gvp) { |
7200
|
|
|
|
|
|
SV * const tmp_sv = sv; |
7201
|
326
|
|
|
|
|
sv = newSVpvs("CORE::GLOBAL::"); |
7202
|
326
|
|
|
|
|
sv_catsv(sv, tmp_sv); |
7203
|
326
|
|
|
|
|
SvREFCNT_dec(tmp_sv); |
7204
|
|
|
|
|
|
} |
7205
|
|
|
|
|
|
|
7206
|
|
|
|
|
|
#ifdef PERL_MAD |
7207
|
|
|
|
|
|
if (PL_madskills && !PL_thistoken) { |
7208
|
|
|
|
|
|
char *start = SvPVX(PL_linestr) + PL_realtokenstart; |
7209
|
|
|
|
|
|
PL_thistoken = newSVpvn(start,s - start); |
7210
|
|
|
|
|
|
PL_realtokenstart = s - SvPVX(PL_linestr); |
7211
|
|
|
|
|
|
} |
7212
|
|
|
|
|
|
#endif |
7213
|
|
|
|
|
|
|
7214
|
|
|
|
|
|
/* Presume this is going to be a bareword of some sort. */ |
7215
|
14382775
|
|
|
|
|
CLINE; |
7216
|
14382775
|
|
|
|
|
pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); |
7217
|
14382775
|
|
|
|
|
pl_yylval.opval->op_private = OPpCONST_BARE; |
7218
|
|
|
|
|
|
|
7219
|
|
|
|
|
|
/* And if "Foo::", then that's what it certainly is. */ |
7220
|
14382775
|
100
|
|
|
|
if (len) |
7221
|
|
|
|
|
|
goto safe_bareword; |
7222
|
|
|
|
|
|
|
7223
|
14377913
|
100
|
|
|
|
if (!off) |
7224
|
|
|
|
|
|
{ |
7225
|
14377781
|
|
|
|
|
OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv)); |
7226
|
14377781
|
|
|
|
|
const_op->op_private = OPpCONST_BARE; |
7227
|
14377781
|
|
|
|
|
rv2cv_op = newCVREF(0, const_op); |
7228
|
14377781
|
100
|
|
|
|
cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0); |
7229
|
|
|
|
|
|
} |
7230
|
|
|
|
|
|
|
7231
|
|
|
|
|
|
/* See if it's the indirect object for a list operator. */ |
7232
|
|
|
|
|
|
|
7233
|
21334524
|
50
|
|
|
|
if (PL_oldoldbufptr && |
|
|
100
|
|
|
|
|
7234
|
20895096
|
100
|
|
|
|
PL_oldoldbufptr < PL_bufptr && |
7235
|
13938485
|
|
|
|
|
(PL_oldoldbufptr == PL_last_lop |
7236
|
14086911
|
100
|
|
|
|
|| PL_oldoldbufptr == PL_last_uni) && |
|
|
100
|
|
|
|
|
7237
|
|
|
|
|
|
/* NO SKIPSPACE BEFORE HERE! */ |
7238
|
1058589
|
100
|
|
|
|
(PL_expect == XREF || |
7239
|
615658
|
|
|
|
|
((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF)) |
7240
|
|
|
|
|
|
{ |
7241
|
718556
|
|
|
|
|
bool immediate_paren = *s == '('; |
7242
|
|
|
|
|
|
|
7243
|
|
|
|
|
|
/* (Now we can afford to cross potential line boundary.) */ |
7244
|
718556
|
|
|
|
|
s = SKIPSPACE2(s,nextPL_nextwhite); |
7245
|
|
|
|
|
|
#ifdef PERL_MAD |
7246
|
|
|
|
|
|
PL_nextwhite = nextPL_nextwhite; /* assume no & deception */ |
7247
|
|
|
|
|
|
#endif |
7248
|
|
|
|
|
|
|
7249
|
|
|
|
|
|
/* Two barewords in a row may indicate method call. */ |
7250
|
|
|
|
|
|
|
7251
|
718556
|
100
|
|
|
|
if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
7252
|
|
|
|
|
|
(tmp = intuit_method(s, gv, cv))) { |
7253
|
0
|
|
|
|
|
op_free(rv2cv_op); |
7254
|
0
|
0
|
|
|
|
if (tmp == METHOD && !PL_lex_allbrackets && |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
7255
|
0
|
|
|
|
|
PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) |
7256
|
0
|
|
|
|
|
PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; |
7257
|
|
|
|
|
|
return REPORT(tmp); |
7258
|
|
|
|
|
|
} |
7259
|
|
|
|
|
|
|
7260
|
|
|
|
|
|
/* If not a declared subroutine, it's an indirect object. */ |
7261
|
|
|
|
|
|
/* (But it's an indir obj regardless for sort.) */ |
7262
|
|
|
|
|
|
/* Also, if "_" follows a filetest operator, it's a bareword */ |
7263
|
|
|
|
|
|
|
7264
|
718556
|
100
|
|
|
|
if ( |
7265
|
679063
|
100
|
|
|
|
( !immediate_paren && (PL_last_lop_op == OP_SORT || |
|
|
100
|
|
|
|
|
7266
|
673641
|
100
|
|
|
|
(!cv && |
7267
|
673641
|
|
|
|
|
(PL_last_lop_op != OP_MAPSTART && |
7268
|
|
|
|
|
|
PL_last_lop_op != OP_GREPSTART)))) |
7269
|
46039
|
100
|
|
|
|
|| (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0' |
7270
|
26
|
50
|
|
|
|
&& ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP)) |
7271
|
|
|
|
|
|
) |
7272
|
|
|
|
|
|
{ |
7273
|
672543
|
|
|
|
|
PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR; |
7274
|
672543
|
|
|
|
|
goto bareword; |
7275
|
|
|
|
|
|
} |
7276
|
|
|
|
|
|
} |
7277
|
|
|
|
|
|
|
7278
|
13705370
|
|
|
|
|
PL_expect = XOPERATOR; |
7279
|
|
|
|
|
|
#ifdef PERL_MAD |
7280
|
|
|
|
|
|
if (isSPACE(*s)) |
7281
|
|
|
|
|
|
s = SKIPSPACE2(s,nextPL_nextwhite); |
7282
|
|
|
|
|
|
PL_nextwhite = nextPL_nextwhite; |
7283
|
|
|
|
|
|
#else |
7284
|
13705370
|
|
|
|
|
s = skipspace(s); |
7285
|
|
|
|
|
|
#endif |
7286
|
|
|
|
|
|
|
7287
|
|
|
|
|
|
/* Is this a word before a => operator? */ |
7288
|
13705370
|
100
|
|
|
|
if (*s == '=' && s[1] == '>' && !pkgname) { |
|
|
100
|
|
|
|
|
7289
|
26
|
|
|
|
|
op_free(rv2cv_op); |
7290
|
26
|
|
|
|
|
CLINE; |
7291
|
|
|
|
|
|
/* This is our own scalar, created a few lines above, |
7292
|
|
|
|
|
|
so this is safe. */ |
7293
|
26
|
|
|
|
|
SvREADONLY_off(cSVOPx(pl_yylval.opval)->op_sv); |
7294
|
26
|
|
|
|
|
sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf); |
7295
|
26
|
50
|
|
|
|
if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len)) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
7296
|
0
|
|
|
|
|
SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv); |
7297
|
26
|
|
|
|
|
SvREADONLY_on(cSVOPx(pl_yylval.opval)->op_sv); |
7298
|
26
|
|
|
|
|
TERM(WORD); |
7299
|
|
|
|
|
|
} |
7300
|
|
|
|
|
|
|
7301
|
|
|
|
|
|
/* If followed by a paren, it's certainly a subroutine. */ |
7302
|
13705344
|
100
|
|
|
|
if (*s == '(') { |
7303
|
9278802
|
|
|
|
|
CLINE; |
7304
|
9278802
|
100
|
|
|
|
if (cv) { |
7305
|
6737349
|
|
|
|
|
d = s + 1; |
7306
|
10327308
|
100
|
|
|
|
while (SPACE_OR_TAB(*d)) |
7307
|
288418
|
|
|
|
|
d++; |
7308
|
6737349
|
100
|
|
|
|
if (*d == ')' && (sv = cv_const_sv_or_av(cv))) { |
|
|
100
|
|
|
|
|
7309
|
21088
|
|
|
|
|
s = d + 1; |
7310
|
21088
|
|
|
|
|
goto its_constant; |
7311
|
|
|
|
|
|
} |
7312
|
|
|
|
|
|
} |
7313
|
|
|
|
|
|
#ifdef PERL_MAD |
7314
|
|
|
|
|
|
if (PL_madskills) { |
7315
|
|
|
|
|
|
PL_nextwhite = PL_thiswhite; |
7316
|
|
|
|
|
|
PL_thiswhite = 0; |
7317
|
|
|
|
|
|
} |
7318
|
|
|
|
|
|
start_force(PL_curforce); |
7319
|
|
|
|
|
|
#endif |
7320
|
18515428
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval = |
7321
|
9257714
|
100
|
|
|
|
off ? rv2cv_op : pl_yylval.opval; |
7322
|
9257714
|
|
|
|
|
PL_expect = XOPERATOR; |
7323
|
|
|
|
|
|
#ifdef PERL_MAD |
7324
|
|
|
|
|
|
if (PL_madskills) { |
7325
|
|
|
|
|
|
PL_nextwhite = nextPL_nextwhite; |
7326
|
|
|
|
|
|
curmad('X', PL_thistoken); |
7327
|
|
|
|
|
|
PL_thistoken = newSVpvs(""); |
7328
|
|
|
|
|
|
} |
7329
|
|
|
|
|
|
#endif |
7330
|
9257714
|
100
|
|
|
|
if (off) |
7331
|
38
|
|
|
|
|
op_free(pl_yylval.opval), force_next(PRIVATEREF); |
7332
|
9257676
|
|
|
|
|
else op_free(rv2cv_op), force_next(WORD); |
7333
|
9257714
|
|
|
|
|
pl_yylval.ival = 0; |
7334
|
9257714
|
|
|
|
|
TOKEN('&'); |
7335
|
|
|
|
|
|
} |
7336
|
|
|
|
|
|
|
7337
|
|
|
|
|
|
/* If followed by var or block, call it a method (unless sub) */ |
7338
|
|
|
|
|
|
|
7339
|
4426542
|
100
|
|
|
|
if ((*s == '$' || *s == '{') && !cv) { |
|
|
100
|
|
|
|
|
7340
|
1442
|
|
|
|
|
op_free(rv2cv_op); |
7341
|
1442
|
|
|
|
|
PL_last_lop = PL_oldbufptr; |
7342
|
1442
|
|
|
|
|
PL_last_lop_op = OP_METHOD; |
7343
|
1469
|
100
|
|
|
|
if (!PL_lex_allbrackets && |
|
|
50
|
|
|
|
|
7344
|
54
|
|
|
|
|
PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) |
7345
|
0
|
|
|
|
|
PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; |
7346
|
1442
|
|
|
|
|
PREBLOCK(METHOD); |
7347
|
|
|
|
|
|
} |
7348
|
|
|
|
|
|
|
7349
|
|
|
|
|
|
/* If followed by a bareword, see if it looks like indir obj. */ |
7350
|
|
|
|
|
|
|
7351
|
6533585
|
100
|
|
|
|
if (!orig_keyword |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
7352
|
6475096
|
50
|
|
|
|
&& (isIDFIRST_lazy_if(s,UTF) || *s == '$') |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
7353
|
685717
|
100
|
|
|
|
&& (tmp = intuit_method(s, gv, cv))) { |
7354
|
62949
|
|
|
|
|
op_free(rv2cv_op); |
7355
|
65018
|
100
|
|
|
|
if (tmp == METHOD && !PL_lex_allbrackets && |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
7356
|
4138
|
|
|
|
|
PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) |
7357
|
4
|
|
|
|
|
PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; |
7358
|
|
|
|
|
|
return REPORT(tmp); |
7359
|
|
|
|
|
|
} |
7360
|
|
|
|
|
|
|
7361
|
|
|
|
|
|
/* Not a method, so call it a subroutine (if defined) */ |
7362
|
|
|
|
|
|
|
7363
|
4362151
|
100
|
|
|
|
if (cv) { |
7364
|
3457161
|
100
|
|
|
|
if (lastchar == '-' && penultchar != '-') { |
7365
|
32
|
50
|
|
|
|
const STRLEN l = len ? len : strlen(PL_tokenbuf); |
7366
|
160
|
50
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS), |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
7367
|
|
|
|
|
|
"Ambiguous use of -%"UTF8f" resolved as -&%"UTF8f"()", |
7368
|
80
|
50
|
|
|
|
UTF8fARG(UTF, l, PL_tokenbuf), |
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
7369
|
80
|
50
|
|
|
|
UTF8fARG(UTF, l, PL_tokenbuf)); |
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
7370
|
|
|
|
|
|
} |
7371
|
|
|
|
|
|
/* Check for a constant sub */ |
7372
|
3457161
|
100
|
|
|
|
if ((sv = cv_const_sv_or_av(cv))) { |
7373
|
|
|
|
|
|
its_constant: |
7374
|
2229594
|
|
|
|
|
op_free(rv2cv_op); |
7375
|
2229594
|
|
|
|
|
SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv); |
7376
|
4459188
|
|
|
|
|
((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv); |
7377
|
2229594
|
100
|
|
|
|
if (SvTYPE(sv) == SVt_PVAV) |
7378
|
1010
|
|
|
|
|
pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS, |
7379
|
|
|
|
|
|
pl_yylval.opval); |
7380
|
|
|
|
|
|
else { |
7381
|
2228584
|
|
|
|
|
pl_yylval.opval->op_private = OPpCONST_FOLDED; |
7382
|
2228584
|
|
|
|
|
pl_yylval.opval->op_folded = 1; |
7383
|
2228584
|
|
|
|
|
pl_yylval.opval->op_flags |= OPf_SPECIAL; |
7384
|
|
|
|
|
|
} |
7385
|
2229594
|
|
|
|
|
TOKEN(WORD); |
7386
|
|
|
|
|
|
} |
7387
|
|
|
|
|
|
|
7388
|
1248655
|
|
|
|
|
op_free(pl_yylval.opval); |
7389
|
2497310
|
|
|
|
|
pl_yylval.opval = |
7390
|
1248655
|
100
|
|
|
|
off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op; |
7391
|
1248655
|
|
|
|
|
pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN; |
7392
|
1248655
|
|
|
|
|
PL_last_lop = PL_oldbufptr; |
7393
|
1248655
|
|
|
|
|
PL_last_lop_op = OP_ENTERSUB; |
7394
|
|
|
|
|
|
/* Is there a prototype? */ |
7395
|
1248655
|
100
|
|
|
|
if ( |
7396
|
|
|
|
|
|
#ifdef PERL_MAD |
7397
|
|
|
|
|
|
cv && |
7398
|
|
|
|
|
|
#endif |
7399
|
1248655
|
|
|
|
|
SvPOK(cv)) |
7400
|
|
|
|
|
|
{ |
7401
|
86362
|
50
|
|
|
|
STRLEN protolen = CvPROTOLEN(cv); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
7402
|
86362
|
50
|
|
|
|
const char *proto = CvPROTO(cv); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
7403
|
|
|
|
|
|
bool optional; |
7404
|
|
|
|
|
|
proto = S_strip_spaces(aTHX_ proto, &protolen); |
7405
|
86362
|
100
|
|
|
|
if (!protolen) |
7406
|
43058
|
|
|
|
|
TERM(FUNC0SUB); |
7407
|
43304
|
100
|
|
|
|
if ((optional = *proto == ';')) |
7408
|
|
|
|
|
|
do |
7409
|
406
|
|
|
|
|
proto++; |
7410
|
406
|
100
|
|
|
|
while (*proto == ';'); |
7411
|
43304
|
100
|
|
|
|
if ( |
7412
|
|
|
|
|
|
( |
7413
|
|
|
|
|
|
( |
7414
|
43304
|
|
|
|
|
*proto == '$' || *proto == '_' |
7415
|
7742
|
100
|
|
|
|
|| *proto == '*' || *proto == '+' |
|
|
100
|
|
|
|
|
7416
|
|
|
|
|
|
) |
7417
|
36310
|
100
|
|
|
|
&& proto[1] == '\0' |
7418
|
|
|
|
|
|
) |
7419
|
40990
|
100
|
|
|
|
|| ( |
7420
|
20713
|
50
|
|
|
|
*proto == '\\' && proto[1] && proto[2] == '\0' |
|
|
100
|
|
|
|
|
7421
|
|
|
|
|
|
) |
7422
|
|
|
|
|
|
) |
7423
|
2388
|
100
|
|
|
|
UNIPROTO(UNIOPSUB,optional); |
7424
|
40916
|
100
|
|
|
|
if (*proto == '\\' && proto[1] == '[') { |
|
|
100
|
|
|
|
|
7425
|
122
|
|
|
|
|
const char *p = proto + 2; |
7426
|
561
|
100
|
|
|
|
while(*p && *p != ']') |
7427
|
378
|
|
|
|
|
++p; |
7428
|
122
|
50
|
|
|
|
if(*p == ']' && !p[1]) |
|
|
100
|
|
|
|
|
7429
|
32
|
100
|
|
|
|
UNIPROTO(UNIOPSUB,optional); |
7430
|
|
|
|
|
|
} |
7431
|
40884
|
100
|
|
|
|
if (*proto == '&' && *s == '{') { |
|
|
100
|
|
|
|
|
7432
|
2442
|
50
|
|
|
|
if (PL_curstash) |
7433
|
2442
|
|
|
|
|
sv_setpvs(PL_subname, "__ANON__"); |
7434
|
|
|
|
|
|
else |
7435
|
0
|
|
|
|
|
sv_setpvs(PL_subname, "__ANON__::__ANON__"); |
7436
|
2495
|
100
|
|
|
|
if (!PL_lex_allbrackets && |
|
|
100
|
|
|
|
|
7437
|
106
|
|
|
|
|
PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) |
7438
|
4
|
|
|
|
|
PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; |
7439
|
2442
|
|
|
|
|
PREBLOCK(LSTOPSUB); |
7440
|
|
|
|
|
|
} |
7441
|
|
|
|
|
|
} |
7442
|
|
|
|
|
|
#ifdef PERL_MAD |
7443
|
|
|
|
|
|
{ |
7444
|
|
|
|
|
|
if (PL_madskills) { |
7445
|
|
|
|
|
|
PL_nextwhite = PL_thiswhite; |
7446
|
|
|
|
|
|
PL_thiswhite = 0; |
7447
|
|
|
|
|
|
} |
7448
|
|
|
|
|
|
start_force(PL_curforce); |
7449
|
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval = pl_yylval.opval; |
7450
|
|
|
|
|
|
PL_expect = XTERM; |
7451
|
|
|
|
|
|
if (PL_madskills) { |
7452
|
|
|
|
|
|
PL_nextwhite = nextPL_nextwhite; |
7453
|
|
|
|
|
|
curmad('X', PL_thistoken); |
7454
|
|
|
|
|
|
PL_thistoken = newSVpvs(""); |
7455
|
|
|
|
|
|
} |
7456
|
|
|
|
|
|
force_next(off ? PRIVATEREF : WORD); |
7457
|
|
|
|
|
|
if (!PL_lex_allbrackets && |
7458
|
|
|
|
|
|
PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) |
7459
|
|
|
|
|
|
PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; |
7460
|
|
|
|
|
|
TOKEN(NOAMP); |
7461
|
|
|
|
|
|
} |
7462
|
|
|
|
|
|
} |
7463
|
|
|
|
|
|
|
7464
|
|
|
|
|
|
/* Guess harder when madskills require "best effort". */ |
7465
|
|
|
|
|
|
if (PL_madskills && (!gv || !GvCVu(gv))) { |
7466
|
|
|
|
|
|
int probable_sub = 0; |
7467
|
|
|
|
|
|
if (strchr("\"'`$@%0123456789!*+{[<", *s)) |
7468
|
|
|
|
|
|
probable_sub = 1; |
7469
|
|
|
|
|
|
else if (isALPHA(*s)) { |
7470
|
|
|
|
|
|
char tmpbuf[1024]; |
7471
|
|
|
|
|
|
STRLEN tmplen; |
7472
|
|
|
|
|
|
d = s; |
7473
|
|
|
|
|
|
d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen); |
7474
|
|
|
|
|
|
if (!keyword(tmpbuf, tmplen, 0)) |
7475
|
|
|
|
|
|
probable_sub = 1; |
7476
|
|
|
|
|
|
else { |
7477
|
|
|
|
|
|
while (d < PL_bufend && isSPACE(*d)) |
7478
|
|
|
|
|
|
d++; |
7479
|
|
|
|
|
|
if (*d == '=' && d[1] == '>') |
7480
|
|
|
|
|
|
probable_sub = 1; |
7481
|
|
|
|
|
|
} |
7482
|
|
|
|
|
|
} |
7483
|
|
|
|
|
|
if (probable_sub) { |
7484
|
|
|
|
|
|
gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), |
7485
|
|
|
|
|
|
SVt_PVCV); |
7486
|
|
|
|
|
|
op_free(pl_yylval.opval); |
7487
|
|
|
|
|
|
pl_yylval.opval = |
7488
|
|
|
|
|
|
off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op; |
7489
|
|
|
|
|
|
pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN; |
7490
|
|
|
|
|
|
PL_last_lop = PL_oldbufptr; |
7491
|
|
|
|
|
|
PL_last_lop_op = OP_ENTERSUB; |
7492
|
|
|
|
|
|
PL_nextwhite = PL_thiswhite; |
7493
|
|
|
|
|
|
PL_thiswhite = 0; |
7494
|
|
|
|
|
|
start_force(PL_curforce); |
7495
|
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval = pl_yylval.opval; |
7496
|
|
|
|
|
|
PL_expect = XTERM; |
7497
|
|
|
|
|
|
PL_nextwhite = nextPL_nextwhite; |
7498
|
|
|
|
|
|
curmad('X', PL_thistoken); |
7499
|
|
|
|
|
|
PL_thistoken = newSVpvs(""); |
7500
|
|
|
|
|
|
force_next(off ? PRIVATEREF : WORD); |
7501
|
|
|
|
|
|
if (!PL_lex_allbrackets && |
7502
|
|
|
|
|
|
PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) |
7503
|
|
|
|
|
|
PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; |
7504
|
|
|
|
|
|
TOKEN(NOAMP); |
7505
|
|
|
|
|
|
} |
7506
|
|
|
|
|
|
#else |
7507
|
1200735
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval = pl_yylval.opval; |
7508
|
1200735
|
|
|
|
|
PL_expect = XTERM; |
7509
|
1200735
|
100
|
|
|
|
force_next(off ? PRIVATEREF : WORD); |
7510
|
1213490
|
100
|
|
|
|
if (!PL_lex_allbrackets && |
|
|
100
|
|
|
|
|
7511
|
25870
|
|
|
|
|
PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) |
7512
|
4
|
|
|
|
|
PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; |
7513
|
1200735
|
|
|
|
|
TOKEN(NOAMP); |
7514
|
|
|
|
|
|
#endif |
7515
|
|
|
|
|
|
} |
7516
|
|
|
|
|
|
|
7517
|
|
|
|
|
|
/* Call it a bare word */ |
7518
|
|
|
|
|
|
|
7519
|
904990
|
100
|
|
|
|
if (PL_hints & HINT_STRICT_SUBS) |
7520
|
822842
|
|
|
|
|
pl_yylval.opval->op_private |= OPpCONST_STRICT; |
7521
|
|
|
|
|
|
else { |
7522
|
|
|
|
|
|
bareword: |
7523
|
|
|
|
|
|
/* after "print" and similar functions (corresponding to |
7524
|
|
|
|
|
|
* "F? L" in opcode.pl), whatever wasn't already parsed as |
7525
|
|
|
|
|
|
* a filehandle should be subject to "strict subs". |
7526
|
|
|
|
|
|
* Likewise for the optional indirect-object argument to system |
7527
|
|
|
|
|
|
* or exec, which can't be a bareword */ |
7528
|
1114943
|
100
|
|
|
|
if ((PL_last_lop_op == OP_PRINT |
7529
|
|
|
|
|
|
|| PL_last_lop_op == OP_PRTF |
7530
|
|
|
|
|
|
|| PL_last_lop_op == OP_SAY |
7531
|
754691
|
|
|
|
|
|| PL_last_lop_op == OP_SYSTEM |
7532
|
486505
|
50
|
|
|
|
|| PL_last_lop_op == OP_EXEC) |
7533
|
268186
|
100
|
|
|
|
&& (PL_hints & HINT_STRICT_SUBS)) |
7534
|
191612
|
|
|
|
|
pl_yylval.opval->op_private |= OPpCONST_STRICT; |
7535
|
754691
|
100
|
|
|
|
if (lastchar != '-') { |
7536
|
754675
|
100
|
|
|
|
if (ckWARN(WARN_RESERVED)) { |
7537
|
311528
|
|
|
|
|
d = PL_tokenbuf; |
7538
|
465528
|
100
|
|
|
|
while (isLOWER(*d)) |
7539
|
2196
|
|
|
|
|
d++; |
7540
|
311528
|
100
|
|
|
|
if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
7541
|
42
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved, |
7542
|
42
|
|
|
|
|
PL_tokenbuf); |
7543
|
|
|
|
|
|
} |
7544
|
|
|
|
|
|
} |
7545
|
|
|
|
|
|
} |
7546
|
1577533
|
|
|
|
|
op_free(rv2cv_op); |
7547
|
|
|
|
|
|
|
7548
|
|
|
|
|
|
safe_bareword: |
7549
|
1582395
|
100
|
|
|
|
if ((lastchar == '*' || lastchar == '%' || lastchar == '&') |
|
|
100
|
|
|
|
|
7550
|
48
|
100
|
|
|
|
&& saw_infix_sigil) { |
7551
|
112
|
50
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS), |
|
|
50
|
|
|
|
|
7552
|
|
|
|
|
|
"Operator or semicolon missing before %c%"UTF8f, |
7553
|
|
|
|
|
|
lastchar, |
7554
|
96
|
50
|
|
|
|
UTF8fARG(UTF, strlen(PL_tokenbuf), |
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
7555
|
|
|
|
|
|
PL_tokenbuf)); |
7556
|
32
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS), |
7557
|
|
|
|
|
|
"Ambiguous use of %c resolved as operator %c", |
7558
|
|
|
|
|
|
lastchar, lastchar); |
7559
|
|
|
|
|
|
} |
7560
|
1582395
|
|
|
|
|
TOKEN(WORD); |
7561
|
|
|
|
|
|
} |
7562
|
|
|
|
|
|
|
7563
|
|
|
|
|
|
case KEY___FILE__: |
7564
|
38364
|
50
|
|
|
|
FUN0OP( |
7565
|
|
|
|
|
|
(OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0)) |
7566
|
|
|
|
|
|
); |
7567
|
|
|
|
|
|
|
7568
|
|
|
|
|
|
case KEY___LINE__: |
7569
|
25326
|
|
|
|
|
FUN0OP( |
7570
|
|
|
|
|
|
(OP*)newSVOP(OP_CONST, 0, |
7571
|
|
|
|
|
|
Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop))) |
7572
|
|
|
|
|
|
); |
7573
|
|
|
|
|
|
|
7574
|
|
|
|
|
|
case KEY___PACKAGE__: |
7575
|
200440
|
50
|
|
|
|
FUN0OP( |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
7576
|
|
|
|
|
|
(OP*)newSVOP(OP_CONST, 0, |
7577
|
|
|
|
|
|
(PL_curstash |
7578
|
|
|
|
|
|
? newSVhek(HvNAME_HEK(PL_curstash)) |
7579
|
|
|
|
|
|
: &PL_sv_undef)) |
7580
|
|
|
|
|
|
); |
7581
|
|
|
|
|
|
|
7582
|
|
|
|
|
|
case KEY___DATA__: |
7583
|
|
|
|
|
|
case KEY___END__: { |
7584
|
|
|
|
|
|
GV *gv; |
7585
|
389930
|
100
|
|
|
|
if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
7586
|
2359
|
50
|
|
|
|
HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash |
7587
|
|
|
|
|
|
? PL_curstash |
7588
|
3650
|
100
|
|
|
|
: PL_defstash; |
7589
|
2222
|
|
|
|
|
gv = (GV *)*hv_fetchs(stash, "DATA", 1); |
7590
|
2222
|
100
|
|
|
|
if (!isGV(gv)) |
7591
|
734
|
|
|
|
|
gv_init(gv,stash,"DATA",4,0); |
7592
|
2222
|
|
|
|
|
GvMULTI_on(gv); |
7593
|
2222
|
50
|
|
|
|
if (!GvIO(gv)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
7594
|
926
|
|
|
|
|
GvIOp(gv) = newIO(); |
7595
|
2222
|
|
|
|
|
IoIFP(GvIOp(gv)) = PL_rsfp; |
7596
|
|
|
|
|
|
#if defined(HAS_FCNTL) && defined(F_SETFD) |
7597
|
|
|
|
|
|
{ |
7598
|
2222
|
|
|
|
|
const int fd = PerlIO_fileno(PL_rsfp); |
7599
|
2222
|
|
|
|
|
fcntl(fd,F_SETFD,fd >= 3); |
7600
|
|
|
|
|
|
} |
7601
|
|
|
|
|
|
#endif |
7602
|
|
|
|
|
|
/* Mark this internal pseudo-handle as clean */ |
7603
|
2222
|
|
|
|
|
IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT; |
7604
|
2222
|
50
|
|
|
|
if ((PerlIO*)PL_rsfp == PerlIO_stdin()) |
7605
|
0
|
|
|
|
|
IoTYPE(GvIOp(gv)) = IoTYPE_STD; |
7606
|
|
|
|
|
|
else |
7607
|
2222
|
|
|
|
|
IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY; |
7608
|
|
|
|
|
|
#if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS) |
7609
|
|
|
|
|
|
/* if the script was opened in binmode, we need to revert |
7610
|
|
|
|
|
|
* it to text mode for compatibility; but only iff it has CRs |
7611
|
|
|
|
|
|
* XXX this is a questionable hack at best. */ |
7612
|
|
|
|
|
|
if (PL_bufend-PL_bufptr > 2 |
7613
|
|
|
|
|
|
&& PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r') |
7614
|
|
|
|
|
|
{ |
7615
|
|
|
|
|
|
Off_t loc = 0; |
7616
|
|
|
|
|
|
if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) { |
7617
|
|
|
|
|
|
loc = PerlIO_tell(PL_rsfp); |
7618
|
|
|
|
|
|
(void)PerlIO_seek(PL_rsfp, 0L, 0); |
7619
|
|
|
|
|
|
} |
7620
|
|
|
|
|
|
#ifdef NETWARE |
7621
|
|
|
|
|
|
if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) { |
7622
|
|
|
|
|
|
#else |
7623
|
|
|
|
|
|
if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) { |
7624
|
|
|
|
|
|
#endif /* NETWARE */ |
7625
|
|
|
|
|
|
if (loc > 0) |
7626
|
|
|
|
|
|
PerlIO_seek(PL_rsfp, loc, 0); |
7627
|
|
|
|
|
|
} |
7628
|
|
|
|
|
|
} |
7629
|
|
|
|
|
|
#endif |
7630
|
|
|
|
|
|
#ifdef PERLIO_LAYERS |
7631
|
2222
|
100
|
|
|
|
if (!IN_BYTES) { |
7632
|
2220
|
50
|
|
|
|
if (UTF) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
7633
|
16
|
|
|
|
|
PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8"); |
7634
|
2222
|
100
|
|
|
|
else if (PL_encoding) { |
|
|
50
|
|
|
|
|
7635
|
|
|
|
|
|
SV *name; |
7636
|
18
|
|
|
|
|
dSP; |
7637
|
18
|
|
|
|
|
ENTER; |
7638
|
18
|
|
|
|
|
SAVETMPS; |
7639
|
18
|
50
|
|
|
|
PUSHMARK(sp); |
7640
|
9
|
|
|
|
|
EXTEND(SP, 1); |
7641
|
18
|
50
|
|
|
|
XPUSHs(PL_encoding); |
7642
|
18
|
|
|
|
|
PUTBACK; |
7643
|
18
|
|
|
|
|
call_method("name", G_SCALAR); |
7644
|
18
|
|
|
|
|
SPAGAIN; |
7645
|
18
|
|
|
|
|
name = POPs; |
7646
|
18
|
|
|
|
|
PUTBACK; |
7647
|
18
|
|
|
|
|
PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, |
7648
|
18
|
|
|
|
|
Perl_form(aTHX_ ":encoding(%"SVf")", |
7649
|
|
|
|
|
|
SVfARG(name))); |
7650
|
18
|
50
|
|
|
|
FREETMPS; |
7651
|
18
|
|
|
|
|
LEAVE; |
7652
|
|
|
|
|
|
} |
7653
|
|
|
|
|
|
} |
7654
|
|
|
|
|
|
#endif |
7655
|
|
|
|
|
|
#ifdef PERL_MAD |
7656
|
|
|
|
|
|
if (PL_madskills) { |
7657
|
|
|
|
|
|
if (PL_realtokenstart >= 0) { |
7658
|
|
|
|
|
|
char *tstart = SvPVX(PL_linestr) + PL_realtokenstart; |
7659
|
|
|
|
|
|
if (!PL_endwhite) |
7660
|
|
|
|
|
|
PL_endwhite = newSVpvs(""); |
7661
|
|
|
|
|
|
sv_catsv(PL_endwhite, PL_thiswhite); |
7662
|
|
|
|
|
|
PL_thiswhite = 0; |
7663
|
|
|
|
|
|
sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart); |
7664
|
|
|
|
|
|
PL_realtokenstart = -1; |
7665
|
|
|
|
|
|
} |
7666
|
|
|
|
|
|
while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite))) |
7667
|
|
|
|
|
|
!= NULL) ; |
7668
|
|
|
|
|
|
} |
7669
|
|
|
|
|
|
#endif |
7670
|
2222
|
|
|
|
|
PL_rsfp = NULL; |
7671
|
|
|
|
|
|
} |
7672
|
|
|
|
|
|
goto fake_eof; |
7673
|
|
|
|
|
|
} |
7674
|
|
|
|
|
|
|
7675
|
|
|
|
|
|
case KEY___SUB__: |
7676
|
32
|
|
|
|
|
FUN0OP(newPVOP(OP_RUNCV,0,NULL)); |
7677
|
|
|
|
|
|
|
7678
|
|
|
|
|
|
case KEY_AUTOLOAD: |
7679
|
|
|
|
|
|
case KEY_DESTROY: |
7680
|
|
|
|
|
|
case KEY_BEGIN: |
7681
|
|
|
|
|
|
case KEY_UNITCHECK: |
7682
|
|
|
|
|
|
case KEY_CHECK: |
7683
|
|
|
|
|
|
case KEY_INIT: |
7684
|
|
|
|
|
|
case KEY_END: |
7685
|
346012
|
100
|
|
|
|
if (PL_expect == XSTATE) { |
7686
|
346008
|
|
|
|
|
s = PL_bufptr; |
7687
|
346008
|
|
|
|
|
goto really_sub; |
7688
|
|
|
|
|
|
} |
7689
|
|
|
|
|
|
goto just_a_word; |
7690
|
|
|
|
|
|
|
7691
|
|
|
|
|
|
case KEY_CORE: |
7692
|
93556
|
100
|
|
|
|
if (*s == ':' && s[1] == ':') { |
|
|
50
|
|
|
|
|
7693
|
93550
|
|
|
|
|
STRLEN olen = len; |
7694
|
|
|
|
|
|
d = s; |
7695
|
93550
|
|
|
|
|
s += 2; |
7696
|
93550
|
|
|
|
|
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); |
7697
|
93550
|
100
|
|
|
|
if ((*s == ':' && s[1] == ':') |
|
|
50
|
|
|
|
|
7698
|
93548
|
100
|
|
|
|
|| (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\'')) |
|
|
100
|
|
|
|
|
7699
|
|
|
|
|
|
{ |
7700
|
|
|
|
|
|
s = d; |
7701
|
4
|
|
|
|
|
len = olen; |
7702
|
4
|
|
|
|
|
Copy(PL_bufptr, PL_tokenbuf, olen, char); |
7703
|
|
|
|
|
|
goto just_a_word; |
7704
|
|
|
|
|
|
} |
7705
|
93546
|
100
|
|
|
|
if (!tmp) |
7706
|
7
|
50
|
|
|
|
Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword", |
|
|
50
|
|
|
|
|
7707
|
6
|
50
|
|
|
|
UTF8fARG(UTF, len, PL_tokenbuf)); |
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
7708
|
93544
|
100
|
|
|
|
if (tmp < 0) |
7709
|
91982
|
|
|
|
|
tmp = -tmp; |
7710
|
1562
|
100
|
|
|
|
else if (tmp == KEY_require || tmp == KEY_do |
7711
|
1557
|
100
|
|
|
|
|| tmp == KEY_glob) |
7712
|
|
|
|
|
|
/* that's a way to remember we saw "CORE::" */ |
7713
|
|
|
|
|
|
orig_keyword = tmp; |
7714
|
|
|
|
|
|
goto reserved_word; |
7715
|
|
|
|
|
|
} |
7716
|
|
|
|
|
|
goto just_a_word; |
7717
|
|
|
|
|
|
|
7718
|
|
|
|
|
|
case KEY_abs: |
7719
|
7382
|
100
|
|
|
|
UNI(OP_ABS); |
|
|
100
|
|
|
|
|
7720
|
|
|
|
|
|
|
7721
|
|
|
|
|
|
case KEY_alarm: |
7722
|
2372
|
100
|
|
|
|
UNI(OP_ALARM); |
|
|
50
|
|
|
|
|
7723
|
|
|
|
|
|
|
7724
|
|
|
|
|
|
case KEY_accept: |
7725
|
234
|
|
|
|
|
LOP(OP_ACCEPT,XTERM); |
7726
|
|
|
|
|
|
|
7727
|
|
|
|
|
|
case KEY_and: |
7728
|
2012188
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC) |
|
|
100
|
|
|
|
|
7729
|
|
|
|
|
|
return REPORT(0); |
7730
|
2012182
|
|
|
|
|
OPERATOR(ANDOP); |
7731
|
|
|
|
|
|
|
7732
|
|
|
|
|
|
case KEY_atan2: |
7733
|
122
|
|
|
|
|
LOP(OP_ATAN2,XTERM); |
7734
|
|
|
|
|
|
|
7735
|
|
|
|
|
|
case KEY_bind: |
7736
|
336
|
|
|
|
|
LOP(OP_BIND,XTERM); |
7737
|
|
|
|
|
|
|
7738
|
|
|
|
|
|
case KEY_binmode: |
7739
|
46583
|
|
|
|
|
LOP(OP_BINMODE,XTERM); |
7740
|
|
|
|
|
|
|
7741
|
|
|
|
|
|
case KEY_bless: |
7742
|
195603
|
|
|
|
|
LOP(OP_BLESS,XTERM); |
7743
|
|
|
|
|
|
|
7744
|
|
|
|
|
|
case KEY_break: |
7745
|
32
|
|
|
|
|
FUN0(OP_BREAK); |
7746
|
|
|
|
|
|
|
7747
|
|
|
|
|
|
case KEY_chop: |
7748
|
33362
|
100
|
|
|
|
UNI(OP_CHOP); |
|
|
100
|
|
|
|
|
7749
|
|
|
|
|
|
|
7750
|
|
|
|
|
|
case KEY_continue: |
7751
|
|
|
|
|
|
/* We have to disambiguate the two senses of |
7752
|
|
|
|
|
|
"continue". If the next token is a '{' then |
7753
|
|
|
|
|
|
treat it as the start of a continue block; |
7754
|
|
|
|
|
|
otherwise treat it as a control operator. |
7755
|
|
|
|
|
|
*/ |
7756
|
6626
|
|
|
|
|
s = skipspace(s); |
7757
|
6626
|
100
|
|
|
|
if (*s == '{') |
7758
|
6566
|
|
|
|
|
PREBLOCK(CONTINUE); |
7759
|
|
|
|
|
|
else |
7760
|
60
|
|
|
|
|
FUN0(OP_CONTINUE); |
7761
|
|
|
|
|
|
|
7762
|
|
|
|
|
|
case KEY_chdir: |
7763
|
|
|
|
|
|
/* may use HOME */ |
7764
|
122836
|
|
|
|
|
(void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV); |
7765
|
122836
|
100
|
|
|
|
UNI(OP_CHDIR); |
|
|
100
|
|
|
|
|
7766
|
|
|
|
|
|
|
7767
|
|
|
|
|
|
case KEY_close: |
7768
|
145367
|
100
|
|
|
|
UNI(OP_CLOSE); |
|
|
100
|
|
|
|
|
7769
|
|
|
|
|
|
|
7770
|
|
|
|
|
|
case KEY_closedir: |
7771
|
76954
|
100
|
|
|
|
UNI(OP_CLOSEDIR); |
|
|
50
|
|
|
|
|
7772
|
|
|
|
|
|
|
7773
|
|
|
|
|
|
case KEY_cmp: |
7774
|
24996
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) |
|
|
50
|
|
|
|
|
7775
|
|
|
|
|
|
return REPORT(0); |
7776
|
24996
|
|
|
|
|
Eop(OP_SCMP); |
7777
|
|
|
|
|
|
|
7778
|
|
|
|
|
|
case KEY_caller: |
7779
|
447978
|
100
|
|
|
|
UNI(OP_CALLER); |
|
|
100
|
|
|
|
|
7780
|
|
|
|
|
|
|
7781
|
|
|
|
|
|
case KEY_crypt: |
7782
|
|
|
|
|
|
#ifdef FCRYPT |
7783
|
|
|
|
|
|
if (!PL_cryptseen) { |
7784
|
|
|
|
|
|
PL_cryptseen = TRUE; |
7785
|
|
|
|
|
|
init_des(); |
7786
|
|
|
|
|
|
} |
7787
|
|
|
|
|
|
#endif |
7788
|
20
|
|
|
|
|
LOP(OP_CRYPT,XTERM); |
7789
|
|
|
|
|
|
|
7790
|
|
|
|
|
|
case KEY_chmod: |
7791
|
84278
|
|
|
|
|
LOP(OP_CHMOD,XTERM); |
7792
|
|
|
|
|
|
|
7793
|
|
|
|
|
|
case KEY_chown: |
7794
|
9376
|
|
|
|
|
LOP(OP_CHOWN,XTERM); |
7795
|
|
|
|
|
|
|
7796
|
|
|
|
|
|
case KEY_connect: |
7797
|
472
|
|
|
|
|
LOP(OP_CONNECT,XTERM); |
7798
|
|
|
|
|
|
|
7799
|
|
|
|
|
|
case KEY_chr: |
7800
|
80004
|
100
|
|
|
|
UNI(OP_CHR); |
|
|
100
|
|
|
|
|
7801
|
|
|
|
|
|
|
7802
|
|
|
|
|
|
case KEY_cos: |
7803
|
330
|
100
|
|
|
|
UNI(OP_COS); |
|
|
50
|
|
|
|
|
7804
|
|
|
|
|
|
|
7805
|
|
|
|
|
|
case KEY_chroot: |
7806
|
6
|
100
|
|
|
|
UNI(OP_CHROOT); |
|
|
50
|
|
|
|
|
7807
|
|
|
|
|
|
|
7808
|
|
|
|
|
|
case KEY_default: |
7809
|
70
|
|
|
|
|
PREBLOCK(DEFAULT); |
7810
|
|
|
|
|
|
|
7811
|
|
|
|
|
|
case KEY_do: |
7812
|
537255
|
|
|
|
|
s = SKIPSPACE1(s); |
7813
|
537255
|
100
|
|
|
|
if (*s == '{') |
7814
|
506471
|
|
|
|
|
PRETERMBLOCK(DO); |
7815
|
30784
|
100
|
|
|
|
if (*s != '\'') { |
7816
|
28898
|
|
|
|
|
*PL_tokenbuf = '&'; |
7817
|
28898
|
|
|
|
|
d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, |
7818
|
|
|
|
|
|
1, &len); |
7819
|
28898
|
100
|
|
|
|
if (len && !keyword(PL_tokenbuf + 1, len, 0)) { |
|
|
100
|
|
|
|
|
7820
|
60
|
|
|
|
|
d = SKIPSPACE1(d); |
7821
|
60
|
100
|
|
|
|
if (*d == '(') { |
7822
|
56
|
|
|
|
|
force_ident_maybe_lex('&'); |
7823
|
|
|
|
|
|
s = d; |
7824
|
|
|
|
|
|
} |
7825
|
|
|
|
|
|
} |
7826
|
|
|
|
|
|
} |
7827
|
30784
|
50
|
|
|
|
if (orig_keyword == KEY_do) { |
7828
|
|
|
|
|
|
orig_keyword = 0; |
7829
|
0
|
|
|
|
|
pl_yylval.ival = 1; |
7830
|
|
|
|
|
|
} |
7831
|
|
|
|
|
|
else |
7832
|
30784
|
|
|
|
|
pl_yylval.ival = 0; |
7833
|
30784
|
|
|
|
|
OPERATOR(DO); |
7834
|
|
|
|
|
|
|
7835
|
|
|
|
|
|
case KEY_die: |
7836
|
695120
|
|
|
|
|
PL_hints |= HINT_BLOCK_SCOPE; |
7837
|
695120
|
|
|
|
|
LOP(OP_DIE,XTERM); |
7838
|
|
|
|
|
|
|
7839
|
|
|
|
|
|
case KEY_defined: |
7840
|
3193360
|
100
|
|
|
|
UNI(OP_DEFINED); |
|
|
100
|
|
|
|
|
7841
|
|
|
|
|
|
|
7842
|
|
|
|
|
|
case KEY_delete: |
7843
|
400444
|
100
|
|
|
|
UNI(OP_DELETE); |
|
|
100
|
|
|
|
|
7844
|
|
|
|
|
|
|
7845
|
|
|
|
|
|
case KEY_dbmopen: |
7846
|
116
|
|
|
|
|
Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"), |
7847
|
|
|
|
|
|
STR_WITH_LEN("NDBM_File::"), |
7848
|
|
|
|
|
|
STR_WITH_LEN("DB_File::"), |
7849
|
|
|
|
|
|
STR_WITH_LEN("GDBM_File::"), |
7850
|
|
|
|
|
|
STR_WITH_LEN("SDBM_File::"), |
7851
|
|
|
|
|
|
STR_WITH_LEN("ODBM_File::"), |
7852
|
|
|
|
|
|
NULL); |
7853
|
116
|
|
|
|
|
LOP(OP_DBMOPEN,XTERM); |
7854
|
|
|
|
|
|
|
7855
|
|
|
|
|
|
case KEY_dbmclose: |
7856
|
110
|
100
|
|
|
|
UNI(OP_DBMCLOSE); |
|
|
50
|
|
|
|
|
7857
|
|
|
|
|
|
|
7858
|
|
|
|
|
|
case KEY_dump: |
7859
|
8
|
|
|
|
|
PL_expect = XOPERATOR; |
7860
|
8
|
|
|
|
|
s = force_word(s,WORD,TRUE,FALSE); |
7861
|
8
|
|
|
|
|
LOOPX(OP_DUMP); |
7862
|
|
|
|
|
|
|
7863
|
|
|
|
|
|
case KEY_else: |
7864
|
2940718
|
|
|
|
|
PREBLOCK(ELSE); |
7865
|
|
|
|
|
|
|
7866
|
|
|
|
|
|
case KEY_elsif: |
7867
|
1807244
|
|
|
|
|
pl_yylval.ival = CopLINE(PL_curcop); |
7868
|
1807244
|
|
|
|
|
OPERATOR(ELSIF); |
7869
|
|
|
|
|
|
|
7870
|
|
|
|
|
|
case KEY_eq: |
7871
|
4426840
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) |
|
|
50
|
|
|
|
|
7872
|
|
|
|
|
|
return REPORT(0); |
7873
|
4426840
|
|
|
|
|
Eop(OP_SEQ); |
7874
|
|
|
|
|
|
|
7875
|
|
|
|
|
|
case KEY_exists: |
7876
|
839897
|
100
|
|
|
|
UNI(OP_EXISTS); |
|
|
100
|
|
|
|
|
7877
|
|
|
|
|
|
|
7878
|
|
|
|
|
|
case KEY_exit: |
7879
|
|
|
|
|
|
if (PL_madskills) |
7880
|
|
|
|
|
|
UNI(OP_INT); |
7881
|
23502
|
100
|
|
|
|
UNI(OP_EXIT); |
|
|
100
|
|
|
|
|
7882
|
|
|
|
|
|
|
7883
|
|
|
|
|
|
case KEY_eval: |
7884
|
711177
|
|
|
|
|
s = SKIPSPACE1(s); |
7885
|
711177
|
100
|
|
|
|
if (*s == '{') { /* block eval */ |
7886
|
422178
|
|
|
|
|
PL_expect = XTERMBLOCK; |
7887
|
422178
|
50
|
|
|
|
UNIBRACK(OP_ENTERTRY); |
|
|
50
|
|
|
|
|
7888
|
|
|
|
|
|
} |
7889
|
|
|
|
|
|
else { /* string eval */ |
7890
|
288999
|
|
|
|
|
PL_expect = XTERM; |
7891
|
288999
|
100
|
|
|
|
UNIBRACK(OP_ENTEREVAL); |
|
|
50
|
|
|
|
|
7892
|
|
|
|
|
|
} |
7893
|
|
|
|
|
|
|
7894
|
|
|
|
|
|
case KEY_evalbytes: |
7895
|
42
|
|
|
|
|
PL_expect = XTERM; |
7896
|
42
|
100
|
|
|
|
UNIBRACK(-OP_ENTEREVAL); |
|
|
50
|
|
|
|
|
7897
|
|
|
|
|
|
|
7898
|
|
|
|
|
|
case KEY_eof: |
7899
|
4198
|
100
|
|
|
|
UNI(OP_EOF); |
|
|
50
|
|
|
|
|
7900
|
|
|
|
|
|
|
7901
|
|
|
|
|
|
case KEY_exp: |
7902
|
316
|
100
|
|
|
|
UNI(OP_EXP); |
|
|
50
|
|
|
|
|
7903
|
|
|
|
|
|
|
7904
|
|
|
|
|
|
case KEY_each: |
7905
|
103866
|
100
|
|
|
|
UNI(OP_EACH); |
|
|
100
|
|
|
|
|
7906
|
|
|
|
|
|
|
7907
|
|
|
|
|
|
case KEY_exec: |
7908
|
11664
|
|
|
|
|
LOP(OP_EXEC,XREF); |
7909
|
|
|
|
|
|
|
7910
|
|
|
|
|
|
case KEY_endhostent: |
7911
|
6
|
|
|
|
|
FUN0(OP_EHOSTENT); |
7912
|
|
|
|
|
|
|
7913
|
|
|
|
|
|
case KEY_endnetent: |
7914
|
6
|
|
|
|
|
FUN0(OP_ENETENT); |
7915
|
|
|
|
|
|
|
7916
|
|
|
|
|
|
case KEY_endservent: |
7917
|
6
|
|
|
|
|
FUN0(OP_ESERVENT); |
7918
|
|
|
|
|
|
|
7919
|
|
|
|
|
|
case KEY_endprotoent: |
7920
|
6
|
|
|
|
|
FUN0(OP_EPROTOENT); |
7921
|
|
|
|
|
|
|
7922
|
|
|
|
|
|
case KEY_endpwent: |
7923
|
12
|
|
|
|
|
FUN0(OP_EPWENT); |
7924
|
|
|
|
|
|
|
7925
|
|
|
|
|
|
case KEY_endgrent: |
7926
|
12
|
|
|
|
|
FUN0(OP_EGRENT); |
7927
|
|
|
|
|
|
|
7928
|
|
|
|
|
|
case KEY_for: |
7929
|
|
|
|
|
|
case KEY_foreach: |
7930
|
1948455
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR) |
|
|
50
|
|
|
|
|
7931
|
|
|
|
|
|
return REPORT(0); |
7932
|
1948455
|
|
|
|
|
pl_yylval.ival = CopLINE(PL_curcop); |
7933
|
1948455
|
|
|
|
|
s = SKIPSPACE1(s); |
7934
|
1948455
|
100
|
|
|
|
if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
7935
|
|
|
|
|
|
char *p = s; |
7936
|
|
|
|
|
|
#ifdef PERL_MAD |
7937
|
|
|
|
|
|
int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */ |
7938
|
|
|
|
|
|
#endif |
7939
|
|
|
|
|
|
|
7940
|
1314041
|
50
|
|
|
|
if ((PL_bufend - p) >= 3 && |
|
|
100
|
|
|
|
|
7941
|
1314019
|
50
|
|
|
|
strnEQ(p, "my", 2) && isSPACE(*(p + 2))) |
7942
|
886085
|
|
|
|
|
p += 2; |
7943
|
33
|
50
|
|
|
|
else if ((PL_bufend - p) >= 4 && |
|
|
100
|
|
|
|
|
7944
|
27
|
50
|
|
|
|
strnEQ(p, "our", 3) && isSPACE(*(p + 3))) |
7945
|
16
|
|
|
|
|
p += 3; |
7946
|
886107
|
|
|
|
|
p = PEEKSPACE(p); |
7947
|
886107
|
100
|
|
|
|
if (isIDFIRST_lazy_if(p,UTF)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
7948
|
6
|
|
|
|
|
p = scan_ident(p, PL_bufend, |
7949
|
|
|
|
|
|
PL_tokenbuf, sizeof PL_tokenbuf, TRUE); |
7950
|
2
|
|
|
|
|
p = PEEKSPACE(p); |
7951
|
|
|
|
|
|
} |
7952
|
886103
|
100
|
|
|
|
if (*p != '$') |
7953
|
2
|
|
|
|
|
Perl_croak(aTHX_ "Missing $ on loop variable"); |
7954
|
|
|
|
|
|
#ifdef PERL_MAD |
7955
|
|
|
|
|
|
s = SvPVX(PL_linestr) + soff; |
7956
|
|
|
|
|
|
#endif |
7957
|
|
|
|
|
|
} |
7958
|
1948449
|
|
|
|
|
OPERATOR(FOR); |
7959
|
|
|
|
|
|
|
7960
|
|
|
|
|
|
case KEY_formline: |
7961
|
1522
|
|
|
|
|
LOP(OP_FORMLINE,XTERM); |
7962
|
|
|
|
|
|
|
7963
|
|
|
|
|
|
case KEY_fork: |
7964
|
3114
|
|
|
|
|
FUN0(OP_FORK); |
7965
|
|
|
|
|
|
|
7966
|
|
|
|
|
|
case KEY_fc: |
7967
|
112
|
100
|
|
|
|
UNI(OP_FC); |
|
|
50
|
|
|
|
|
7968
|
|
|
|
|
|
|
7969
|
|
|
|
|
|
case KEY_fcntl: |
7970
|
6284
|
|
|
|
|
LOP(OP_FCNTL,XTERM); |
7971
|
|
|
|
|
|
|
7972
|
|
|
|
|
|
case KEY_fileno: |
7973
|
25632
|
100
|
|
|
|
UNI(OP_FILENO); |
|
|
50
|
|
|
|
|
7974
|
|
|
|
|
|
|
7975
|
|
|
|
|
|
case KEY_flock: |
7976
|
11012
|
|
|
|
|
LOP(OP_FLOCK,XTERM); |
7977
|
|
|
|
|
|
|
7978
|
|
|
|
|
|
case KEY_gt: |
7979
|
5030
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) |
|
|
50
|
|
|
|
|
7980
|
|
|
|
|
|
return REPORT(0); |
7981
|
5030
|
|
|
|
|
Rop(OP_SGT); |
7982
|
|
|
|
|
|
|
7983
|
|
|
|
|
|
case KEY_ge: |
7984
|
11272
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) |
|
|
50
|
|
|
|
|
7985
|
|
|
|
|
|
return REPORT(0); |
7986
|
11272
|
|
|
|
|
Rop(OP_SGE); |
7987
|
|
|
|
|
|
|
7988
|
|
|
|
|
|
case KEY_grep: |
7989
|
425926
|
|
|
|
|
LOP(OP_GREPSTART, XREF); |
7990
|
|
|
|
|
|
|
7991
|
|
|
|
|
|
case KEY_goto: |
7992
|
335173
|
|
|
|
|
PL_expect = XOPERATOR; |
7993
|
335173
|
|
|
|
|
s = force_word(s,WORD,TRUE,FALSE); |
7994
|
335173
|
|
|
|
|
LOOPX(OP_GOTO); |
7995
|
|
|
|
|
|
|
7996
|
|
|
|
|
|
case KEY_gmtime: |
7997
|
5620
|
100
|
|
|
|
UNI(OP_GMTIME); |
|
|
50
|
|
|
|
|
7998
|
|
|
|
|
|
|
7999
|
|
|
|
|
|
case KEY_getc: |
8000
|
1572
|
100
|
|
|
|
UNIDOR(OP_GETC); |
|
|
50
|
|
|
|
|
8001
|
|
|
|
|
|
|
8002
|
|
|
|
|
|
case KEY_getppid: |
8003
|
1036
|
|
|
|
|
FUN0(OP_GETPPID); |
8004
|
|
|
|
|
|
|
8005
|
|
|
|
|
|
case KEY_getpgrp: |
8006
|
20
|
100
|
|
|
|
UNI(OP_GETPGRP); |
|
|
50
|
|
|
|
|
8007
|
|
|
|
|
|
|
8008
|
|
|
|
|
|
case KEY_getpriority: |
8009
|
12
|
|
|
|
|
LOP(OP_GETPRIORITY,XTERM); |
8010
|
|
|
|
|
|
|
8011
|
|
|
|
|
|
case KEY_getprotobyname: |
8012
|
858
|
100
|
|
|
|
UNI(OP_GPBYNAME); |
|
|
50
|
|
|
|
|
8013
|
|
|
|
|
|
|
8014
|
|
|
|
|
|
case KEY_getprotobynumber: |
8015
|
742
|
|
|
|
|
LOP(OP_GPBYNUMBER,XTERM); |
8016
|
|
|
|
|
|
|
8017
|
|
|
|
|
|
case KEY_getprotoent: |
8018
|
12
|
|
|
|
|
FUN0(OP_GPROTOENT); |
8019
|
|
|
|
|
|
|
8020
|
|
|
|
|
|
case KEY_getpwent: |
8021
|
14
|
|
|
|
|
FUN0(OP_GPWENT); |
8022
|
|
|
|
|
|
|
8023
|
|
|
|
|
|
case KEY_getpwnam: |
8024
|
11312
|
100
|
|
|
|
UNI(OP_GPWNAM); |
|
|
50
|
|
|
|
|
8025
|
|
|
|
|
|
|
8026
|
|
|
|
|
|
case KEY_getpwuid: |
8027
|
1870
|
100
|
|
|
|
UNI(OP_GPWUID); |
|
|
100
|
|
|
|
|
8028
|
|
|
|
|
|
|
8029
|
|
|
|
|
|
case KEY_getpeername: |
8030
|
386
|
100
|
|
|
|
UNI(OP_GETPEERNAME); |
|
|
50
|
|
|
|
|
8031
|
|
|
|
|
|
|
8032
|
|
|
|
|
|
case KEY_gethostbyname: |
8033
|
1420
|
100
|
|
|
|
UNI(OP_GHBYNAME); |
|
|
50
|
|
|
|
|
8034
|
|
|
|
|
|
|
8035
|
|
|
|
|
|
case KEY_gethostbyaddr: |
8036
|
656
|
|
|
|
|
LOP(OP_GHBYADDR,XTERM); |
8037
|
|
|
|
|
|
|
8038
|
|
|
|
|
|
case KEY_gethostent: |
8039
|
10
|
|
|
|
|
FUN0(OP_GHOSTENT); |
8040
|
|
|
|
|
|
|
8041
|
|
|
|
|
|
case KEY_getnetbyname: |
8042
|
14
|
100
|
|
|
|
UNI(OP_GNBYNAME); |
|
|
50
|
|
|
|
|
8043
|
|
|
|
|
|
|
8044
|
|
|
|
|
|
case KEY_getnetbyaddr: |
8045
|
8
|
|
|
|
|
LOP(OP_GNBYADDR,XTERM); |
8046
|
|
|
|
|
|
|
8047
|
|
|
|
|
|
case KEY_getnetent: |
8048
|
10
|
|
|
|
|
FUN0(OP_GNETENT); |
8049
|
|
|
|
|
|
|
8050
|
|
|
|
|
|
case KEY_getservbyname: |
8051
|
1528
|
|
|
|
|
LOP(OP_GSBYNAME,XTERM); |
8052
|
|
|
|
|
|
|
8053
|
|
|
|
|
|
case KEY_getservbyport: |
8054
|
648
|
|
|
|
|
LOP(OP_GSBYPORT,XTERM); |
8055
|
|
|
|
|
|
|
8056
|
|
|
|
|
|
case KEY_getservent: |
8057
|
12
|
|
|
|
|
FUN0(OP_GSERVENT); |
8058
|
|
|
|
|
|
|
8059
|
|
|
|
|
|
case KEY_getsockname: |
8060
|
138
|
100
|
|
|
|
UNI(OP_GETSOCKNAME); |
|
|
50
|
|
|
|
|
8061
|
|
|
|
|
|
|
8062
|
|
|
|
|
|
case KEY_getsockopt: |
8063
|
258
|
|
|
|
|
LOP(OP_GSOCKOPT,XTERM); |
8064
|
|
|
|
|
|
|
8065
|
|
|
|
|
|
case KEY_getgrent: |
8066
|
14
|
|
|
|
|
FUN0(OP_GGRENT); |
8067
|
|
|
|
|
|
|
8068
|
|
|
|
|
|
case KEY_getgrnam: |
8069
|
9302
|
100
|
|
|
|
UNI(OP_GGRNAM); |
|
|
50
|
|
|
|
|
8070
|
|
|
|
|
|
|
8071
|
|
|
|
|
|
case KEY_getgrgid: |
8072
|
78
|
100
|
|
|
|
UNI(OP_GGRGID); |
|
|
100
|
|
|
|
|
8073
|
|
|
|
|
|
|
8074
|
|
|
|
|
|
case KEY_getlogin: |
8075
|
30
|
|
|
|
|
FUN0(OP_GETLOGIN); |
8076
|
|
|
|
|
|
|
8077
|
|
|
|
|
|
case KEY_given: |
8078
|
216
|
|
|
|
|
pl_yylval.ival = CopLINE(PL_curcop); |
8079
|
216
|
|
|
|
|
Perl_ck_warner_d(aTHX_ |
8080
|
|
|
|
|
|
packWARN(WARN_EXPERIMENTAL__SMARTMATCH), |
8081
|
|
|
|
|
|
"given is experimental"); |
8082
|
216
|
|
|
|
|
OPERATOR(GIVEN); |
8083
|
|
|
|
|
|
|
8084
|
|
|
|
|
|
case KEY_glob: |
8085
|
10252
|
100
|
|
|
|
LOP( |
8086
|
|
|
|
|
|
orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB, |
8087
|
|
|
|
|
|
XTERM |
8088
|
|
|
|
|
|
); |
8089
|
|
|
|
|
|
|
8090
|
|
|
|
|
|
case KEY_hex: |
8091
|
55556
|
100
|
|
|
|
UNI(OP_HEX); |
|
|
50
|
|
|
|
|
8092
|
|
|
|
|
|
|
8093
|
|
|
|
|
|
case KEY_if: |
8094
|
11643170
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR) |
|
|
100
|
|
|
|
|
8095
|
|
|
|
|
|
return REPORT(0); |
8096
|
11643162
|
|
|
|
|
pl_yylval.ival = CopLINE(PL_curcop); |
8097
|
11643162
|
|
|
|
|
OPERATOR(IF); |
8098
|
|
|
|
|
|
|
8099
|
|
|
|
|
|
case KEY_index: |
8100
|
68398
|
|
|
|
|
LOP(OP_INDEX,XTERM); |
8101
|
|
|
|
|
|
|
8102
|
|
|
|
|
|
case KEY_int: |
8103
|
48366
|
100
|
|
|
|
UNI(OP_INT); |
|
|
100
|
|
|
|
|
8104
|
|
|
|
|
|
|
8105
|
|
|
|
|
|
case KEY_ioctl: |
8106
|
1670
|
|
|
|
|
LOP(OP_IOCTL,XTERM); |
8107
|
|
|
|
|
|
|
8108
|
|
|
|
|
|
case KEY_join: |
8109
|
588286
|
|
|
|
|
LOP(OP_JOIN,XTERM); |
8110
|
|
|
|
|
|
|
8111
|
|
|
|
|
|
case KEY_keys: |
8112
|
554537
|
100
|
|
|
|
UNI(OP_KEYS); |
|
|
100
|
|
|
|
|
8113
|
|
|
|
|
|
|
8114
|
|
|
|
|
|
case KEY_kill: |
8115
|
10296
|
|
|
|
|
LOP(OP_KILL,XTERM); |
8116
|
|
|
|
|
|
|
8117
|
|
|
|
|
|
case KEY_last: |
8118
|
480846
|
|
|
|
|
PL_expect = XOPERATOR; |
8119
|
480846
|
|
|
|
|
s = force_word(s,WORD,TRUE,FALSE); |
8120
|
480846
|
|
|
|
|
LOOPX(OP_LAST); |
8121
|
|
|
|
|
|
|
8122
|
|
|
|
|
|
case KEY_lc: |
8123
|
73964
|
100
|
|
|
|
UNI(OP_LC); |
|
|
100
|
|
|
|
|
8124
|
|
|
|
|
|
|
8125
|
|
|
|
|
|
case KEY_lcfirst: |
8126
|
376
|
100
|
|
|
|
UNI(OP_LCFIRST); |
|
|
100
|
|
|
|
|
8127
|
|
|
|
|
|
|
8128
|
|
|
|
|
|
case KEY_local: |
8129
|
1214863
|
|
|
|
|
pl_yylval.ival = 0; |
8130
|
1214863
|
|
|
|
|
OPERATOR(LOCAL); |
8131
|
|
|
|
|
|
|
8132
|
|
|
|
|
|
case KEY_length: |
8133
|
698007
|
100
|
|
|
|
UNI(OP_LENGTH); |
|
|
100
|
|
|
|
|
8134
|
|
|
|
|
|
|
8135
|
|
|
|
|
|
case KEY_lt: |
8136
|
1872
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) |
|
|
50
|
|
|
|
|
8137
|
|
|
|
|
|
return REPORT(0); |
8138
|
1872
|
|
|
|
|
Rop(OP_SLT); |
8139
|
|
|
|
|
|
|
8140
|
|
|
|
|
|
case KEY_le: |
8141
|
5684
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) |
|
|
50
|
|
|
|
|
8142
|
|
|
|
|
|
return REPORT(0); |
8143
|
5684
|
|
|
|
|
Rop(OP_SLE); |
8144
|
|
|
|
|
|
|
8145
|
|
|
|
|
|
case KEY_localtime: |
8146
|
8140
|
100
|
|
|
|
UNI(OP_LOCALTIME); |
|
|
50
|
|
|
|
|
8147
|
|
|
|
|
|
|
8148
|
|
|
|
|
|
case KEY_log: |
8149
|
10402
|
100
|
|
|
|
UNI(OP_LOG); |
|
|
100
|
|
|
|
|
8150
|
|
|
|
|
|
|
8151
|
|
|
|
|
|
case KEY_link: |
8152
|
484
|
|
|
|
|
LOP(OP_LINK,XTERM); |
8153
|
|
|
|
|
|
|
8154
|
|
|
|
|
|
case KEY_listen: |
8155
|
232
|
|
|
|
|
LOP(OP_LISTEN,XTERM); |
8156
|
|
|
|
|
|
|
8157
|
|
|
|
|
|
case KEY_lock: |
8158
|
882
|
100
|
|
|
|
UNI(OP_LOCK); |
|
|
50
|
|
|
|
|
8159
|
|
|
|
|
|
|
8160
|
|
|
|
|
|
case KEY_lstat: |
8161
|
56338
|
100
|
|
|
|
UNI(OP_LSTAT); |
|
|
100
|
|
|
|
|
8162
|
|
|
|
|
|
|
8163
|
|
|
|
|
|
case KEY_m: |
8164
|
493413
|
|
|
|
|
s = scan_pat(s,OP_MATCH); |
8165
|
493389
|
|
|
|
|
TERM(sublex_start()); |
8166
|
|
|
|
|
|
|
8167
|
|
|
|
|
|
case KEY_map: |
8168
|
545027
|
|
|
|
|
LOP(OP_MAPSTART, XREF); |
8169
|
|
|
|
|
|
|
8170
|
|
|
|
|
|
case KEY_mkdir: |
8171
|
35086
|
|
|
|
|
LOP(OP_MKDIR,XTERM); |
8172
|
|
|
|
|
|
|
8173
|
|
|
|
|
|
case KEY_msgctl: |
8174
|
110
|
|
|
|
|
LOP(OP_MSGCTL,XTERM); |
8175
|
|
|
|
|
|
|
8176
|
|
|
|
|
|
case KEY_msgget: |
8177
|
104
|
|
|
|
|
LOP(OP_MSGGET,XTERM); |
8178
|
|
|
|
|
|
|
8179
|
|
|
|
|
|
case KEY_msgrcv: |
8180
|
104
|
|
|
|
|
LOP(OP_MSGRCV,XTERM); |
8181
|
|
|
|
|
|
|
8182
|
|
|
|
|
|
case KEY_msgsnd: |
8183
|
104
|
|
|
|
|
LOP(OP_MSGSND,XTERM); |
8184
|
|
|
|
|
|
|
8185
|
|
|
|
|
|
case KEY_our: |
8186
|
|
|
|
|
|
case KEY_my: |
8187
|
|
|
|
|
|
case KEY_state: |
8188
|
19007435
|
|
|
|
|
PL_in_my = (U16)tmp; |
8189
|
19007435
|
|
|
|
|
s = SKIPSPACE1(s); |
8190
|
19007435
|
100
|
|
|
|
if (isIDFIRST_lazy_if(s,UTF)) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
8191
|
|
|
|
|
|
#ifdef PERL_MAD |
8192
|
|
|
|
|
|
char* start = s; |
8193
|
|
|
|
|
|
#endif |
8194
|
302
|
|
|
|
|
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); |
8195
|
302
|
100
|
|
|
|
if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3)) |
|
|
100
|
|
|
|
|
8196
|
|
|
|
|
|
{ |
8197
|
212
|
50
|
|
|
|
if (!FEATURE_LEXSUBS_IS_ENABLED) |
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
8198
|
11
|
100
|
|
|
|
Perl_croak(aTHX_ |
8199
|
|
|
|
|
|
"Experimental \"%s\" subs not enabled", |
8200
|
|
|
|
|
|
tmp == KEY_my ? "my" : |
8201
|
4
|
100
|
|
|
|
tmp == KEY_state ? "state" : "our"); |
8202
|
206
|
|
|
|
|
Perl_ck_warner_d(aTHX_ |
8203
|
|
|
|
|
|
packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS), |
8204
|
|
|
|
|
|
"The lexical_subs feature is experimental"); |
8205
|
202
|
|
|
|
|
goto really_sub; |
8206
|
|
|
|
|
|
} |
8207
|
90
|
|
|
|
|
PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len); |
8208
|
90
|
100
|
|
|
|
if (!PL_in_my_stash) { |
8209
|
|
|
|
|
|
char tmpbuf[1024]; |
8210
|
18
|
|
|
|
|
PL_bufptr = s; |
8211
|
27
|
50
|
|
|
|
my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf); |
8212
|
18
|
50
|
|
|
|
yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
8213
|
|
|
|
|
|
} |
8214
|
|
|
|
|
|
#ifdef PERL_MAD |
8215
|
|
|
|
|
|
if (PL_madskills) { /* just add type to declarator token */ |
8216
|
|
|
|
|
|
sv_catsv(PL_thistoken, PL_nextwhite); |
8217
|
|
|
|
|
|
PL_nextwhite = 0; |
8218
|
|
|
|
|
|
sv_catpvn(PL_thistoken, start, s - start); |
8219
|
|
|
|
|
|
} |
8220
|
|
|
|
|
|
#endif |
8221
|
|
|
|
|
|
} |
8222
|
19007223
|
|
|
|
|
pl_yylval.ival = 1; |
8223
|
19007223
|
|
|
|
|
OPERATOR(MY); |
8224
|
|
|
|
|
|
|
8225
|
|
|
|
|
|
case KEY_next: |
8226
|
846262
|
|
|
|
|
PL_expect = XOPERATOR; |
8227
|
846262
|
|
|
|
|
s = force_word(s,WORD,TRUE,FALSE); |
8228
|
846262
|
|
|
|
|
LOOPX(OP_NEXT); |
8229
|
|
|
|
|
|
|
8230
|
|
|
|
|
|
case KEY_ne: |
8231
|
580020
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) |
|
|
50
|
|
|
|
|
8232
|
|
|
|
|
|
return REPORT(0); |
8233
|
580020
|
|
|
|
|
Eop(OP_SNE); |
8234
|
|
|
|
|
|
|
8235
|
|
|
|
|
|
case KEY_no: |
8236
|
411504
|
|
|
|
|
s = tokenize_use(0, s); |
8237
|
411504
|
|
|
|
|
TERM(USE); |
8238
|
|
|
|
|
|
|
8239
|
|
|
|
|
|
case KEY_not: |
8240
|
324558
|
100
|
|
|
|
if (*s == '(' || (s = SKIPSPACE1(s), *s == '(')) |
|
|
100
|
|
|
|
|
8241
|
1218
|
|
|
|
|
FUN1(OP_NOT); |
8242
|
|
|
|
|
|
else { |
8243
|
323863
|
100
|
|
|
|
if (!PL_lex_allbrackets && |
|
|
100
|
|
|
|
|
8244
|
1046
|
|
|
|
|
PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) |
8245
|
4
|
|
|
|
|
PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; |
8246
|
323340
|
|
|
|
|
OPERATOR(NOTOP); |
8247
|
|
|
|
|
|
} |
8248
|
|
|
|
|
|
|
8249
|
|
|
|
|
|
case KEY_open: |
8250
|
171428
|
|
|
|
|
s = SKIPSPACE1(s); |
8251
|
171428
|
100
|
|
|
|
if (isIDFIRST_lazy_if(s,UTF)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
8252
|
|
|
|
|
|
const char *t; |
8253
|
64708
|
|
|
|
|
d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, |
8254
|
|
|
|
|
|
&len); |
8255
|
143580
|
100
|
|
|
|
for (t=d; isSPACE(*t);) |
8256
|
47958
|
|
|
|
|
t++; |
8257
|
64708
|
100
|
|
|
|
if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
8258
|
|
|
|
|
|
/* [perl #16184] */ |
8259
|
36
|
100
|
|
|
|
&& !(t[0] == '=' && t[1] == '>') |
|
|
50
|
|
|
|
|
8260
|
34
|
100
|
|
|
|
&& !(t[0] == ':' && t[1] == ':') |
|
|
50
|
|
|
|
|
8261
|
26
|
100
|
|
|
|
&& !keyword(s, d-s, 0) |
8262
|
|
|
|
|
|
) { |
8263
|
132
|
50
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE), |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
8264
|
|
|
|
|
|
"Precedence problem: open %"UTF8f" should be open(%"UTF8f")", |
8265
|
120
|
50
|
|
|
|
UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s)); |
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
8266
|
|
|
|
|
|
} |
8267
|
|
|
|
|
|
} |
8268
|
171428
|
|
|
|
|
LOP(OP_OPEN,XTERM); |
8269
|
|
|
|
|
|
|
8270
|
|
|
|
|
|
case KEY_or: |
8271
|
1364511
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC) |
|
|
100
|
|
|
|
|
8272
|
|
|
|
|
|
return REPORT(0); |
8273
|
1364481
|
|
|
|
|
pl_yylval.ival = OP_OR; |
8274
|
1364481
|
|
|
|
|
OPERATOR(OROP); |
8275
|
|
|
|
|
|
|
8276
|
|
|
|
|
|
case KEY_ord: |
8277
|
371972
|
100
|
|
|
|
UNI(OP_ORD); |
|
|
100
|
|
|
|
|
8278
|
|
|
|
|
|
|
8279
|
|
|
|
|
|
case KEY_oct: |
8280
|
19120
|
100
|
|
|
|
UNI(OP_OCT); |
|
|
50
|
|
|
|
|
8281
|
|
|
|
|
|
|
8282
|
|
|
|
|
|
case KEY_opendir: |
8283
|
57350
|
|
|
|
|
LOP(OP_OPEN_DIR,XTERM); |
8284
|
|
|
|
|
|
|
8285
|
|
|
|
|
|
case KEY_print: |
8286
|
1031900
|
|
|
|
|
checkcomma(s,PL_tokenbuf,"filehandle"); |
8287
|
1031898
|
|
|
|
|
LOP(OP_PRINT,XREF); |
8288
|
|
|
|
|
|
|
8289
|
|
|
|
|
|
case KEY_printf: |
8290
|
300566
|
|
|
|
|
checkcomma(s,PL_tokenbuf,"filehandle"); |
8291
|
300566
|
|
|
|
|
LOP(OP_PRTF,XREF); |
8292
|
|
|
|
|
|
|
8293
|
|
|
|
|
|
case KEY_prototype: |
8294
|
24050
|
100
|
|
|
|
UNI(OP_PROTOTYPE); |
|
|
50
|
|
|
|
|
8295
|
|
|
|
|
|
|
8296
|
|
|
|
|
|
case KEY_push: |
8297
|
1413114
|
|
|
|
|
LOP(OP_PUSH,XTERM); |
8298
|
|
|
|
|
|
|
8299
|
|
|
|
|
|
case KEY_pop: |
8300
|
168172
|
100
|
|
|
|
UNIDOR(OP_POP); |
|
|
100
|
|
|
|
|
8301
|
|
|
|
|
|
|
8302
|
|
|
|
|
|
case KEY_pos: |
8303
|
35270
|
100
|
|
|
|
UNIDOR(OP_POS); |
|
|
100
|
|
|
|
|
8304
|
|
|
|
|
|
|
8305
|
|
|
|
|
|
case KEY_pack: |
8306
|
82767
|
|
|
|
|
LOP(OP_PACK,XTERM); |
8307
|
|
|
|
|
|
|
8308
|
|
|
|
|
|
case KEY_package: |
8309
|
700686
|
|
|
|
|
s = force_word(s,WORD,FALSE,TRUE); |
8310
|
700686
|
|
|
|
|
s = SKIPSPACE1(s); |
8311
|
700686
|
|
|
|
|
s = force_strict_version(s); |
8312
|
700686
|
|
|
|
|
PL_lex_expect = XBLOCK; |
8313
|
700686
|
|
|
|
|
OPERATOR(PACKAGE); |
8314
|
|
|
|
|
|
|
8315
|
|
|
|
|
|
case KEY_pipe: |
8316
|
1926
|
|
|
|
|
LOP(OP_PIPE_OP,XTERM); |
8317
|
|
|
|
|
|
|
8318
|
|
|
|
|
|
case KEY_q: |
8319
|
1233587
|
|
|
|
|
s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); |
8320
|
1233587
|
100
|
|
|
|
COPLINE_SET_FROM_MULTI_END; |
8321
|
1233587
|
100
|
|
|
|
if (!s) |
8322
|
4
|
|
|
|
|
missingterm(NULL); |
8323
|
1233583
|
|
|
|
|
pl_yylval.ival = OP_CONST; |
8324
|
1233583
|
|
|
|
|
TERM(sublex_start()); |
8325
|
|
|
|
|
|
|
8326
|
|
|
|
|
|
case KEY_quotemeta: |
8327
|
8216
|
100
|
|
|
|
UNI(OP_QUOTEMETA); |
|
|
100
|
|
|
|
|
8328
|
|
|
|
|
|
|
8329
|
|
|
|
|
|
case KEY_qw: { |
8330
|
|
|
|
|
|
OP *words = NULL; |
8331
|
1361133
|
|
|
|
|
s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); |
8332
|
1361133
|
100
|
|
|
|
COPLINE_SET_FROM_MULTI_END; |
8333
|
1361133
|
100
|
|
|
|
if (!s) |
8334
|
4
|
|
|
|
|
missingterm(NULL); |
8335
|
1361129
|
|
|
|
|
PL_expect = XOPERATOR; |
8336
|
1361129
|
100
|
|
|
|
if (SvCUR(PL_lex_stuff)) { |
8337
|
1360275
|
|
|
|
|
int warned_comma = !ckWARN(WARN_QW); |
8338
|
|
|
|
|
|
int warned_comment = warned_comma; |
8339
|
1360275
|
50
|
|
|
|
d = SvPV_force(PL_lex_stuff, len); |
8340
|
11881663
|
100
|
|
|
|
while (len) { |
8341
|
22727388
|
100
|
|
|
|
for (; isSPACE(*d) && len; --len, ++d) |
|
|
50
|
|
|
|
|
8342
|
|
|
|
|
|
/**/; |
8343
|
9161113
|
100
|
|
|
|
if (len) { |
8344
|
|
|
|
|
|
SV *sv; |
8345
|
|
|
|
|
|
const char *b = d; |
8346
|
8838317
|
100
|
|
|
|
if (!warned_comma || !warned_comment) { |
8347
|
25552910
|
100
|
|
|
|
for (; !isSPACE(*d) && len; --len, ++d) { |
|
|
100
|
|
|
|
|
8348
|
23941194
|
100
|
|
|
|
if (!warned_comma && *d == ',') { |
|
|
100
|
|
|
|
|
8349
|
4
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_QW), |
8350
|
|
|
|
|
|
"Possible attempt to separate words with commas"); |
8351
|
4
|
|
|
|
|
++warned_comma; |
8352
|
|
|
|
|
|
} |
8353
|
23941190
|
100
|
|
|
|
else if (!warned_comment && *d == '#') { |
|
|
100
|
|
|
|
|
8354
|
4
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_QW), |
8355
|
|
|
|
|
|
"Possible attempt to put comments in qw() list"); |
8356
|
4
|
|
|
|
|
++warned_comment; |
8357
|
|
|
|
|
|
} |
8358
|
|
|
|
|
|
} |
8359
|
|
|
|
|
|
} |
8360
|
|
|
|
|
|
else { |
8361
|
49022790
|
100
|
|
|
|
for (; !isSPACE(*d) && len; --len, ++d) |
|
|
100
|
|
|
|
|
8362
|
|
|
|
|
|
/**/; |
8363
|
|
|
|
|
|
} |
8364
|
8838317
|
100
|
|
|
|
sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff)); |
|
|
50
|
|
|
|
|
8365
|
9541668
|
|
|
|
|
words = op_append_elem(OP_LIST, words, |
8366
|
|
|
|
|
|
newSVOP(OP_CONST, 0, tokeq(sv))); |
8367
|
|
|
|
|
|
} |
8368
|
|
|
|
|
|
} |
8369
|
|
|
|
|
|
} |
8370
|
1361129
|
100
|
|
|
|
if (!words) |
8371
|
1724
|
|
|
|
|
words = newNULLLIST(); |
8372
|
1361129
|
50
|
|
|
|
if (PL_lex_stuff) { |
8373
|
1361129
|
|
|
|
|
SvREFCNT_dec(PL_lex_stuff); |
8374
|
1361129
|
|
|
|
|
PL_lex_stuff = NULL; |
8375
|
|
|
|
|
|
} |
8376
|
1361129
|
|
|
|
|
PL_expect = XOPERATOR; |
8377
|
1361129
|
|
|
|
|
pl_yylval.opval = sawparens(words); |
8378
|
1361129
|
|
|
|
|
TOKEN(QWLIST); |
8379
|
|
|
|
|
|
} |
8380
|
|
|
|
|
|
|
8381
|
|
|
|
|
|
case KEY_qq: |
8382
|
277457
|
|
|
|
|
s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); |
8383
|
277457
|
100
|
|
|
|
if (!s) |
8384
|
2
|
|
|
|
|
missingterm(NULL); |
8385
|
277455
|
|
|
|
|
pl_yylval.ival = OP_STRINGIFY; |
8386
|
277455
|
100
|
|
|
|
if (SvIVX(PL_lex_stuff) == '\'') |
8387
|
46218
|
|
|
|
|
SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */ |
8388
|
277455
|
|
|
|
|
TERM(sublex_start()); |
8389
|
|
|
|
|
|
|
8390
|
|
|
|
|
|
case KEY_qr: |
8391
|
472010
|
|
|
|
|
s = scan_pat(s,OP_QR); |
8392
|
471994
|
|
|
|
|
TERM(sublex_start()); |
8393
|
|
|
|
|
|
|
8394
|
|
|
|
|
|
case KEY_qx: |
8395
|
56
|
|
|
|
|
s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); |
8396
|
56
|
100
|
|
|
|
if (!s) |
8397
|
2
|
|
|
|
|
missingterm(NULL); |
8398
|
54
|
|
|
|
|
readpipe_override(); |
8399
|
54
|
|
|
|
|
TERM(sublex_start()); |
8400
|
|
|
|
|
|
|
8401
|
|
|
|
|
|
case KEY_return: |
8402
|
6899041
|
100
|
|
|
|
OLDLOP(OP_RETURN); |
|
|
100
|
|
|
|
|
8403
|
|
|
|
|
|
|
8404
|
|
|
|
|
|
case KEY_require: |
8405
|
1430907
|
|
|
|
|
s = SKIPSPACE1(s); |
8406
|
1430907
|
|
|
|
|
PL_expect = XOPERATOR; |
8407
|
1430907
|
100
|
|
|
|
if (isDIGIT(*s)) { |
8408
|
50648
|
|
|
|
|
s = force_version(s, FALSE); |
8409
|
|
|
|
|
|
} |
8410
|
1380259
|
100
|
|
|
|
else if (*s != 'v' || !isDIGIT(s[1]) |
|
|
100
|
|
|
|
|
8411
|
8
|
50
|
|
|
|
|| (s = force_version(s, TRUE), *s == 'v')) |
8412
|
|
|
|
|
|
{ |
8413
|
1380251
|
|
|
|
|
*PL_tokenbuf = '\0'; |
8414
|
1380251
|
|
|
|
|
s = force_word(s,WORD,TRUE,TRUE); |
8415
|
1380251
|
100
|
|
|
|
if (isIDFIRST_lazy_if(PL_tokenbuf,UTF)) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
8416
|
1321802
|
50
|
|
|
|
gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
8417
|
|
|
|
|
|
GV_ADD | (UTF ? SVf_UTF8 : 0)); |
8418
|
58449
|
100
|
|
|
|
else if (*s == '<') |
8419
|
2
|
|
|
|
|
yyerror("<> should be quotes"); |
8420
|
|
|
|
|
|
} |
8421
|
1430907
|
100
|
|
|
|
if (orig_keyword == KEY_require) { |
8422
|
|
|
|
|
|
orig_keyword = 0; |
8423
|
10
|
|
|
|
|
pl_yylval.ival = 1; |
8424
|
|
|
|
|
|
} |
8425
|
|
|
|
|
|
else |
8426
|
1430897
|
|
|
|
|
pl_yylval.ival = 0; |
8427
|
1430907
|
|
|
|
|
PL_expect = XTERM; |
8428
|
1430907
|
|
|
|
|
PL_bufptr = s; |
8429
|
1430907
|
|
|
|
|
PL_last_uni = PL_oldbufptr; |
8430
|
1430907
|
|
|
|
|
PL_last_lop_op = OP_REQUIRE; |
8431
|
1430907
|
|
|
|
|
s = skipspace(s); |
8432
|
1430907
|
|
|
|
|
return REPORT( (int)REQUIRE ); |
8433
|
|
|
|
|
|
|
8434
|
|
|
|
|
|
case KEY_reset: |
8435
|
56
|
100
|
|
|
|
UNI(OP_RESET); |
|
|
50
|
|
|
|
|
8436
|
|
|
|
|
|
|
8437
|
|
|
|
|
|
case KEY_redo: |
8438
|
181572
|
|
|
|
|
PL_expect = XOPERATOR; |
8439
|
181572
|
|
|
|
|
s = force_word(s,WORD,TRUE,FALSE); |
8440
|
181572
|
|
|
|
|
LOOPX(OP_REDO); |
8441
|
|
|
|
|
|
|
8442
|
|
|
|
|
|
case KEY_rename: |
8443
|
15540
|
|
|
|
|
LOP(OP_RENAME,XTERM); |
8444
|
|
|
|
|
|
|
8445
|
|
|
|
|
|
case KEY_rand: |
8446
|
7578
|
100
|
|
|
|
UNI(OP_RAND); |
|
|
100
|
|
|
|
|
8447
|
|
|
|
|
|
|
8448
|
|
|
|
|
|
case KEY_rmdir: |
8449
|
9528
|
100
|
|
|
|
UNI(OP_RMDIR); |
|
|
50
|
|
|
|
|
8450
|
|
|
|
|
|
|
8451
|
|
|
|
|
|
case KEY_rindex: |
8452
|
3606
|
|
|
|
|
LOP(OP_RINDEX,XTERM); |
8453
|
|
|
|
|
|
|
8454
|
|
|
|
|
|
case KEY_read: |
8455
|
18346
|
|
|
|
|
LOP(OP_READ,XTERM); |
8456
|
|
|
|
|
|
|
8457
|
|
|
|
|
|
case KEY_readdir: |
8458
|
66438
|
100
|
|
|
|
UNI(OP_READDIR); |
|
|
50
|
|
|
|
|
8459
|
|
|
|
|
|
|
8460
|
|
|
|
|
|
case KEY_readline: |
8461
|
6674
|
100
|
|
|
|
UNIDOR(OP_READLINE); |
|
|
50
|
|
|
|
|
8462
|
|
|
|
|
|
|
8463
|
|
|
|
|
|
case KEY_readpipe: |
8464
|
6
|
100
|
|
|
|
UNIDOR(OP_BACKTICK); |
|
|
50
|
|
|
|
|
8465
|
|
|
|
|
|
|
8466
|
|
|
|
|
|
case KEY_rewinddir: |
8467
|
1320
|
100
|
|
|
|
UNI(OP_REWINDDIR); |
|
|
50
|
|
|
|
|
8468
|
|
|
|
|
|
|
8469
|
|
|
|
|
|
case KEY_recv: |
8470
|
258
|
|
|
|
|
LOP(OP_RECV,XTERM); |
8471
|
|
|
|
|
|
|
8472
|
|
|
|
|
|
case KEY_reverse: |
8473
|
23688
|
|
|
|
|
LOP(OP_REVERSE,XTERM); |
8474
|
|
|
|
|
|
|
8475
|
|
|
|
|
|
case KEY_readlink: |
8476
|
32920
|
100
|
|
|
|
UNIDOR(OP_READLINK); |
|
|
50
|
|
|
|
|
8477
|
|
|
|
|
|
|
8478
|
|
|
|
|
|
case KEY_ref: |
8479
|
1107855
|
100
|
|
|
|
UNI(OP_REF); |
|
|
100
|
|
|
|
|
8480
|
|
|
|
|
|
|
8481
|
|
|
|
|
|
case KEY_s: |
8482
|
1488023
|
|
|
|
|
s = scan_subst(s); |
8483
|
1488011
|
50
|
|
|
|
if (pl_yylval.opval) |
8484
|
1488011
|
|
|
|
|
TERM(sublex_start()); |
8485
|
|
|
|
|
|
else |
8486
|
0
|
|
|
|
|
TOKEN(1); /* force error */ |
8487
|
|
|
|
|
|
|
8488
|
|
|
|
|
|
case KEY_say: |
8489
|
78
|
|
|
|
|
checkcomma(s,PL_tokenbuf,"filehandle"); |
8490
|
78
|
|
|
|
|
LOP(OP_SAY,XREF); |
8491
|
|
|
|
|
|
|
8492
|
|
|
|
|
|
case KEY_chomp: |
8493
|
121127
|
100
|
|
|
|
UNI(OP_CHOMP); |
|
|
100
|
|
|
|
|
8494
|
|
|
|
|
|
|
8495
|
|
|
|
|
|
case KEY_scalar: |
8496
|
126618
|
100
|
|
|
|
UNI(OP_SCALAR); |
|
|
100
|
|
|
|
|
8497
|
|
|
|
|
|
|
8498
|
|
|
|
|
|
case KEY_select: |
8499
|
38140
|
|
|
|
|
LOP(OP_SELECT,XTERM); |
8500
|
|
|
|
|
|
|
8501
|
|
|
|
|
|
case KEY_seek: |
8502
|
9220
|
|
|
|
|
LOP(OP_SEEK,XTERM); |
8503
|
|
|
|
|
|
|
8504
|
|
|
|
|
|
case KEY_semctl: |
8505
|
132
|
|
|
|
|
LOP(OP_SEMCTL,XTERM); |
8506
|
|
|
|
|
|
|
8507
|
|
|
|
|
|
case KEY_semget: |
8508
|
104
|
|
|
|
|
LOP(OP_SEMGET,XTERM); |
8509
|
|
|
|
|
|
|
8510
|
|
|
|
|
|
case KEY_semop: |
8511
|
102
|
|
|
|
|
LOP(OP_SEMOP,XTERM); |
8512
|
|
|
|
|
|
|
8513
|
|
|
|
|
|
case KEY_send: |
8514
|
522
|
|
|
|
|
LOP(OP_SEND,XTERM); |
8515
|
|
|
|
|
|
|
8516
|
|
|
|
|
|
case KEY_setpgrp: |
8517
|
8
|
|
|
|
|
LOP(OP_SETPGRP,XTERM); |
8518
|
|
|
|
|
|
|
8519
|
|
|
|
|
|
case KEY_setpriority: |
8520
|
4
|
|
|
|
|
LOP(OP_SETPRIORITY,XTERM); |
8521
|
|
|
|
|
|
|
8522
|
|
|
|
|
|
case KEY_sethostent: |
8523
|
6
|
100
|
|
|
|
UNI(OP_SHOSTENT); |
|
|
50
|
|
|
|
|
8524
|
|
|
|
|
|
|
8525
|
|
|
|
|
|
case KEY_setnetent: |
8526
|
6
|
100
|
|
|
|
UNI(OP_SNETENT); |
|
|
50
|
|
|
|
|
8527
|
|
|
|
|
|
|
8528
|
|
|
|
|
|
case KEY_setservent: |
8529
|
6
|
100
|
|
|
|
UNI(OP_SSERVENT); |
|
|
50
|
|
|
|
|
8530
|
|
|
|
|
|
|
8531
|
|
|
|
|
|
case KEY_setprotoent: |
8532
|
6
|
100
|
|
|
|
UNI(OP_SPROTOENT); |
|
|
50
|
|
|
|
|
8533
|
|
|
|
|
|
|
8534
|
|
|
|
|
|
case KEY_setpwent: |
8535
|
14
|
|
|
|
|
FUN0(OP_SPWENT); |
8536
|
|
|
|
|
|
|
8537
|
|
|
|
|
|
case KEY_setgrent: |
8538
|
12
|
|
|
|
|
FUN0(OP_SGRENT); |
8539
|
|
|
|
|
|
|
8540
|
|
|
|
|
|
case KEY_seekdir: |
8541
|
54
|
|
|
|
|
LOP(OP_SEEKDIR,XTERM); |
8542
|
|
|
|
|
|
|
8543
|
|
|
|
|
|
case KEY_setsockopt: |
8544
|
522
|
|
|
|
|
LOP(OP_SSOCKOPT,XTERM); |
8545
|
|
|
|
|
|
|
8546
|
|
|
|
|
|
case KEY_shift: |
8547
|
3309389
|
100
|
|
|
|
UNIDOR(OP_SHIFT); |
|
|
100
|
|
|
|
|
8548
|
|
|
|
|
|
|
8549
|
|
|
|
|
|
case KEY_shmctl: |
8550
|
108
|
|
|
|
|
LOP(OP_SHMCTL,XTERM); |
8551
|
|
|
|
|
|
|
8552
|
|
|
|
|
|
case KEY_shmget: |
8553
|
106
|
|
|
|
|
LOP(OP_SHMGET,XTERM); |
8554
|
|
|
|
|
|
|
8555
|
|
|
|
|
|
case KEY_shmread: |
8556
|
112
|
|
|
|
|
LOP(OP_SHMREAD,XTERM); |
8557
|
|
|
|
|
|
|
8558
|
|
|
|
|
|
case KEY_shmwrite: |
8559
|
18
|
|
|
|
|
LOP(OP_SHMWRITE,XTERM); |
8560
|
|
|
|
|
|
|
8561
|
|
|
|
|
|
case KEY_shutdown: |
8562
|
1222
|
|
|
|
|
LOP(OP_SHUTDOWN,XTERM); |
8563
|
|
|
|
|
|
|
8564
|
|
|
|
|
|
case KEY_sin: |
8565
|
9668
|
100
|
|
|
|
UNI(OP_SIN); |
|
|
50
|
|
|
|
|
8566
|
|
|
|
|
|
|
8567
|
|
|
|
|
|
case KEY_sleep: |
8568
|
4508
|
100
|
|
|
|
UNI(OP_SLEEP); |
|
|
100
|
|
|
|
|
8569
|
|
|
|
|
|
|
8570
|
|
|
|
|
|
case KEY_socket: |
8571
|
272
|
|
|
|
|
LOP(OP_SOCKET,XTERM); |
8572
|
|
|
|
|
|
|
8573
|
|
|
|
|
|
case KEY_socketpair: |
8574
|
2178
|
|
|
|
|
LOP(OP_SOCKPAIR,XTERM); |
8575
|
|
|
|
|
|
|
8576
|
|
|
|
|
|
case KEY_sort: |
8577
|
239572
|
|
|
|
|
checkcomma(s,PL_tokenbuf,"subroutine name"); |
8578
|
239572
|
|
|
|
|
s = SKIPSPACE1(s); |
8579
|
239572
|
|
|
|
|
PL_expect = XTERM; |
8580
|
239572
|
|
|
|
|
s = force_word(s,WORD,TRUE,TRUE); |
8581
|
239572
|
|
|
|
|
LOP(OP_SORT,XREF); |
8582
|
|
|
|
|
|
|
8583
|
|
|
|
|
|
case KEY_split: |
8584
|
325600
|
|
|
|
|
LOP(OP_SPLIT,XTERM); |
8585
|
|
|
|
|
|
|
8586
|
|
|
|
|
|
case KEY_sprintf: |
8587
|
405821
|
|
|
|
|
LOP(OP_SPRINTF,XTERM); |
8588
|
|
|
|
|
|
|
8589
|
|
|
|
|
|
case KEY_splice: |
8590
|
87536
|
|
|
|
|
LOP(OP_SPLICE,XTERM); |
8591
|
|
|
|
|
|
|
8592
|
|
|
|
|
|
case KEY_sqrt: |
8593
|
1562
|
100
|
|
|
|
UNI(OP_SQRT); |
|
|
100
|
|
|
|
|
8594
|
|
|
|
|
|
|
8595
|
|
|
|
|
|
case KEY_srand: |
8596
|
70
|
100
|
|
|
|
UNI(OP_SRAND); |
|
|
50
|
|
|
|
|
8597
|
|
|
|
|
|
|
8598
|
|
|
|
|
|
case KEY_stat: |
8599
|
154208
|
100
|
|
|
|
UNI(OP_STAT); |
|
|
50
|
|
|
|
|
8600
|
|
|
|
|
|
|
8601
|
|
|
|
|
|
case KEY_study: |
8602
|
37170
|
100
|
|
|
|
UNI(OP_STUDY); |
|
|
50
|
|
|
|
|
8603
|
|
|
|
|
|
|
8604
|
|
|
|
|
|
case KEY_substr: |
8605
|
575203
|
|
|
|
|
LOP(OP_SUBSTR,XTERM); |
8606
|
|
|
|
|
|
|
8607
|
|
|
|
|
|
case KEY_format: |
8608
|
|
|
|
|
|
case KEY_sub: |
8609
|
|
|
|
|
|
really_sub: |
8610
|
|
|
|
|
|
{ |
8611
|
9565790
|
|
|
|
|
char * const tmpbuf = PL_tokenbuf + 1; |
8612
|
|
|
|
|
|
expectation attrful; |
8613
|
|
|
|
|
|
bool have_name, have_proto; |
8614
|
|
|
|
|
|
const int key = tmp; |
8615
|
|
|
|
|
|
#ifndef PERL_MAD |
8616
|
|
|
|
|
|
SV *format_name = NULL; |
8617
|
|
|
|
|
|
#endif |
8618
|
|
|
|
|
|
|
8619
|
|
|
|
|
|
#ifdef PERL_MAD |
8620
|
|
|
|
|
|
SV *tmpwhite = 0; |
8621
|
|
|
|
|
|
|
8622
|
|
|
|
|
|
char *tstart = SvPVX(PL_linestr) + PL_realtokenstart; |
8623
|
|
|
|
|
|
SV *subtoken = PL_madskills |
8624
|
|
|
|
|
|
? newSVpvn_flags(tstart, s - tstart, SvUTF8(PL_linestr)) |
8625
|
|
|
|
|
|
: NULL; |
8626
|
|
|
|
|
|
PL_thistoken = 0; |
8627
|
|
|
|
|
|
|
8628
|
|
|
|
|
|
d = s; |
8629
|
|
|
|
|
|
s = SKIPSPACE2(s,tmpwhite); |
8630
|
|
|
|
|
|
#else |
8631
|
|
|
|
|
|
d = s; |
8632
|
9565790
|
|
|
|
|
s = skipspace(s); |
8633
|
|
|
|
|
|
#endif |
8634
|
|
|
|
|
|
|
8635
|
9864377
|
100
|
|
|
|
if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' || |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
8636
|
298651
|
100
|
|
|
|
(*s == ':' && s[1] == ':')) |
8637
|
|
|
|
|
|
{ |
8638
|
|
|
|
|
|
#ifdef PERL_MAD |
8639
|
|
|
|
|
|
SV *nametoke = NULL; |
8640
|
|
|
|
|
|
#endif |
8641
|
|
|
|
|
|
|
8642
|
8948104
|
|
|
|
|
PL_expect = XBLOCK; |
8643
|
|
|
|
|
|
attrful = XATTRBLOCK; |
8644
|
8948104
|
|
|
|
|
d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE, |
8645
|
|
|
|
|
|
&len); |
8646
|
|
|
|
|
|
#ifdef PERL_MAD |
8647
|
|
|
|
|
|
if (PL_madskills) |
8648
|
|
|
|
|
|
nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr)); |
8649
|
|
|
|
|
|
#else |
8650
|
8948104
|
100
|
|
|
|
if (key == KEY_format) |
8651
|
260
|
|
|
|
|
format_name = S_newSV_maybe_utf8(aTHX_ s, d - s); |
8652
|
|
|
|
|
|
#endif |
8653
|
8948104
|
|
|
|
|
*PL_tokenbuf = '&'; |
8654
|
8948104
|
100
|
|
|
|
if (memchr(tmpbuf, ':', len) || key != KEY_sub |
8655
|
8411722
|
50
|
|
|
|
|| pad_findmy_pvn( |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
8656
|
|
|
|
|
|
PL_tokenbuf, len + 1, UTF ? SVf_UTF8 : 0 |
8657
|
|
|
|
|
|
) != NOT_IN_PAD) |
8658
|
536446
|
|
|
|
|
sv_setpvn(PL_subname, tmpbuf, len); |
8659
|
|
|
|
|
|
else { |
8660
|
8411658
|
|
|
|
|
sv_setsv(PL_subname,PL_curstname); |
8661
|
8411658
|
|
|
|
|
sv_catpvs(PL_subname,"::"); |
8662
|
8411658
|
|
|
|
|
sv_catpvn(PL_subname,tmpbuf,len); |
8663
|
|
|
|
|
|
} |
8664
|
8948104
|
100
|
|
|
|
if (SvUTF8(PL_linestr)) |
8665
|
74
|
|
|
|
|
SvUTF8_on(PL_subname); |
8666
|
|
|
|
|
|
have_name = TRUE; |
8667
|
|
|
|
|
|
|
8668
|
|
|
|
|
|
|
8669
|
|
|
|
|
|
#ifdef PERL_MAD |
8670
|
|
|
|
|
|
start_force(0); |
8671
|
|
|
|
|
|
CURMAD('X', nametoke); |
8672
|
|
|
|
|
|
CURMAD('_', tmpwhite); |
8673
|
|
|
|
|
|
force_ident_maybe_lex('&'); |
8674
|
|
|
|
|
|
|
8675
|
|
|
|
|
|
s = SKIPSPACE2(d,tmpwhite); |
8676
|
|
|
|
|
|
#else |
8677
|
8948104
|
|
|
|
|
s = skipspace(d); |
8678
|
|
|
|
|
|
#endif |
8679
|
|
|
|
|
|
} |
8680
|
|
|
|
|
|
else { |
8681
|
617686
|
100
|
|
|
|
if (key == KEY_my || key == KEY_our || key==KEY_state) |
|
|
100
|
|
|
|
|
8682
|
|
|
|
|
|
{ |
8683
|
6
|
|
|
|
|
*d = '\0'; |
8684
|
|
|
|
|
|
/* diag_listed_as: Missing name in "%s sub" */ |
8685
|
6
|
|
|
|
|
Perl_croak(aTHX_ |
8686
|
6
|
|
|
|
|
"Missing name in \"%s\"", PL_bufptr); |
8687
|
|
|
|
|
|
} |
8688
|
617680
|
|
|
|
|
PL_expect = XTERMBLOCK; |
8689
|
|
|
|
|
|
attrful = XATTRTERM; |
8690
|
617680
|
|
|
|
|
sv_setpvs(PL_subname,"?"); |
8691
|
|
|
|
|
|
have_name = FALSE; |
8692
|
|
|
|
|
|
} |
8693
|
|
|
|
|
|
|
8694
|
9565784
|
100
|
|
|
|
if (key == KEY_format) { |
8695
|
|
|
|
|
|
#ifdef PERL_MAD |
8696
|
|
|
|
|
|
PL_thistoken = subtoken; |
8697
|
|
|
|
|
|
s = d; |
8698
|
|
|
|
|
|
#else |
8699
|
298
|
100
|
|
|
|
if (format_name) { |
8700
|
|
|
|
|
|
start_force(PL_curforce); |
8701
|
260
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval |
8702
|
260
|
|
|
|
|
= (OP*)newSVOP(OP_CONST,0, format_name); |
8703
|
260
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE; |
8704
|
260
|
|
|
|
|
force_next(WORD); |
8705
|
|
|
|
|
|
} |
8706
|
|
|
|
|
|
#endif |
8707
|
298
|
|
|
|
|
PREBLOCK(FORMAT); |
8708
|
|
|
|
|
|
} |
8709
|
|
|
|
|
|
|
8710
|
|
|
|
|
|
/* Look for a prototype */ |
8711
|
9565486
|
100
|
|
|
|
if (*s == '(') { |
8712
|
519948
|
|
|
|
|
s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); |
8713
|
519948
|
100
|
|
|
|
COPLINE_SET_FROM_MULTI_END; |
8714
|
519948
|
100
|
|
|
|
if (!s) |
8715
|
4
|
|
|
|
|
Perl_croak(aTHX_ "Prototype not terminated"); |
8716
|
519944
|
|
|
|
|
(void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO)); |
8717
|
|
|
|
|
|
have_proto = TRUE; |
8718
|
|
|
|
|
|
|
8719
|
|
|
|
|
|
#ifdef PERL_MAD |
8720
|
|
|
|
|
|
start_force(0); |
8721
|
|
|
|
|
|
CURMAD('q', PL_thisopen); |
8722
|
|
|
|
|
|
CURMAD('_', tmpwhite); |
8723
|
|
|
|
|
|
CURMAD('=', PL_thisstuff); |
8724
|
|
|
|
|
|
CURMAD('Q', PL_thisclose); |
8725
|
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval = |
8726
|
|
|
|
|
|
(OP*)newSVOP(OP_CONST, 0, PL_lex_stuff); |
8727
|
|
|
|
|
|
PL_lex_stuff = NULL; |
8728
|
|
|
|
|
|
force_next(THING); |
8729
|
|
|
|
|
|
|
8730
|
|
|
|
|
|
s = SKIPSPACE2(s,tmpwhite); |
8731
|
|
|
|
|
|
#else |
8732
|
519944
|
|
|
|
|
s = skipspace(s); |
8733
|
|
|
|
|
|
#endif |
8734
|
|
|
|
|
|
} |
8735
|
|
|
|
|
|
else |
8736
|
|
|
|
|
|
have_proto = FALSE; |
8737
|
|
|
|
|
|
|
8738
|
9565482
|
100
|
|
|
|
if (*s == ':' && s[1] != ':') |
|
|
50
|
|
|
|
|
8739
|
5920
|
|
|
|
|
PL_expect = attrful; |
8740
|
9559562
|
100
|
|
|
|
else if (*s != '{' && key == KEY_sub) { |
8741
|
390389
|
100
|
|
|
|
if (!have_name) |
8742
|
16
|
|
|
|
|
Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine"); |
8743
|
390373
|
100
|
|
|
|
else if (*s != ';' && *s != '}') |
8744
|
4
|
|
|
|
|
Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname)); |
8745
|
|
|
|
|
|
} |
8746
|
|
|
|
|
|
|
8747
|
|
|
|
|
|
#ifdef PERL_MAD |
8748
|
|
|
|
|
|
start_force(0); |
8749
|
|
|
|
|
|
if (tmpwhite) { |
8750
|
|
|
|
|
|
if (PL_madskills) |
8751
|
|
|
|
|
|
curmad('^', newSVpvs("")); |
8752
|
|
|
|
|
|
CURMAD('_', tmpwhite); |
8753
|
|
|
|
|
|
} |
8754
|
|
|
|
|
|
force_next(0); |
8755
|
|
|
|
|
|
|
8756
|
|
|
|
|
|
PL_thistoken = subtoken; |
8757
|
|
|
|
|
|
PERL_UNUSED_VAR(have_proto); |
8758
|
|
|
|
|
|
#else |
8759
|
9565462
|
100
|
|
|
|
if (have_proto) { |
8760
|
1039880
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval = |
8761
|
519940
|
|
|
|
|
(OP*)newSVOP(OP_CONST, 0, PL_lex_stuff); |
8762
|
519940
|
|
|
|
|
PL_lex_stuff = NULL; |
8763
|
519940
|
|
|
|
|
force_next(THING); |
8764
|
|
|
|
|
|
} |
8765
|
|
|
|
|
|
#endif |
8766
|
9565462
|
100
|
|
|
|
if (!have_name) { |
8767
|
617626
|
50
|
|
|
|
if (PL_curstash) |
8768
|
617626
|
|
|
|
|
sv_setpvs(PL_subname, "__ANON__"); |
8769
|
|
|
|
|
|
else |
8770
|
0
|
|
|
|
|
sv_setpvs(PL_subname, "__ANON__::__ANON__"); |
8771
|
617626
|
|
|
|
|
TOKEN(ANONSUB); |
8772
|
|
|
|
|
|
} |
8773
|
|
|
|
|
|
#ifndef PERL_MAD |
8774
|
8947836
|
|
|
|
|
force_ident_maybe_lex('&'); |
8775
|
|
|
|
|
|
#endif |
8776
|
8947836
|
|
|
|
|
TOKEN(SUB); |
8777
|
|
|
|
|
|
} |
8778
|
|
|
|
|
|
|
8779
|
|
|
|
|
|
case KEY_system: |
8780
|
12466
|
|
|
|
|
LOP(OP_SYSTEM,XREF); |
8781
|
|
|
|
|
|
|
8782
|
|
|
|
|
|
case KEY_symlink: |
8783
|
154
|
|
|
|
|
LOP(OP_SYMLINK,XTERM); |
8784
|
|
|
|
|
|
|
8785
|
|
|
|
|
|
case KEY_syscall: |
8786
|
32
|
|
|
|
|
LOP(OP_SYSCALL,XTERM); |
8787
|
|
|
|
|
|
|
8788
|
|
|
|
|
|
case KEY_sysopen: |
8789
|
2084
|
|
|
|
|
LOP(OP_SYSOPEN,XTERM); |
8790
|
|
|
|
|
|
|
8791
|
|
|
|
|
|
case KEY_sysseek: |
8792
|
1222
|
|
|
|
|
LOP(OP_SYSSEEK,XTERM); |
8793
|
|
|
|
|
|
|
8794
|
|
|
|
|
|
case KEY_sysread: |
8795
|
11563
|
|
|
|
|
LOP(OP_SYSREAD,XTERM); |
8796
|
|
|
|
|
|
|
8797
|
|
|
|
|
|
case KEY_syswrite: |
8798
|
7720
|
|
|
|
|
LOP(OP_SYSWRITE,XTERM); |
8799
|
|
|
|
|
|
|
8800
|
|
|
|
|
|
case KEY_tr: |
8801
|
|
|
|
|
|
case KEY_y: |
8802
|
109274
|
|
|
|
|
s = scan_trans(s); |
8803
|
109250
|
|
|
|
|
TERM(sublex_start()); |
8804
|
|
|
|
|
|
|
8805
|
|
|
|
|
|
case KEY_tell: |
8806
|
3776
|
100
|
|
|
|
UNI(OP_TELL); |
|
|
100
|
|
|
|
|
8807
|
|
|
|
|
|
|
8808
|
|
|
|
|
|
case KEY_telldir: |
8809
|
60
|
100
|
|
|
|
UNI(OP_TELLDIR); |
|
|
50
|
|
|
|
|
8810
|
|
|
|
|
|
|
8811
|
|
|
|
|
|
case KEY_tie: |
8812
|
21402
|
|
|
|
|
LOP(OP_TIE,XTERM); |
8813
|
|
|
|
|
|
|
8814
|
|
|
|
|
|
case KEY_tied: |
8815
|
8482
|
100
|
|
|
|
UNI(OP_TIED); |
|
|
50
|
|
|
|
|
8816
|
|
|
|
|
|
|
8817
|
|
|
|
|
|
case KEY_time: |
8818
|
20570
|
|
|
|
|
FUN0(OP_TIME); |
8819
|
|
|
|
|
|
|
8820
|
|
|
|
|
|
case KEY_times: |
8821
|
5604
|
|
|
|
|
FUN0(OP_TMS); |
8822
|
|
|
|
|
|
|
8823
|
|
|
|
|
|
case KEY_truncate: |
8824
|
6623
|
|
|
|
|
LOP(OP_TRUNCATE,XTERM); |
8825
|
|
|
|
|
|
|
8826
|
|
|
|
|
|
case KEY_uc: |
8827
|
52508
|
100
|
|
|
|
UNI(OP_UC); |
|
|
100
|
|
|
|
|
8828
|
|
|
|
|
|
|
8829
|
|
|
|
|
|
case KEY_ucfirst: |
8830
|
7380
|
100
|
|
|
|
UNI(OP_UCFIRST); |
|
|
100
|
|
|
|
|
8831
|
|
|
|
|
|
|
8832
|
|
|
|
|
|
case KEY_untie: |
8833
|
2082
|
100
|
|
|
|
UNI(OP_UNTIE); |
|
|
50
|
|
|
|
|
8834
|
|
|
|
|
|
|
8835
|
|
|
|
|
|
case KEY_until: |
8836
|
15192
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR) |
|
|
50
|
|
|
|
|
8837
|
|
|
|
|
|
return REPORT(0); |
8838
|
15192
|
|
|
|
|
pl_yylval.ival = CopLINE(PL_curcop); |
8839
|
15192
|
|
|
|
|
OPERATOR(UNTIL); |
8840
|
|
|
|
|
|
|
8841
|
|
|
|
|
|
case KEY_unless: |
8842
|
3346816
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR) |
|
|
50
|
|
|
|
|
8843
|
|
|
|
|
|
return REPORT(0); |
8844
|
3346816
|
|
|
|
|
pl_yylval.ival = CopLINE(PL_curcop); |
8845
|
3346816
|
|
|
|
|
OPERATOR(UNLESS); |
8846
|
|
|
|
|
|
|
8847
|
|
|
|
|
|
case KEY_unlink: |
8848
|
61661
|
|
|
|
|
LOP(OP_UNLINK,XTERM); |
8849
|
|
|
|
|
|
|
8850
|
|
|
|
|
|
case KEY_undef: |
8851
|
868280
|
100
|
|
|
|
UNIDOR(OP_UNDEF); |
|
|
50
|
|
|
|
|
8852
|
|
|
|
|
|
|
8853
|
|
|
|
|
|
case KEY_unpack: |
8854
|
90122
|
|
|
|
|
LOP(OP_UNPACK,XTERM); |
8855
|
|
|
|
|
|
|
8856
|
|
|
|
|
|
case KEY_utime: |
8857
|
13112
|
|
|
|
|
LOP(OP_UTIME,XTERM); |
8858
|
|
|
|
|
|
|
8859
|
|
|
|
|
|
case KEY_umask: |
8860
|
3420
|
100
|
|
|
|
UNIDOR(OP_UMASK); |
|
|
100
|
|
|
|
|
8861
|
|
|
|
|
|
|
8862
|
|
|
|
|
|
case KEY_unshift: |
8863
|
156678
|
|
|
|
|
LOP(OP_UNSHIFT,XTERM); |
8864
|
|
|
|
|
|
|
8865
|
|
|
|
|
|
case KEY_use: |
8866
|
4235040
|
|
|
|
|
s = tokenize_use(1, s); |
8867
|
4235040
|
|
|
|
|
OPERATOR(USE); |
8868
|
|
|
|
|
|
|
8869
|
|
|
|
|
|
case KEY_values: |
8870
|
58113
|
100
|
|
|
|
UNI(OP_VALUES); |
|
|
100
|
|
|
|
|
8871
|
|
|
|
|
|
|
8872
|
|
|
|
|
|
case KEY_vec: |
8873
|
271486
|
|
|
|
|
LOP(OP_VEC,XTERM); |
8874
|
|
|
|
|
|
|
8875
|
|
|
|
|
|
case KEY_when: |
8876
|
432
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR) |
|
|
50
|
|
|
|
|
8877
|
|
|
|
|
|
return REPORT(0); |
8878
|
432
|
|
|
|
|
pl_yylval.ival = CopLINE(PL_curcop); |
8879
|
432
|
|
|
|
|
Perl_ck_warner_d(aTHX_ |
8880
|
|
|
|
|
|
packWARN(WARN_EXPERIMENTAL__SMARTMATCH), |
8881
|
|
|
|
|
|
"when is experimental"); |
8882
|
432
|
|
|
|
|
OPERATOR(WHEN); |
8883
|
|
|
|
|
|
|
8884
|
|
|
|
|
|
case KEY_while: |
8885
|
689160
|
100
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR) |
|
|
50
|
|
|
|
|
8886
|
|
|
|
|
|
return REPORT(0); |
8887
|
689160
|
|
|
|
|
pl_yylval.ival = CopLINE(PL_curcop); |
8888
|
689160
|
|
|
|
|
OPERATOR(WHILE); |
8889
|
|
|
|
|
|
|
8890
|
|
|
|
|
|
case KEY_warn: |
8891
|
405308
|
|
|
|
|
PL_hints |= HINT_BLOCK_SCOPE; |
8892
|
405308
|
|
|
|
|
LOP(OP_WARN,XTERM); |
8893
|
|
|
|
|
|
|
8894
|
|
|
|
|
|
case KEY_wait: |
8895
|
120
|
|
|
|
|
FUN0(OP_WAIT); |
8896
|
|
|
|
|
|
|
8897
|
|
|
|
|
|
case KEY_waitpid: |
8898
|
3420
|
|
|
|
|
LOP(OP_WAITPID,XTERM); |
8899
|
|
|
|
|
|
|
8900
|
|
|
|
|
|
case KEY_wantarray: |
8901
|
115848
|
|
|
|
|
FUN0(OP_WANTARRAY); |
8902
|
|
|
|
|
|
|
8903
|
|
|
|
|
|
case KEY_write: |
8904
|
|
|
|
|
|
/* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and |
8905
|
|
|
|
|
|
* we use the same number on EBCDIC */ |
8906
|
3314
|
|
|
|
|
gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV); |
8907
|
3314
|
100
|
|
|
|
UNI(OP_ENTERWRITE); |
|
|
100
|
|
|
|
|
8908
|
|
|
|
|
|
|
8909
|
|
|
|
|
|
case KEY_x: |
8910
|
221558
|
100
|
|
|
|
if (PL_expect == XOPERATOR) { |
8911
|
221452
|
100
|
|
|
|
if (*s == '=' && !PL_lex_allbrackets && |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
8912
|
8
|
|
|
|
|
PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) |
8913
|
|
|
|
|
|
return REPORT(0); |
8914
|
221448
|
|
|
|
|
Mop(OP_REPEAT); |
8915
|
|
|
|
|
|
} |
8916
|
110
|
|
|
|
|
check_uni(); |
8917
|
110
|
|
|
|
|
goto just_a_word; |
8918
|
|
|
|
|
|
|
8919
|
|
|
|
|
|
case KEY_xor: |
8920
|
38984
|
50
|
|
|
|
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC) |
|
|
0
|
|
|
|
|
8921
|
|
|
|
|
|
return REPORT(0); |
8922
|
38984
|
|
|
|
|
pl_yylval.ival = OP_XOR; |
8923
|
547621750
|
|
|
|
|
OPERATOR(OROP); |
8924
|
|
|
|
|
|
} |
8925
|
|
|
|
|
|
}} |
8926
|
|
|
|
|
|
} |
8927
|
|
|
|
|
|
#ifdef __SC__ |
8928
|
|
|
|
|
|
#pragma segment Main |
8929
|
|
|
|
|
|
#endif |
8930
|
|
|
|
|
|
|
8931
|
|
|
|
|
|
/* |
8932
|
|
|
|
|
|
S_pending_ident |
8933
|
|
|
|
|
|
|
8934
|
|
|
|
|
|
Looks up an identifier in the pad or in a package |
8935
|
|
|
|
|
|
|
8936
|
|
|
|
|
|
Returns: |
8937
|
|
|
|
|
|
PRIVATEREF if this is a lexical name. |
8938
|
|
|
|
|
|
WORD if this belongs to a package. |
8939
|
|
|
|
|
|
|
8940
|
|
|
|
|
|
Structure: |
8941
|
|
|
|
|
|
if we're in a my declaration |
8942
|
|
|
|
|
|
croak if they tried to say my($foo::bar) |
8943
|
|
|
|
|
|
build the ops for a my() declaration |
8944
|
|
|
|
|
|
if it's an access to a my() variable |
8945
|
|
|
|
|
|
build ops for access to a my() variable |
8946
|
|
|
|
|
|
if in a dq string, and they've said @foo and we can't find @foo |
8947
|
|
|
|
|
|
warn |
8948
|
|
|
|
|
|
build ops for a bareword |
8949
|
|
|
|
|
|
*/ |
8950
|
|
|
|
|
|
|
8951
|
|
|
|
|
|
static int |
8952
|
142444391
|
|
|
|
|
S_pending_ident(pTHX) |
8953
|
|
|
|
|
|
{ |
8954
|
|
|
|
|
|
dVAR; |
8955
|
|
|
|
|
|
PADOFFSET tmp = 0; |
8956
|
142444391
|
|
|
|
|
const char pit = (char)pl_yylval.ival; |
8957
|
142444391
|
|
|
|
|
const STRLEN tokenbuf_len = strlen(PL_tokenbuf); |
8958
|
|
|
|
|
|
/* All routes through this function want to know if there is a colon. */ |
8959
|
142444391
|
|
|
|
|
const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len); |
8960
|
|
|
|
|
|
|
8961
|
|
|
|
|
|
DEBUG_T({ PerlIO_printf(Perl_debug_log, |
8962
|
|
|
|
|
|
"### Pending identifier '%s'\n", PL_tokenbuf); }); |
8963
|
|
|
|
|
|
|
8964
|
|
|
|
|
|
/* if we're in a my(), we can't allow dynamics here. |
8965
|
|
|
|
|
|
$foo'bar has already been turned into $foo::bar, so |
8966
|
|
|
|
|
|
just check for colons. |
8967
|
|
|
|
|
|
|
8968
|
|
|
|
|
|
if it's a legal name, the OP is a PADANY. |
8969
|
|
|
|
|
|
*/ |
8970
|
142444391
|
100
|
|
|
|
if (PL_in_my) { |
8971
|
23690304
|
100
|
|
|
|
if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */ |
8972
|
1161493
|
100
|
|
|
|
if (has_colon) |
8973
|
2
|
50
|
|
|
|
yyerror_pv(Perl_form(aTHX_ "No package name allowed for " |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
8974
|
|
|
|
|
|
"variable %s in \"our\"", |
8975
|
|
|
|
|
|
PL_tokenbuf), UTF ? SVf_UTF8 : 0); |
8976
|
1161493
|
50
|
|
|
|
tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
8977
|
|
|
|
|
|
} |
8978
|
|
|
|
|
|
else { |
8979
|
22528811
|
100
|
|
|
|
if (has_colon) |
8980
|
4
|
50
|
|
|
|
yyerror_pv(Perl_form(aTHX_ PL_no_myglob, |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
8981
|
|
|
|
|
|
PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf), |
8982
|
|
|
|
|
|
UTF ? SVf_UTF8 : 0); |
8983
|
|
|
|
|
|
|
8984
|
22528811
|
|
|
|
|
pl_yylval.opval = newOP(OP_PADANY, 0); |
8985
|
22528811
|
50
|
|
|
|
pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len, |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
8986
|
|
|
|
|
|
UTF ? SVf_UTF8 : 0); |
8987
|
22528807
|
|
|
|
|
return PRIVATEREF; |
8988
|
|
|
|
|
|
} |
8989
|
|
|
|
|
|
} |
8990
|
|
|
|
|
|
|
8991
|
|
|
|
|
|
/* |
8992
|
|
|
|
|
|
build the ops for accesses to a my() variable. |
8993
|
|
|
|
|
|
*/ |
8994
|
|
|
|
|
|
|
8995
|
119915576
|
100
|
|
|
|
if (!has_colon) { |
8996
|
117716705
|
100
|
|
|
|
if (!PL_in_my) |
8997
|
116555218
|
50
|
|
|
|
tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len, |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
8998
|
|
|
|
|
|
UTF ? SVf_UTF8 : 0); |
8999
|
117716705
|
100
|
|
|
|
if (tmp != NOT_IN_PAD) { |
9000
|
|
|
|
|
|
/* might be an "our" variable" */ |
9001
|
86130860
|
100
|
|
|
|
if (PAD_COMPNAME_FLAGS_isOUR(tmp)) { |
9002
|
|
|
|
|
|
/* build ops for a bareword */ |
9003
|
3831012
|
50
|
|
|
|
HV * const stash = PAD_COMPNAME_OURSTASH(tmp); |
9004
|
3831012
|
50
|
|
|
|
HEK * const stashname = HvNAME_HEK(stash); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
9005
|
3831012
|
|
|
|
|
SV * const sym = newSVhek(stashname); |
9006
|
3831012
|
|
|
|
|
sv_catpvs(sym, "::"); |
9007
|
3831012
|
50
|
|
|
|
sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES )); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
9008
|
3831012
|
|
|
|
|
pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym); |
9009
|
3831012
|
|
|
|
|
pl_yylval.opval->op_private = OPpCONST_ENTERED; |
9010
|
3831012
|
100
|
|
|
|
if (pit != '&') |
9011
|
3830972
|
100
|
|
|
|
gv_fetchsv(sym, |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
9012
|
|
|
|
|
|
(PL_in_eval |
9013
|
|
|
|
|
|
? (GV_ADDMULTI | GV_ADDINEVAL) |
9014
|
|
|
|
|
|
: GV_ADDMULTI |
9015
|
|
|
|
|
|
), |
9016
|
|
|
|
|
|
((PL_tokenbuf[0] == '$') ? SVt_PV |
9017
|
|
|
|
|
|
: (PL_tokenbuf[0] == '@') ? SVt_PVAV |
9018
|
|
|
|
|
|
: SVt_PVHV)); |
9019
|
|
|
|
|
|
return WORD; |
9020
|
|
|
|
|
|
} |
9021
|
|
|
|
|
|
|
9022
|
82299848
|
|
|
|
|
pl_yylval.opval = newOP(OP_PADANY, 0); |
9023
|
82299848
|
|
|
|
|
pl_yylval.opval->op_targ = tmp; |
9024
|
82299848
|
|
|
|
|
return PRIVATEREF; |
9025
|
|
|
|
|
|
} |
9026
|
|
|
|
|
|
} |
9027
|
|
|
|
|
|
|
9028
|
|
|
|
|
|
/* |
9029
|
|
|
|
|
|
Whine if they've said @foo in a doublequoted string, |
9030
|
|
|
|
|
|
and @foo isn't a variable we can find in the symbol |
9031
|
|
|
|
|
|
table. |
9032
|
|
|
|
|
|
*/ |
9033
|
33784716
|
100
|
|
|
|
if (ckWARN(WARN_AMBIGUOUS) && |
|
|
100
|
|
|
|
|
9034
|
1936768
|
100
|
|
|
|
pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) { |
|
|
100
|
|
|
|
|
9035
|
12058
|
50
|
|
|
|
GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1, |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
9036
|
|
|
|
|
|
( UTF ? SVf_UTF8 : 0 ), SVt_PVAV); |
9037
|
12058
|
100
|
|
|
|
if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
9038
|
|
|
|
|
|
/* DO NOT warn for @- and @+ */ |
9039
|
24
|
100
|
|
|
|
&& !( PL_tokenbuf[2] == '\0' && |
|
|
100
|
|
|
|
|
9040
|
12
|
|
|
|
|
( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' )) |
9041
|
|
|
|
|
|
) |
9042
|
|
|
|
|
|
{ |
9043
|
|
|
|
|
|
/* Downgraded from fatal to warning 20000522 mjd */ |
9044
|
20
|
50
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), |
|
|
50
|
|
|
|
|
9045
|
|
|
|
|
|
"Possible unintended interpolation of %"UTF8f |
9046
|
|
|
|
|
|
" in string", |
9047
|
16
|
100
|
|
|
|
UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf)); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
9048
|
|
|
|
|
|
} |
9049
|
|
|
|
|
|
} |
9050
|
|
|
|
|
|
|
9051
|
|
|
|
|
|
/* build ops for a bareword */ |
9052
|
33784716
|
50
|
|
|
|
pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
9053
|
|
|
|
|
|
newSVpvn_flags(PL_tokenbuf + 1, |
9054
|
|
|
|
|
|
tokenbuf_len - 1, |
9055
|
|
|
|
|
|
UTF ? SVf_UTF8 : 0 )); |
9056
|
33784716
|
|
|
|
|
pl_yylval.opval->op_private = OPpCONST_ENTERED; |
9057
|
33784716
|
100
|
|
|
|
if (pit != '&') |
9058
|
84650408
|
100
|
|
|
|
gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1, |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
9059
|
|
|
|
|
|
(PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD) |
9060
|
|
|
|
|
|
| ( UTF ? SVf_UTF8 : 0 ), |
9061
|
|
|
|
|
|
((PL_tokenbuf[0] == '$') ? SVt_PV |
9062
|
|
|
|
|
|
: (PL_tokenbuf[0] == '@') ? SVt_PVAV |
9063
|
|
|
|
|
|
: SVt_PVHV)); |
9064
|
|
|
|
|
|
return WORD; |
9065
|
|
|
|
|
|
} |
9066
|
|
|
|
|
|
|
9067
|
|
|
|
|
|
STATIC void |
9068
|
1572116
|
|
|
|
|
S_checkcomma(pTHX_ const char *s, const char *name, const char *what) |
9069
|
|
|
|
|
|
{ |
9070
|
|
|
|
|
|
dVAR; |
9071
|
|
|
|
|
|
|
9072
|
|
|
|
|
|
PERL_ARGS_ASSERT_CHECKCOMMA; |
9073
|
|
|
|
|
|
|
9074
|
1572116
|
100
|
|
|
|
if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ |
|
|
100
|
|
|
|
|
9075
|
444
|
100
|
|
|
|
if (ckWARN(WARN_SYNTAX)) { |
9076
|
|
|
|
|
|
int level = 1; |
9077
|
|
|
|
|
|
const char *w; |
9078
|
7308
|
100
|
|
|
|
for (w = s+2; *w && level; w++) { |
9079
|
7134
|
100
|
|
|
|
if (*w == '(') |
9080
|
132
|
|
|
|
|
++level; |
9081
|
7002
|
100
|
|
|
|
else if (*w == ')') |
9082
|
306
|
|
|
|
|
--level; |
9083
|
|
|
|
|
|
} |
9084
|
188
|
100
|
|
|
|
while (isSPACE(*w)) |
9085
|
14
|
|
|
|
|
++w; |
9086
|
|
|
|
|
|
/* the list of chars below is for end of statements or |
9087
|
|
|
|
|
|
* block / parens, boolean operators (&&, ||, //) and branch |
9088
|
|
|
|
|
|
* constructs (or, and, if, until, unless, while, err, for). |
9089
|
|
|
|
|
|
* Not a very solid hack... */ |
9090
|
174
|
50
|
|
|
|
if (!*w || !strchr(";&/|})]oaiuwef!=", *w)) |
|
|
100
|
|
|
|
|
9091
|
847432
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), |
9092
|
|
|
|
|
|
"%s (...) interpreted as function",name); |
9093
|
|
|
|
|
|
} |
9094
|
|
|
|
|
|
} |
9095
|
3139818
|
100
|
|
|
|
while (s < PL_bufend && isSPACE(*s)) |
|
|
100
|
|
|
|
|
9096
|
1567702
|
|
|
|
|
s++; |
9097
|
1572116
|
100
|
|
|
|
if (*s == '(') |
9098
|
871734
|
|
|
|
|
s++; |
9099
|
1578082
|
100
|
|
|
|
while (s < PL_bufend && isSPACE(*s)) |
|
|
100
|
|
|
|
|
9100
|
5966
|
|
|
|
|
s++; |
9101
|
1572116
|
100
|
|
|
|
if (isIDFIRST_lazy_if(s,UTF)) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
9102
|
|
|
|
|
|
const char * const w = s; |
9103
|
525413
|
50
|
|
|
|
s += UTF ? UTF8SKIP(s) : 1; |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
9104
|
2867518
|
100
|
|
|
|
while (isWORDCHAR_lazy_if(s,UTF)) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
9105
|
2092896
|
50
|
|
|
|
s += UTF ? UTF8SKIP(s) : 1; |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
9106
|
996371
|
100
|
|
|
|
while (s < PL_bufend && isSPACE(*s)) |
|
|
100
|
|
|
|
|
9107
|
470958
|
|
|
|
|
s++; |
9108
|
525413
|
100
|
|
|
|
if (*s == ',') { |
9109
|
|
|
|
|
|
GV* gv; |
9110
|
2222
|
100
|
|
|
|
if (keyword(w, s - w, 0)) |
9111
|
|
|
|
|
|
return; |
9112
|
|
|
|
|
|
|
9113
|
10
|
50
|
|
|
|
gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
9114
|
10
|
50
|
|
|
|
if (gv && GvCVu(gv)) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
9115
|
|
|
|
|
|
return; |
9116
|
847430
|
|
|
|
|
Perl_croak(aTHX_ "No comma allowed after %s", what); |
9117
|
|
|
|
|
|
} |
9118
|
|
|
|
|
|
} |
9119
|
|
|
|
|
|
} |
9120
|
|
|
|
|
|
|
9121
|
|
|
|
|
|
/* S_new_constant(): do any overload::constant lookup. |
9122
|
|
|
|
|
|
|
9123
|
|
|
|
|
|
Either returns sv, or mortalizes/frees sv and returns a new SV*. |
9124
|
|
|
|
|
|
Best used as sv=new_constant(..., sv, ...). |
9125
|
|
|
|
|
|
If s, pv are NULL, calls subroutine with one argument, |
9126
|
|
|
|
|
|
and is used with error messages only. |
9127
|
|
|
|
|
|
is assumed to be well formed UTF-8 */ |
9128
|
|
|
|
|
|
|
9129
|
|
|
|
|
|
STATIC SV * |
9130
|
3218
|
|
|
|
|
S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, |
9131
|
|
|
|
|
|
SV *sv, SV *pv, const char *type, STRLEN typelen) |
9132
|
3070
|
50
|
|
|
|
{ |
9133
|
3218
|
|
|
|
|
dVAR; dSP; |
9134
|
3218
|
|
|
|
|
HV * table = GvHV(PL_hintgv); /* ^H */ |
9135
|
|
|
|
|
|
SV *res; |
9136
|
|
|
|
|
|
SV *errsv = NULL; |
9137
|
|
|
|
|
|
SV **cvp; |
9138
|
|
|
|
|
|
SV *cv, *typesv; |
9139
|
|
|
|
|
|
const char *why1 = "", *why2 = "", *why3 = ""; |
9140
|
|
|
|
|
|
|
9141
|
|
|
|
|
|
PERL_ARGS_ASSERT_NEW_CONSTANT; |
9142
|
|
|
|
|
|
/* We assume that this is true: */ |
9143
|
|
|
|
|
|
if (*key == 'c') { assert (strEQ(key, "charnames")); } |
9144
|
|
|
|
|
|
assert(type || s); |
9145
|
|
|
|
|
|
|
9146
|
|
|
|
|
|
/* charnames doesn't work well if there have been errors found */ |
9147
|
3218
|
100
|
|
|
|
if (PL_error_count > 0 && *key == 'c') |
|
|
100
|
|
|
|
|
9148
|
|
|
|
|
|
{ |
9149
|
|
|
|
|
|
SvREFCNT_dec_NN(sv); |
9150
|
|
|
|
|
|
return &PL_sv_undef; |
9151
|
|
|
|
|
|
} |
9152
|
|
|
|
|
|
|
9153
|
3172
|
|
|
|
|
sv_2mortal(sv); /* Parent created it permanently */ |
9154
|
3172
|
100
|
|
|
|
if (!table |
9155
|
3154
|
100
|
|
|
|
|| ! (PL_hints & HINT_LOCALIZE_HH) |
9156
|
3012
|
100
|
|
|
|
|| ! (cvp = hv_fetch(table, key, keylen, FALSE)) |
9157
|
2970
|
50
|
|
|
|
|| ! SvOK(*cvp)) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
9158
|
|
|
|
|
|
{ |
9159
|
|
|
|
|
|
char *msg; |
9160
|
|
|
|
|
|
|
9161
|
|
|
|
|
|
/* Here haven't found what we're looking for. If it is charnames, |
9162
|
|
|
|
|
|
* perhaps it needs to be loaded. Try doing that before giving up */ |
9163
|
202
|
100
|
|
|
|
if (*key == 'c') { |
9164
|
104
|
|
|
|
|
Perl_load_module(aTHX_ |
9165
|
|
|
|
|
|
0, |
9166
|
|
|
|
|
|
newSVpvs("_charnames"), |
9167
|
|
|
|
|
|
/* version parameter; no need to specify it, as if |
9168
|
|
|
|
|
|
* we get too early a version, will fail anyway, |
9169
|
|
|
|
|
|
* not being able to find '_charnames' */ |
9170
|
|
|
|
|
|
NULL, |
9171
|
|
|
|
|
|
newSVpvs(":full"), |
9172
|
|
|
|
|
|
newSVpvs(":short"), |
9173
|
|
|
|
|
|
NULL); |
9174
|
104
|
|
|
|
|
SPAGAIN; |
9175
|
104
|
|
|
|
|
table = GvHV(PL_hintgv); |
9176
|
104
|
50
|
|
|
|
if (table |
9177
|
104
|
100
|
|
|
|
&& (PL_hints & HINT_LOCALIZE_HH) |
9178
|
100
|
50
|
|
|
|
&& (cvp = hv_fetch(table, key, keylen, FALSE)) |
9179
|
100
|
50
|
|
|
|
&& SvOK(*cvp)) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
9180
|
|
|
|
|
|
{ |
9181
|
|
|
|
|
|
goto now_ok; |
9182
|
|
|
|
|
|
} |
9183
|
|
|
|
|
|
} |
9184
|
102
|
100
|
|
|
|
if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { |
|
|
100
|
|
|
|
|
9185
|
62
|
100
|
|
|
|
msg = Perl_form(aTHX_ |
|
|
100
|
|
|
|
|
9186
|
|
|
|
|
|
"Constant(%.*s) unknown", |
9187
|
|
|
|
|
|
(int)(type ? typelen : len), |
9188
|
|
|
|
|
|
(type ? type: s)); |
9189
|
|
|
|
|
|
} |
9190
|
|
|
|
|
|
else { |
9191
|
|
|
|
|
|
why1 = "$^H{"; |
9192
|
|
|
|
|
|
why2 = key; |
9193
|
|
|
|
|
|
why3 = "} is not defined"; |
9194
|
|
|
|
|
|
report: |
9195
|
162
|
100
|
|
|
|
if (*key == 'c') { |
9196
|
96
|
|
|
|
|
msg = Perl_form(aTHX_ |
9197
|
|
|
|
|
|
/* The +3 is for '\N{'; -4 for that, plus '}' */ |
9198
|
64
|
|
|
|
|
"Unknown charname '%.*s'", (int)typelen - 4, type + 3 |
9199
|
|
|
|
|
|
); |
9200
|
|
|
|
|
|
} |
9201
|
|
|
|
|
|
else { |
9202
|
98
|
100
|
|
|
|
msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s", |
|
|
100
|
|
|
|
|
9203
|
|
|
|
|
|
(int)(type ? typelen : len), |
9204
|
|
|
|
|
|
(type ? type: s), why1, why2, why3); |
9205
|
|
|
|
|
|
} |
9206
|
|
|
|
|
|
} |
9207
|
224
|
50
|
|
|
|
yyerror_pv(msg, UTF ? SVf_UTF8 : 0); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
9208
|
212
|
|
|
|
|
return SvREFCNT_inc_simple_NN(sv); |
9209
|
|
|
|
|
|
} |
9210
|
|
|
|
|
|
now_ok: |
9211
|
3070
|
|
|
|
|
cv = *cvp; |
9212
|
3070
|
100
|
|
|
|
if (!pv && s) |
9213
|
542
|
|
|
|
|
pv = newSVpvn_flags(s, len, SVs_TEMP); |
9214
|
3070
|
100
|
|
|
|
if (type && pv) |
9215
|
78
|
|
|
|
|
typesv = newSVpvn_flags(type, typelen, SVs_TEMP); |
9216
|
|
|
|
|
|
else |
9217
|
|
|
|
|
|
typesv = &PL_sv_undef; |
9218
|
|
|
|
|
|
|
9219
|
3070
|
100
|
|
|
|
PUSHSTACKi(PERLSI_OVERLOAD); |
9220
|
3070
|
|
|
|
|
ENTER ; |
9221
|
3070
|
|
|
|
|
SAVETMPS; |
9222
|
|
|
|
|
|
|
9223
|
3070
|
50
|
|
|
|
PUSHMARK(SP) ; |
9224
|
1535
|
|
|
|
|
EXTEND(sp, 3); |
9225
|
3070
|
100
|
|
|
|
if (pv) |
9226
|
544
|
|
|
|
|
PUSHs(pv); |
9227
|
3070
|
|
|
|
|
PUSHs(sv); |
9228
|
3070
|
100
|
|
|
|
if (pv) |
9229
|
544
|
|
|
|
|
PUSHs(typesv); |
9230
|
3070
|
|
|
|
|
PUTBACK; |
9231
|
3070
|
100
|
|
|
|
call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL)); |
9232
|
|
|
|
|
|
|
9233
|
3066
|
|
|
|
|
SPAGAIN ; |
9234
|
|
|
|
|
|
|
9235
|
|
|
|
|
|
/* Check the eval first */ |
9236
|
3070
|
100
|
|
|
|
if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
9237
|
|
|
|
|
|
STRLEN errlen; |
9238
|
|
|
|
|
|
const char * errstr; |
9239
|
4
|
|
|
|
|
sv_catpvs(errsv, "Propagated"); |
9240
|
4
|
50
|
|
|
|
errstr = SvPV_const(errsv, errlen); |
9241
|
4
|
|
|
|
|
yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */ |
9242
|
4
|
|
|
|
|
(void)POPs; |
9243
|
4
|
|
|
|
|
res = SvREFCNT_inc_simple_NN(sv); |
9244
|
|
|
|
|
|
} |
9245
|
|
|
|
|
|
else { |
9246
|
3062
|
|
|
|
|
res = POPs; |
9247
|
3062
|
|
|
|
|
SvREFCNT_inc_simple_void_NN(res); |
9248
|
|
|
|
|
|
} |
9249
|
|
|
|
|
|
|
9250
|
3066
|
|
|
|
|
PUTBACK ; |
9251
|
3066
|
100
|
|
|
|
FREETMPS ; |
9252
|
3066
|
|
|
|
|
LEAVE ; |
9253
|
3066
|
50
|
|
|
|
POPSTACK; |
9254
|
|
|
|
|
|
|
9255
|
3066
|
100
|
|
|
|
if (!SvOK(res)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
9256
|
|
|
|
|
|
why1 = "Call to &{$^H{"; |
9257
|
|
|
|
|
|
why2 = key; |
9258
|
|
|
|
|
|
why3 = "}} did not return a defined value"; |
9259
|
|
|
|
|
|
sv = res; |
9260
|
1723
|
|
|
|
|
(void)sv_2mortal(sv); |
9261
|
122
|
|
|
|
|
goto report; |
9262
|
|
|
|
|
|
} |
9263
|
|
|
|
|
|
|
9264
|
|
|
|
|
|
return res; |
9265
|
|
|
|
|
|
} |
9266
|
|
|
|
|
|
|
9267
|
|
|
|
|
|
PERL_STATIC_INLINE void |
9268
|
488411213
|
|
|
|
|
S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) { |
9269
|
|
|
|
|
|
dVAR; |
9270
|
|
|
|
|
|
PERL_ARGS_ASSERT_PARSE_IDENT; |
9271
|
|
|
|
|
|
|
9272
|
|
|
|
|
|
for (;;) { |
9273
|
652473562
|
100
|
|
|
|
if (*d >= e) |
9274
|
14
|
|
|
|
|
Perl_croak(aTHX_ "%s", ident_too_long); |
9275
|
653898602
|
100
|
|
|
|
if (is_utf8 && isIDFIRST_utf8((U8*)*s)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
9276
|
|
|
|
|
|
/* The UTF-8 case must come first, otherwise things |
9277
|
|
|
|
|
|
* like c\N{COMBINING TILDE} would start failing, as the |
9278
|
|
|
|
|
|
* isWORDCHAR_A case below would gobble the 'c' up. |
9279
|
|
|
|
|
|
*/ |
9280
|
|
|
|
|
|
|
9281
|
1425054
|
|
|
|
|
char *t = *s + UTF8SKIP(*s); |
9282
|
2873641
|
100
|
|
|
|
while (isIDCONT_utf8((U8*)t)) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
9283
|
736060
|
|
|
|
|
t += UTF8SKIP(t); |
9284
|
1425054
|
50
|
|
|
|
if (*d + (t - *s) > e) |
9285
|
0
|
|
|
|
|
Perl_croak(aTHX_ "%s", ident_too_long); |
9286
|
1425054
|
|
|
|
|
Copy(*s, *d, t - *s, char); |
9287
|
1425054
|
|
|
|
|
*d += t - *s; |
9288
|
1425054
|
|
|
|
|
*s = t; |
9289
|
|
|
|
|
|
} |
9290
|
651048494
|
100
|
|
|
|
else if ( isWORDCHAR_A(**s) ) { |
9291
|
|
|
|
|
|
do { |
9292
|
1515795206
|
|
|
|
|
*(*d)++ = *(*s)++; |
9293
|
1515795206
|
100
|
|
|
|
} while isWORDCHAR_A(**s); |
9294
|
|
|
|
|
|
} |
9295
|
332367595
|
100
|
|
|
|
else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
9296
|
2612
|
|
|
|
|
*(*d)++ = ':'; |
9297
|
2612
|
|
|
|
|
*(*d)++ = ':'; |
9298
|
2612
|
|
|
|
|
(*s)++; |
9299
|
|
|
|
|
|
} |
9300
|
332364983
|
100
|
|
|
|
else if (allow_package && **s == ':' && (*s)[1] == ':' |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
9301
|
|
|
|
|
|
/* Disallow things like Foo::$bar. For the curious, this is |
9302
|
|
|
|
|
|
* the code path that triggers the "Bad name after" warning |
9303
|
|
|
|
|
|
* when looking for barewords. |
9304
|
|
|
|
|
|
*/ |
9305
|
18358566
|
100
|
|
|
|
&& (*s)[2] != '$') { |
9306
|
18358562
|
|
|
|
|
*(*d)++ = *(*s)++; |
9307
|
18358562
|
|
|
|
|
*(*d)++ = *(*s)++; |
9308
|
|
|
|
|
|
} |
9309
|
|
|
|
|
|
else |
9310
|
|
|
|
|
|
break; |
9311
|
|
|
|
|
|
} |
9312
|
314006421
|
|
|
|
|
return; |
9313
|
|
|
|
|
|
} |
9314
|
|
|
|
|
|
|
9315
|
|
|
|
|
|
/* Returns a NUL terminated string, with the length of the string written to |
9316
|
|
|
|
|
|
*slp |
9317
|
|
|
|
|
|
*/ |
9318
|
|
|
|
|
|
STATIC char * |
9319
|
175654796
|
|
|
|
|
S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) |
9320
|
|
|
|
|
|
{ |
9321
|
|
|
|
|
|
dVAR; |
9322
|
175654796
|
|
|
|
|
char *d = dest; |
9323
|
175654796
|
|
|
|
|
char * const e = d + destlen - 3; /* two-character token, ending NUL */ |
9324
|
175654796
|
50
|
|
|
|
bool is_utf8 = cBOOL(UTF); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
9325
|
|
|
|
|
|
|
9326
|
|
|
|
|
|
PERL_ARGS_ASSERT_SCAN_WORD; |
9327
|
|
|
|
|
|
|
9328
|
175654796
|
|
|
|
|
parse_ident(&s, &d, e, allow_package, is_utf8); |
9329
|
175654796
|
|
|
|
|
*d = '\0'; |
9330
|
175654796
|
|
|
|
|
*slp = d - dest; |
9331
|
175654796
|
|
|
|
|
return s; |
9332
|
|
|
|
|
|
} |
9333
|
|
|
|
|
|
|
9334
|
|
|
|
|
|
STATIC char * |
9335
|
139284652
|
|
|
|
|
S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck_uni) |
9336
|
|
|
|
|
|
{ |
9337
|
|
|
|
|
|
dVAR; |
9338
|
|
|
|
|
|
char *bracket = NULL; |
9339
|
139284652
|
|
|
|
|
char funny = *s++; |
9340
|
139284652
|
|
|
|
|
char *d = dest; |
9341
|
139284652
|
|
|
|
|
char * const e = d + destlen - 3; /* two-character token, ending NUL */ |
9342
|
139284652
|
50
|
|
|
|
bool is_utf8 = cBOOL(UTF); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
9343
|
|
|
|
|
|
|
9344
|
|
|
|
|
|
PERL_ARGS_ASSERT_SCAN_IDENT; |
9345
|
|
|
|
|
|
|
9346
|
139284652
|
100
|
|
|
|
if (isSPACE(*s)) |
9347
|
39756
|
|
|
|
|
s = PEEKSPACE(s); |
9348
|
139284652
|
100
|
|
|
|
if (isDIGIT(*s)) { |
9349
|
2808694
|
100
|
|
|
|
while (isDIGIT(*s)) { |
9350
|
1404422
|
50
|
|
|
|
if (d >= e) |
9351
|
0
|
|
|
|
|
Perl_croak(aTHX_ "%s", ident_too_long); |
9352
|
1404422
|
|
|
|
|
*d++ = *s++; |
9353
|
|
|
|
|
|
} |
9354
|
|
|
|
|
|
} |
9355
|
|
|
|
|
|
else { |
9356
|
137880380
|
|
|
|
|
parse_ident(&s, &d, e, 1, is_utf8); |
9357
|
|
|
|
|
|
} |
9358
|
139284638
|
|
|
|
|
*d = '\0'; |
9359
|
139284638
|
|
|
|
|
d = dest; |
9360
|
139284638
|
100
|
|
|
|
if (*d) { |
9361
|
|
|
|
|
|
/* Either a digit variable, or parse_ident() found an identifier |
9362
|
|
|
|
|
|
(anything valid as a bareword), so job done and return. */ |
9363
|
130359558
|
100
|
|
|
|
if (PL_lex_state != LEX_NORMAL) |
9364
|
8464463
|
|
|
|
|
PL_lex_state = LEX_INTERPENDMAYBE; |
9365
|
130359558
|
|
|
|
|
return s; |
9366
|
|
|
|
|
|
} |
9367
|
12775087
|
100
|
|
|
|
if (*s == '$' && s[1] && |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
9368
|
3829769
|
100
|
|
|
|
(isIDFIRST_lazy_if(s+1,is_utf8) |
9369
|
23546
|
100
|
|
|
|
|| isDIGIT_A((U8)s[1]) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
9370
|
45752
|
100
|
|
|
|
|| s[1] == '$' |
9371
|
45454
|
100
|
|
|
|
|| s[1] == '{' |
9372
|
45432
|
100
|
|
|
|
|| strnEQ(s+1,"::",2)) ) |
9373
|
|
|
|
|
|
{ |
9374
|
|
|
|
|
|
/* Dereferencing a value in a scalar variable. |
9375
|
|
|
|
|
|
The alternatives are different syntaxes for a scalar variable. |
9376
|
|
|
|
|
|
Using ' as a leading package separator isn't allowed. :: is. */ |
9377
|
2595918
|
|
|
|
|
return s; |
9378
|
|
|
|
|
|
} |
9379
|
|
|
|
|
|
/* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */ |
9380
|
6329162
|
100
|
|
|
|
if (*s == '{') { |
9381
|
2819598
|
|
|
|
|
bracket = s; |
9382
|
2819598
|
|
|
|
|
s++; |
9383
|
4394310
|
50
|
|
|
|
while (s < send && SPACE_OR_TAB(*s)) |
|
|
100
|
|
|
|
|
9384
|
218010
|
|
|
|
|
s++; |
9385
|
|
|
|
|
|
} |
9386
|
|
|
|
|
|
|
9387
|
|
|
|
|
|
/* \c?, \c\, \c^, \c_, and \cA..\cZ minus the ones that have traditionally |
9388
|
|
|
|
|
|
* been matched by \s on ASCII platforms, are the legal control char names |
9389
|
|
|
|
|
|
* here, that is \c? plus 1-32 minus the \s ones. */ |
9390
|
|
|
|
|
|
#define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)(d)) \ |
9391
|
|
|
|
|
|
|| isDIGIT_A((U8)(d)) \ |
9392
|
|
|
|
|
|
|| (!(u) && !isASCII((U8)(d))) \ |
9393
|
|
|
|
|
|
|| ((((U8)(d)) < 32) \ |
9394
|
|
|
|
|
|
&& (((((U8)(d)) >= 14) \ |
9395
|
|
|
|
|
|
|| (((U8)(d)) <= 8 && (d) != 0) \ |
9396
|
|
|
|
|
|
|| (((U8)(d)) == 13)))) \ |
9397
|
|
|
|
|
|
|| (((U8)(d)) == toCTRL('?'))) |
9398
|
9443511
|
100
|
|
|
|
if (s < send |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
9399
|
9402832
|
100
|
|
|
|
&& (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(*s, is_utf8))) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
9400
|
|
|
|
|
|
{ |
9401
|
6295104
|
100
|
|
|
|
if (is_utf8) { |
9402
|
1082
|
|
|
|
|
const STRLEN skip = UTF8SKIP(s); |
9403
|
|
|
|
|
|
STRLEN i; |
9404
|
1082
|
|
|
|
|
d[skip] = '\0'; |
9405
|
2178
|
100
|
|
|
|
for ( i = 0; i < skip; i++ ) |
9406
|
1096
|
|
|
|
|
d[i] = *s++; |
9407
|
|
|
|
|
|
} |
9408
|
|
|
|
|
|
else { |
9409
|
6294022
|
|
|
|
|
*d = *s++; |
9410
|
6294022
|
|
|
|
|
d[1] = '\0'; |
9411
|
|
|
|
|
|
} |
9412
|
|
|
|
|
|
} |
9413
|
|
|
|
|
|
/* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */ |
9414
|
6329162
|
100
|
|
|
|
if (*d == '^' && *s && isCONTROLVAR(*s)) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
9415
|
1452138
|
50
|
|
|
|
*d = toCTRL(*s); |
9416
|
1452138
|
|
|
|
|
s++; |
9417
|
|
|
|
|
|
} |
9418
|
|
|
|
|
|
/* Warn about ambiguous code after unary operators if {...} notation isn't |
9419
|
|
|
|
|
|
used. There's no difference in ambiguity; it's merely a heuristic |
9420
|
|
|
|
|
|
about when not to warn. */ |
9421
|
4877024
|
100
|
|
|
|
else if (ck_uni && !bracket) |
9422
|
8
|
|
|
|
|
check_uni(); |
9423
|
6329162
|
100
|
|
|
|
if (bracket) { |
9424
|
|
|
|
|
|
/* If we were processing {...} notation then... */ |
9425
|
2819598
|
100
|
|
|
|
if (isIDFIRST_lazy_if(d,is_utf8)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
9426
|
|
|
|
|
|
/* if it starts as a valid identifier, assume that it is one. |
9427
|
|
|
|
|
|
(the later check for } being at the expected point will trap |
9428
|
|
|
|
|
|
cases where this doesn't pan out.) */ |
9429
|
471259
|
100
|
|
|
|
d += is_utf8 ? UTF8SKIP(d) : 1; |
9430
|
471259
|
|
|
|
|
parse_ident(&s, &d, e, 1, is_utf8); |
9431
|
471259
|
|
|
|
|
*d = '\0'; |
9432
|
708746
|
50
|
|
|
|
while (s < send && SPACE_OR_TAB(*s)) |
|
|
100
|
|
|
|
|
9433
|
10316
|
|
|
|
|
s++; |
9434
|
471259
|
100
|
|
|
|
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
9435
|
|
|
|
|
|
/* ${foo[0]} and ${foo{bar}} notation. */ |
9436
|
14
|
100
|
|
|
|
if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) { |
|
|
100
|
|
|
|
|
9437
|
|
|
|
|
|
const char * const brack = |
9438
|
|
|
|
|
|
(const char *) |
9439
|
6
|
100
|
|
|
|
((*s == '[') ? "[...]" : "{...}"); |
9440
|
|
|
|
|
|
/* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */ |
9441
|
6
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), |
9442
|
|
|
|
|
|
"Ambiguous use of %c{%s%s} resolved to %c%s%s", |
9443
|
|
|
|
|
|
funny, dest, brack, funny, dest, brack); |
9444
|
|
|
|
|
|
} |
9445
|
|
|
|
|
|
bracket++; |
9446
|
14
|
|
|
|
|
PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK); |
9447
|
14
|
|
|
|
|
PL_lex_allbrackets++; |
9448
|
14
|
|
|
|
|
return s; |
9449
|
|
|
|
|
|
} |
9450
|
|
|
|
|
|
} |
9451
|
|
|
|
|
|
/* Handle extended ${^Foo} variables |
9452
|
|
|
|
|
|
* 1999-02-27 mjd-perl-patch@plover.com */ |
9453
|
2348339
|
100
|
|
|
|
else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */ |
9454
|
139154
|
100
|
|
|
|
&& isWORDCHAR(*s)) |
9455
|
|
|
|
|
|
{ |
9456
|
137774
|
|
|
|
|
d++; |
9457
|
1620119
|
100
|
|
|
|
while (isWORDCHAR(*s) && d < e) { |
|
|
50
|
|
|
|
|
9458
|
1414538
|
|
|
|
|
*d++ = *s++; |
9459
|
|
|
|
|
|
} |
9460
|
137774
|
50
|
|
|
|
if (d >= e) |
9461
|
0
|
|
|
|
|
Perl_croak(aTHX_ "%s", ident_too_long); |
9462
|
1530696
|
|
|
|
|
*d = '\0'; |
9463
|
|
|
|
|
|
} |
9464
|
|
|
|
|
|
|
9465
|
2822276
|
100
|
|
|
|
while (s < send && SPACE_OR_TAB(*s)) |
|
|
100
|
|
|
|
|
9466
|
2692
|
|
|
|
|
s++; |
9467
|
|
|
|
|
|
|
9468
|
|
|
|
|
|
/* Expect to find a closing } after consuming any trailing whitespace. |
9469
|
|
|
|
|
|
*/ |
9470
|
2819584
|
100
|
|
|
|
if (*s == '}') { |
9471
|
531073
|
|
|
|
|
s++; |
9472
|
531073
|
100
|
|
|
|
if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) { |
|
|
100
|
|
|
|
|
9473
|
384909
|
|
|
|
|
PL_lex_state = LEX_INTERPEND; |
9474
|
384909
|
|
|
|
|
PL_expect = XREF; |
9475
|
|
|
|
|
|
} |
9476
|
531073
|
100
|
|
|
|
if (PL_lex_state == LEX_NORMAL) { |
9477
|
197418
|
|
|
|
|
if (ckWARN(WARN_AMBIGUOUS) && |
9478
|
51454
|
|
|
|
|
(keyword(dest, d - dest, 0) |
9479
|
51440
|
100
|
|
|
|
|| get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0))) |
|
|
100
|
|
|
|
|
9480
|
|
|
|
|
|
{ |
9481
|
20
|
100
|
|
|
|
SV *tmp = newSVpvn_flags( dest, d - dest, |
9482
|
|
|
|
|
|
SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) ); |
9483
|
20
|
100
|
|
|
|
if (funny == '#') |
9484
|
|
|
|
|
|
funny = '@'; |
9485
|
20
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), |
9486
|
|
|
|
|
|
"Ambiguous use of %c{%"SVf"} resolved to %c%"SVf, |
9487
|
|
|
|
|
|
funny, tmp, funny, tmp); |
9488
|
|
|
|
|
|
} |
9489
|
|
|
|
|
|
} |
9490
|
|
|
|
|
|
} |
9491
|
|
|
|
|
|
else { |
9492
|
|
|
|
|
|
/* Didn't find the closing } at the point we expected, so restore |
9493
|
|
|
|
|
|
state such that the next thing to process is the opening { and */ |
9494
|
2288511
|
|
|
|
|
s = bracket; /* let the parser handle it */ |
9495
|
2288511
|
|
|
|
|
*dest = '\0'; |
9496
|
|
|
|
|
|
} |
9497
|
|
|
|
|
|
} |
9498
|
3509564
|
100
|
|
|
|
else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s)) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
9499
|
803621
|
|
|
|
|
PL_lex_state = LEX_INTERPEND; |
9500
|
75011878
|
|
|
|
|
return s; |
9501
|
|
|
|
|
|
} |
9502
|
|
|
|
|
|
|
9503
|
|
|
|
|
|
static bool |
9504
|
6274656
|
|
|
|
|
S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) { |
9505
|
|
|
|
|
|
|
9506
|
|
|
|
|
|
/* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in |
9507
|
|
|
|
|
|
* the parse starting at 's', based on the subset that are valid in this |
9508
|
|
|
|
|
|
* context input to this routine in 'valid_flags'. Advances s. Returns |
9509
|
|
|
|
|
|
* TRUE if the input should be treated as a valid flag, so the next char |
9510
|
|
|
|
|
|
* may be as well; otherwise FALSE. 'charset' should point to a NUL upon |
9511
|
|
|
|
|
|
* first call on the current regex. This routine will set it to any |
9512
|
|
|
|
|
|
* charset modifier found. The caller shouldn't change it. This way, |
9513
|
|
|
|
|
|
* another charset modifier encountered in the parse can be detected as an |
9514
|
|
|
|
|
|
* error, as we have decided to allow only one */ |
9515
|
|
|
|
|
|
|
9516
|
6274656
|
|
|
|
|
const char c = **s; |
9517
|
6274656
|
50
|
|
|
|
STRLEN charlen = UTF ? UTF8SKIP(*s) : 1; |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
9518
|
|
|
|
|
|
|
9519
|
6274656
|
100
|
|
|
|
if ( charlen != 1 || ! strchr(valid_flags, c) ) { |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
9520
|
4736811
|
100
|
|
|
|
if (isWORDCHAR_lazy_if(*s, UTF)) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
9521
|
24
|
50
|
|
|
|
yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s), |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
9522
|
|
|
|
|
|
UTF ? SVf_UTF8 : 0); |
9523
|
24
|
|
|
|
|
(*s) += charlen; |
9524
|
|
|
|
|
|
/* Pretend that it worked, so will continue processing before |
9525
|
|
|
|
|
|
* dieing */ |
9526
|
24
|
|
|
|
|
return TRUE; |
9527
|
|
|
|
|
|
} |
9528
|
|
|
|
|
|
return FALSE; |
9529
|
|
|
|
|
|
} |
9530
|
|
|
|
|
|
|
9531
|
1537845
|
|
|
|
|
switch (c) { |
9532
|
|
|
|
|
|
|
9533
|
590694
|
|
|
|
|
CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl); |
9534
|
619296
|
|
|
|
|
case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break; |
9535
|
4124
|
|
|
|
|
case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break; |
9536
|
32504
|
|
|
|
|
case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break; |
9537
|
208
|
|
|
|
|
case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break; |
9538
|
5144
|
|
|
|
|
case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break; |
9539
|
|
|
|
|
|
case LOCALE_PAT_MOD: |
9540
|
408
|
100
|
|
|
|
if (*charset) { |
9541
|
|
|
|
|
|
goto multiple_charsets; |
9542
|
|
|
|
|
|
} |
9543
|
|
|
|
|
|
set_regex_charset(pmfl, REGEX_LOCALE_CHARSET); |
9544
|
406
|
|
|
|
|
*charset = c; |
9545
|
406
|
|
|
|
|
break; |
9546
|
|
|
|
|
|
case UNICODE_PAT_MOD: |
9547
|
10662
|
100
|
|
|
|
if (*charset) { |
9548
|
|
|
|
|
|
goto multiple_charsets; |
9549
|
|
|
|
|
|
} |
9550
|
|
|
|
|
|
set_regex_charset(pmfl, REGEX_UNICODE_CHARSET); |
9551
|
10660
|
|
|
|
|
*charset = c; |
9552
|
10660
|
|
|
|
|
break; |
9553
|
|
|
|
|
|
case ASCII_RESTRICT_PAT_MOD: |
9554
|
1534
|
100
|
|
|
|
if (! *charset) { |
9555
|
|
|
|
|
|
set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET); |
9556
|
|
|
|
|
|
} |
9557
|
|
|
|
|
|
else { |
9558
|
|
|
|
|
|
|
9559
|
|
|
|
|
|
/* Error if previous modifier wasn't an 'a', but if it was, see |
9560
|
|
|
|
|
|
* if, and accept, a second occurrence (only) */ |
9561
|
502
|
100
|
|
|
|
if (*charset != 'a' |
9562
|
750
|
100
|
|
|
|
|| get_regex_charset(*pmfl) |
9563
|
|
|
|
|
|
!= REGEX_ASCII_RESTRICTED_CHARSET) |
9564
|
|
|
|
|
|
{ |
9565
|
|
|
|
|
|
goto multiple_charsets; |
9566
|
|
|
|
|
|
} |
9567
|
|
|
|
|
|
set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET); |
9568
|
|
|
|
|
|
} |
9569
|
1530
|
|
|
|
|
*charset = c; |
9570
|
1530
|
|
|
|
|
break; |
9571
|
|
|
|
|
|
case DEPENDS_PAT_MOD: |
9572
|
392
|
100
|
|
|
|
if (*charset) { |
9573
|
|
|
|
|
|
goto multiple_charsets; |
9574
|
|
|
|
|
|
} |
9575
|
|
|
|
|
|
set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET); |
9576
|
312
|
|
|
|
|
*charset = c; |
9577
|
312
|
|
|
|
|
break; |
9578
|
|
|
|
|
|
} |
9579
|
|
|
|
|
|
|
9580
|
1537757
|
|
|
|
|
(*s)++; |
9581
|
1537757
|
|
|
|
|
return TRUE; |
9582
|
|
|
|
|
|
|
9583
|
|
|
|
|
|
multiple_charsets: |
9584
|
88
|
100
|
|
|
|
if (*charset != c) { |
9585
|
4
|
|
|
|
|
yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c)); |
9586
|
|
|
|
|
|
} |
9587
|
84
|
100
|
|
|
|
else if (c == 'a') { |
9588
|
2
|
|
|
|
|
yyerror("Regexp modifier \"/a\" may appear a maximum of twice"); |
9589
|
|
|
|
|
|
} |
9590
|
|
|
|
|
|
else { |
9591
|
82
|
|
|
|
|
yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c)); |
9592
|
|
|
|
|
|
} |
9593
|
|
|
|
|
|
|
9594
|
|
|
|
|
|
/* Pretend that it worked, so will continue processing before dieing */ |
9595
|
80
|
|
|
|
|
(*s)++; |
9596
|
3263349
|
|
|
|
|
return TRUE; |
9597
|
|
|
|
|
|
} |
9598
|
|
|
|
|
|
|
9599
|
|
|
|
|
|
STATIC char * |
9600
|
3248828
|
|
|
|
|
S_scan_pat(pTHX_ char *start, I32 type) |
9601
|
|
|
|
|
|
{ |
9602
|
|
|
|
|
|
dVAR; |
9603
|
|
|
|
|
|
PMOP *pm; |
9604
|
|
|
|
|
|
char *s; |
9605
|
|
|
|
|
|
const char * const valid_flags = |
9606
|
3248828
|
100
|
|
|
|
(const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS); |
9607
|
3248828
|
|
|
|
|
char charset = '\0'; /* character set modifier */ |
9608
|
|
|
|
|
|
#ifdef PERL_MAD |
9609
|
|
|
|
|
|
char *modstart; |
9610
|
|
|
|
|
|
#endif |
9611
|
|
|
|
|
|
|
9612
|
|
|
|
|
|
PERL_ARGS_ASSERT_SCAN_PAT; |
9613
|
|
|
|
|
|
|
9614
|
3248828
|
|
|
|
|
s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING), |
9615
|
|
|
|
|
|
TRUE /* look for escaped bracketed metas */ ); |
9616
|
|
|
|
|
|
|
9617
|
3248828
|
100
|
|
|
|
if (!s) { |
9618
|
46
|
|
|
|
|
const char * const delimiter = skipspace(start); |
9619
|
46
|
50
|
|
|
|
Perl_croak(aTHX_ |
9620
|
|
|
|
|
|
(const char *) |
9621
|
46
|
|
|
|
|
(*delimiter == '?' |
9622
|
|
|
|
|
|
? "Search pattern not terminated or ternary operator parsed as search pattern" |
9623
|
|
|
|
|
|
: "Search pattern not terminated" )); |
9624
|
|
|
|
|
|
} |
9625
|
|
|
|
|
|
|
9626
|
3248782
|
|
|
|
|
pm = (PMOP*)newPMOP(type, 0); |
9627
|
3248782
|
100
|
|
|
|
if (PL_multi_open == '?') { |
9628
|
|
|
|
|
|
/* This is the only point in the code that sets PMf_ONCE: */ |
9629
|
34
|
|
|
|
|
pm->op_pmflags |= PMf_ONCE; |
9630
|
|
|
|
|
|
|
9631
|
|
|
|
|
|
/* Hence it's safe to do this bit of PMOP book-keeping here, which |
9632
|
|
|
|
|
|
allows us to restrict the list needed by reset to just the ?? |
9633
|
|
|
|
|
|
matches. */ |
9634
|
|
|
|
|
|
assert(type != OP_TRANS); |
9635
|
34
|
50
|
|
|
|
if (PL_curstash) { |
9636
|
34
|
|
|
|
|
MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab); |
9637
|
|
|
|
|
|
U32 elements; |
9638
|
34
|
100
|
|
|
|
if (!mg) { |
9639
|
28
|
|
|
|
|
mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0, |
9640
|
|
|
|
|
|
0); |
9641
|
|
|
|
|
|
} |
9642
|
34
|
|
|
|
|
elements = mg->mg_len / sizeof(PMOP**); |
9643
|
34
|
50
|
|
|
|
Renewc(mg->mg_ptr, elements + 1, PMOP*, char); |
9644
|
34
|
|
|
|
|
((PMOP**)mg->mg_ptr) [elements++] = pm; |
9645
|
34
|
|
|
|
|
mg->mg_len = elements * sizeof(PMOP**); |
9646
|
34
|
|
|
|
|
PmopSTASH_set(pm,PL_curstash); |
9647
|
|
|
|
|
|
} |
9648
|
|
|
|
|
|
} |
9649
|
|
|
|
|
|
#ifdef PERL_MAD |
9650
|
|
|
|
|
|
modstart = s; |
9651
|
|
|
|
|
|
#endif |
9652
|
|
|
|
|
|
|
9653
|
|
|
|
|
|
/* if qr/...(?{..}).../, then need to parse the pattern within a new |
9654
|
|
|
|
|
|
* anon CV. False positives like qr/[(?{]/ are harmless */ |
9655
|
|
|
|
|
|
|
9656
|
3248782
|
100
|
|
|
|
if (type == OP_QR) { |
9657
|
|
|
|
|
|
STRLEN len; |
9658
|
471994
|
50
|
|
|
|
char *e, *p = SvPV(PL_lex_stuff, len); |
9659
|
471994
|
|
|
|
|
e = p + len; |
9660
|
17041680
|
100
|
|
|
|
for (; p < e; p++) { |
9661
|
16578630
|
100
|
|
|
|
if (p[0] == '(' && p[1] == '?' |
|
|
100
|
|
|
|
|
9662
|
229308
|
100
|
|
|
|
&& (p[2] == '{' || (p[2] == '?' && p[3] == '{'))) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
9663
|
|
|
|
|
|
{ |
9664
|
8944
|
|
|
|
|
pm->op_pmflags |= PMf_HAS_CV; |
9665
|
8944
|
|
|
|
|
break; |
9666
|
|
|
|
|
|
} |
9667
|
|
|
|
|
|
} |
9668
|
1909885
|
|
|
|
|
pm->op_pmflags |= PMf_IS_QR; |
9669
|
|
|
|
|
|
} |
9670
|
|
|
|
|
|
|
9671
|
3937225
|
100
|
|
|
|
while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {}; |
|
|
100
|
|
|
|
|
9672
|
|
|
|
|
|
#ifdef PERL_MAD |
9673
|
|
|
|
|
|
if (PL_madskills && modstart != s) { |
9674
|
|
|
|
|
|
SV* tmptoken = newSVpvn(modstart, s - modstart); |
9675
|
|
|
|
|
|
append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0); |
9676
|
|
|
|
|
|
} |
9677
|
|
|
|
|
|
#endif |
9678
|
|
|
|
|
|
/* issue a warning if /c is specified,but /g is not */ |
9679
|
3248778
|
100
|
|
|
|
if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)) |
9680
|
|
|
|
|
|
{ |
9681
|
6
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), |
9682
|
|
|
|
|
|
"Use of /c modifier is meaningless without /g" ); |
9683
|
|
|
|
|
|
} |
9684
|
|
|
|
|
|
|
9685
|
3248778
|
|
|
|
|
PL_lex_op = (OP*)pm; |
9686
|
3248778
|
|
|
|
|
pl_yylval.ival = OP_MATCH; |
9687
|
3248778
|
|
|
|
|
return s; |
9688
|
|
|
|
|
|
} |
9689
|
|
|
|
|
|
|
9690
|
|
|
|
|
|
STATIC char * |
9691
|
1488023
|
|
|
|
|
S_scan_subst(pTHX_ char *start) |
9692
|
|
|
|
|
|
{ |
9693
|
|
|
|
|
|
dVAR; |
9694
|
|
|
|
|
|
char *s; |
9695
|
|
|
|
|
|
PMOP *pm; |
9696
|
|
|
|
|
|
I32 first_start; |
9697
|
|
|
|
|
|
line_t first_line; |
9698
|
|
|
|
|
|
I32 es = 0; |
9699
|
1488023
|
|
|
|
|
char charset = '\0'; /* character set modifier */ |
9700
|
|
|
|
|
|
#ifdef PERL_MAD |
9701
|
|
|
|
|
|
char *modstart; |
9702
|
|
|
|
|
|
#endif |
9703
|
|
|
|
|
|
|
9704
|
|
|
|
|
|
PERL_ARGS_ASSERT_SCAN_SUBST; |
9705
|
|
|
|
|
|
|
9706
|
1488023
|
|
|
|
|
pl_yylval.ival = OP_NULL; |
9707
|
|
|
|
|
|
|
9708
|
1488023
|
|
|
|
|
s = scan_str(start,!!PL_madskills,FALSE,FALSE, |
9709
|
|
|
|
|
|
TRUE /* look for escaped bracketed metas */ ); |
9710
|
|
|
|
|
|
|
9711
|
1488023
|
100
|
|
|
|
if (!s) |
9712
|
2
|
|
|
|
|
Perl_croak(aTHX_ "Substitution pattern not terminated"); |
9713
|
|
|
|
|
|
|
9714
|
1488021
|
100
|
|
|
|
if (s[-1] == PL_multi_open) |
9715
|
1300140
|
|
|
|
|
s--; |
9716
|
|
|
|
|
|
#ifdef PERL_MAD |
9717
|
|
|
|
|
|
if (PL_madskills) { |
9718
|
|
|
|
|
|
CURMAD('q', PL_thisopen); |
9719
|
|
|
|
|
|
CURMAD('_', PL_thiswhite); |
9720
|
|
|
|
|
|
CURMAD('E', PL_thisstuff); |
9721
|
|
|
|
|
|
CURMAD('Q', PL_thisclose); |
9722
|
|
|
|
|
|
PL_realtokenstart = s - SvPVX(PL_linestr); |
9723
|
|
|
|
|
|
} |
9724
|
|
|
|
|
|
#endif |
9725
|
|
|
|
|
|
|
9726
|
1488021
|
|
|
|
|
first_start = PL_multi_start; |
9727
|
1488021
|
|
|
|
|
first_line = CopLINE(PL_curcop); |
9728
|
1488021
|
|
|
|
|
s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); |
9729
|
1488021
|
100
|
|
|
|
if (!s) { |
9730
|
6
|
50
|
|
|
|
if (PL_lex_stuff) { |
9731
|
6
|
|
|
|
|
SvREFCNT_dec(PL_lex_stuff); |
9732
|
6
|
|
|
|
|
PL_lex_stuff = NULL; |
9733
|
|
|
|
|
|
} |
9734
|
6
|
|
|
|
|
Perl_croak(aTHX_ "Substitution replacement not terminated"); |
9735
|
|
|
|
|
|
} |
9736
|
1488015
|
|
|
|
|
PL_multi_start = first_start; /* so whole substitution is taken together */ |
9737
|
|
|
|
|
|
|
9738
|
1488015
|
|
|
|
|
pm = (PMOP*)newPMOP(OP_SUBST, 0); |
9739
|
|
|
|
|
|
|
9740
|
|
|
|
|
|
#ifdef PERL_MAD |
9741
|
|
|
|
|
|
if (PL_madskills) { |
9742
|
|
|
|
|
|
CURMAD('z', PL_thisopen); |
9743
|
|
|
|
|
|
CURMAD('R', PL_thisstuff); |
9744
|
|
|
|
|
|
CURMAD('Z', PL_thisclose); |
9745
|
|
|
|
|
|
} |
9746
|
|
|
|
|
|
modstart = s; |
9747
|
|
|
|
|
|
#endif |
9748
|
|
|
|
|
|
|
9749
|
3235211
|
50
|
|
|
|
while (*s) { |
9750
|
2516216
|
100
|
|
|
|
if (*s == EXEC_PAT_MOD) { |
9751
|
178783
|
|
|
|
|
s++; |
9752
|
178783
|
|
|
|
|
es++; |
9753
|
|
|
|
|
|
} |
9754
|
2428984
|
100
|
|
|
|
else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset)) |
9755
|
|
|
|
|
|
{ |
9756
|
|
|
|
|
|
break; |
9757
|
|
|
|
|
|
} |
9758
|
|
|
|
|
|
} |
9759
|
|
|
|
|
|
|
9760
|
|
|
|
|
|
#ifdef PERL_MAD |
9761
|
|
|
|
|
|
if (PL_madskills) { |
9762
|
|
|
|
|
|
if (modstart != s) |
9763
|
|
|
|
|
|
curmad('m', newSVpvn(modstart, s - modstart)); |
9764
|
|
|
|
|
|
append_madprops(PL_thismad, (OP*)pm, 0); |
9765
|
|
|
|
|
|
PL_thismad = 0; |
9766
|
|
|
|
|
|
} |
9767
|
|
|
|
|
|
#endif |
9768
|
1488011
|
100
|
|
|
|
if ((pm->op_pmflags & PMf_CONTINUE)) { |
9769
|
8
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" ); |
9770
|
|
|
|
|
|
} |
9771
|
|
|
|
|
|
|
9772
|
1488011
|
100
|
|
|
|
if (es) { |
9773
|
175371
|
|
|
|
|
SV * const repl = newSVpvs(""); |
9774
|
|
|
|
|
|
|
9775
|
175371
|
|
|
|
|
PL_multi_end = 0; |
9776
|
175371
|
|
|
|
|
pm->op_pmflags |= PMf_EVAL; |
9777
|
439680
|
100
|
|
|
|
while (es-- > 0) { |
9778
|
178783
|
100
|
|
|
|
if (es) |
9779
|
3412
|
|
|
|
|
sv_catpvs(repl, "eval "); |
9780
|
|
|
|
|
|
else |
9781
|
177077
|
|
|
|
|
sv_catpvs(repl, "do "); |
9782
|
|
|
|
|
|
} |
9783
|
175371
|
|
|
|
|
sv_catpvs(repl, "{"); |
9784
|
175371
|
|
|
|
|
sv_catsv(repl, PL_sublex_info.repl); |
9785
|
175371
|
|
|
|
|
sv_catpvs(repl, "}"); |
9786
|
175371
|
|
|
|
|
SvEVALED_on(repl); |
9787
|
175371
|
|
|
|
|
SvREFCNT_dec(PL_sublex_info.repl); |
9788
|
175371
|
|
|
|
|
PL_sublex_info.repl = repl; |
9789
|
|
|
|
|
|
} |
9790
|
1488011
|
100
|
|
|
|
if (CopLINE(PL_curcop) != first_line) { |
9791
|
28285
|
|
|
|
|
sv_upgrade(PL_sublex_info.repl, SVt_PVNV); |
9792
|
56570
|
|
|
|
|
((XPVNV*)SvANY(PL_sublex_info.repl))->xnv_u.xpad_cop_seq.xlow = |
9793
|
28285
|
|
|
|
|
CopLINE(PL_curcop) - first_line; |
9794
|
28285
|
|
|
|
|
CopLINE_set(PL_curcop, first_line); |
9795
|
|
|
|
|
|
} |
9796
|
|
|
|
|
|
|
9797
|
1488011
|
|
|
|
|
PL_lex_op = (OP*)pm; |
9798
|
1488011
|
|
|
|
|
pl_yylval.ival = OP_SUBST; |
9799
|
1488011
|
|
|
|
|
return s; |
9800
|
|
|
|
|
|
} |
9801
|
|
|
|
|
|
|
9802
|
|
|
|
|
|
STATIC char * |
9803
|
109274
|
|
|
|
|
S_scan_trans(pTHX_ char *start) |
9804
|
|
|
|
|
|
{ |
9805
|
|
|
|
|
|
dVAR; |
9806
|
|
|
|
|
|
char* s; |
9807
|
|
|
|
|
|
OP *o; |
9808
|
|
|
|
|
|
U8 squash; |
9809
|
|
|
|
|
|
U8 del; |
9810
|
|
|
|
|
|
U8 complement; |
9811
|
|
|
|
|
|
bool nondestruct = 0; |
9812
|
|
|
|
|
|
#ifdef PERL_MAD |
9813
|
|
|
|
|
|
char *modstart; |
9814
|
|
|
|
|
|
#endif |
9815
|
|
|
|
|
|
|
9816
|
|
|
|
|
|
PERL_ARGS_ASSERT_SCAN_TRANS; |
9817
|
|
|
|
|
|
|
9818
|
109274
|
|
|
|
|
pl_yylval.ival = OP_NULL; |
9819
|
|
|
|
|
|
|
9820
|
109274
|
|
|
|
|
s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE); |
9821
|
109274
|
100
|
|
|
|
if (!s) |
9822
|
12
|
|
|
|
|
Perl_croak(aTHX_ "Transliteration pattern not terminated"); |
9823
|
|
|
|
|
|
|
9824
|
109262
|
100
|
|
|
|
if (s[-1] == PL_multi_open) |
9825
|
98316
|
|
|
|
|
s--; |
9826
|
|
|
|
|
|
#ifdef PERL_MAD |
9827
|
|
|
|
|
|
if (PL_madskills) { |
9828
|
|
|
|
|
|
CURMAD('q', PL_thisopen); |
9829
|
|
|
|
|
|
CURMAD('_', PL_thiswhite); |
9830
|
|
|
|
|
|
CURMAD('E', PL_thisstuff); |
9831
|
|
|
|
|
|
CURMAD('Q', PL_thisclose); |
9832
|
|
|
|
|
|
PL_realtokenstart = s - SvPVX(PL_linestr); |
9833
|
|
|
|
|
|
} |
9834
|
|
|
|
|
|
#endif |
9835
|
|
|
|
|
|
|
9836
|
109262
|
|
|
|
|
s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); |
9837
|
109262
|
100
|
|
|
|
if (!s) { |
9838
|
12
|
50
|
|
|
|
if (PL_lex_stuff) { |
9839
|
12
|
|
|
|
|
SvREFCNT_dec(PL_lex_stuff); |
9840
|
12
|
|
|
|
|
PL_lex_stuff = NULL; |
9841
|
|
|
|
|
|
} |
9842
|
12
|
|
|
|
|
Perl_croak(aTHX_ "Transliteration replacement not terminated"); |
9843
|
|
|
|
|
|
} |
9844
|
|
|
|
|
|
if (PL_madskills) { |
9845
|
|
|
|
|
|
CURMAD('z', PL_thisopen); |
9846
|
|
|
|
|
|
CURMAD('R', PL_thisstuff); |
9847
|
|
|
|
|
|
CURMAD('Z', PL_thisclose); |
9848
|
|
|
|
|
|
} |
9849
|
|
|
|
|
|
|
9850
|
|
|
|
|
|
complement = del = squash = 0; |
9851
|
|
|
|
|
|
#ifdef PERL_MAD |
9852
|
|
|
|
|
|
modstart = s; |
9853
|
|
|
|
|
|
#endif |
9854
|
|
|
|
|
|
while (1) { |
9855
|
139686
|
|
|
|
|
switch (*s) { |
9856
|
|
|
|
|
|
case 'c': |
9857
|
|
|
|
|
|
complement = OPpTRANS_COMPLEMENT; |
9858
|
|
|
|
|
|
break; |
9859
|
|
|
|
|
|
case 'd': |
9860
|
|
|
|
|
|
del = OPpTRANS_DELETE; |
9861
|
15794
|
|
|
|
|
break; |
9862
|
|
|
|
|
|
case 's': |
9863
|
|
|
|
|
|
squash = OPpTRANS_SQUASH; |
9864
|
6394
|
|
|
|
|
break; |
9865
|
|
|
|
|
|
case 'r': |
9866
|
|
|
|
|
|
nondestruct = 1; |
9867
|
28
|
|
|
|
|
break; |
9868
|
|
|
|
|
|
default: |
9869
|
|
|
|
|
|
goto no_more; |
9870
|
|
|
|
|
|
} |
9871
|
30436
|
|
|
|
|
s++; |
9872
|
30436
|
|
|
|
|
} |
9873
|
|
|
|
|
|
no_more: |
9874
|
|
|
|
|
|
|
9875
|
109250
|
100
|
|
|
|
o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL); |
9876
|
109250
|
|
|
|
|
o->op_private &= ~OPpTRANS_ALL; |
9877
|
372115
|
100
|
|
|
|
o->op_private |= del|squash|complement| |
|
|
100
|
|
|
|
|
9878
|
109270
|
50
|
|
|
|
(DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)| |
9879
|
109270
|
50
|
|
|
|
(DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0); |
9880
|
|
|
|
|
|
|
9881
|
109250
|
|
|
|
|
PL_lex_op = o; |
9882
|
109250
|
100
|
|
|
|
pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS; |
9883
|
|
|
|
|
|
|
9884
|
|
|
|
|
|
#ifdef PERL_MAD |
9885
|
|
|
|
|
|
if (PL_madskills) { |
9886
|
|
|
|
|
|
if (modstart != s) |
9887
|
|
|
|
|
|
curmad('m', newSVpvn(modstart, s - modstart)); |
9888
|
|
|
|
|
|
append_madprops(PL_thismad, o, 0); |
9889
|
|
|
|
|
|
PL_thismad = 0; |
9890
|
|
|
|
|
|
} |
9891
|
|
|
|
|
|
#endif |
9892
|
|
|
|
|
|
|
9893
|
109250
|
|
|
|
|
return s; |
9894
|
|
|
|
|
|
} |
9895
|
|
|
|
|
|
|
9896
|
|
|
|
|
|
/* scan_heredoc |
9897
|
|
|
|
|
|
Takes a pointer to the first < in <
|
9898
|
|
|
|
|
|
Returns a pointer to the byte following <
|
9899
|
|
|
|
|
|
|
9900
|
|
|
|
|
|
This function scans a heredoc, which involves different methods |
9901
|
|
|
|
|
|
depending on whether we are in a string eval, quoted construct, etc. |
9902
|
|
|
|
|
|
This is because PL_linestr could containing a single line of input, or |
9903
|
|
|
|
|
|
a whole string being evalled, or the contents of the current quote- |
9904
|
|
|
|
|
|
like operator. |
9905
|
|
|
|
|
|
|
9906
|
|
|
|
|
|
The two basic methods are: |
9907
|
|
|
|
|
|
- Steal lines from the input stream |
9908
|
|
|
|
|
|
- Scan the heredoc in PL_linestr and remove it therefrom |
9909
|
|
|
|
|
|
|
9910
|
|
|
|
|
|
In a file scope or filtered eval, the first method is used; in a |
9911
|
|
|
|
|
|
string eval, the second. |
9912
|
|
|
|
|
|
|
9913
|
|
|
|
|
|
In a quote-like operator, we have to choose between the two, |
9914
|
|
|
|
|
|
depending on where we can find a newline. We peek into outer lex- |
9915
|
|
|
|
|
|
ing scopes until we find one with a newline in it. If we reach the |
9916
|
|
|
|
|
|
outermost lexing scope and it is a file, we use the stream method. |
9917
|
|
|
|
|
|
Otherwise it is treated as an eval. |
9918
|
|
|
|
|
|
*/ |
9919
|
|
|
|
|
|
|
9920
|
|
|
|
|
|
STATIC char * |
9921
|
356411
|
|
|
|
|
S_scan_heredoc(pTHX_ char *s) |
9922
|
|
|
|
|
|
{ |
9923
|
|
|
|
|
|
dVAR; |
9924
|
|
|
|
|
|
I32 op_type = OP_SCALAR; |
9925
|
|
|
|
|
|
I32 len; |
9926
|
|
|
|
|
|
SV *tmpstr; |
9927
|
|
|
|
|
|
char term; |
9928
|
|
|
|
|
|
char *d; |
9929
|
|
|
|
|
|
char *e; |
9930
|
|
|
|
|
|
char *peek; |
9931
|
356411
|
100
|
|
|
|
const bool infile = PL_rsfp || PL_parser->filtered; |
|
|
50
|
|
|
|
|
9932
|
356411
|
|
|
|
|
LEXSHARED *shared = PL_parser->lex_shared; |
9933
|
|
|
|
|
|
#ifdef PERL_MAD |
9934
|
|
|
|
|
|
I32 stuffstart = s - SvPVX(PL_linestr); |
9935
|
|
|
|
|
|
char *tstart; |
9936
|
|
|
|
|
|
|
9937
|
|
|
|
|
|
PL_realtokenstart = -1; |
9938
|
|
|
|
|
|
#endif |
9939
|
|
|
|
|
|
|
9940
|
|
|
|
|
|
PERL_ARGS_ASSERT_SCAN_HEREDOC; |
9941
|
|
|
|
|
|
|
9942
|
356411
|
|
|
|
|
s += 2; |
9943
|
356411
|
|
|
|
|
d = PL_tokenbuf + 1; |
9944
|
356411
|
|
|
|
|
e = PL_tokenbuf + sizeof PL_tokenbuf - 1; |
9945
|
356411
|
|
|
|
|
*PL_tokenbuf = '\n'; |
9946
|
|
|
|
|
|
peek = s; |
9947
|
544184
|
100
|
|
|
|
while (SPACE_OR_TAB(*peek)) |
9948
|
10825
|
|
|
|
|
peek++; |
9949
|
356411
|
100
|
|
|
|
if (*peek == '`' || *peek == '\'' || *peek =='"') { |
|
|
100
|
|
|
|
|
9950
|
|
|
|
|
|
s = peek; |
9951
|
287680
|
|
|
|
|
term = *s++; |
9952
|
287680
|
|
|
|
|
s = delimcpy(d, e, s, PL_bufend, term, &len); |
9953
|
287680
|
100
|
|
|
|
if (s == PL_bufend) |
9954
|
2
|
|
|
|
|
Perl_croak(aTHX_ "Unterminated delimiter for here document"); |
9955
|
287678
|
|
|
|
|
d += len; |
9956
|
287678
|
|
|
|
|
s++; |
9957
|
|
|
|
|
|
} |
9958
|
|
|
|
|
|
else { |
9959
|
68731
|
100
|
|
|
|
if (*s == '\\') |
9960
|
|
|
|
|
|
/* <<\FOO is equivalent to <<'FOO' */ |
9961
|
8
|
|
|
|
|
s++, term = '\''; |
9962
|
|
|
|
|
|
else |
9963
|
|
|
|
|
|
term = '"'; |
9964
|
68731
|
100
|
|
|
|
if (!isWORDCHAR_lazy_if(s,UTF)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
9965
|
34762
|
|
|
|
|
deprecate("bare << to mean <<\"\""); |
9966
|
345022
|
100
|
|
|
|
for (; isWORDCHAR_lazy_if(s,UTF); s++) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
9967
|
310297
|
50
|
|
|
|
if (d < e) |
9968
|
310297
|
|
|
|
|
*d++ = *s; |
9969
|
|
|
|
|
|
} |
9970
|
|
|
|
|
|
} |
9971
|
356409
|
50
|
|
|
|
if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1) |
9972
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Delimiter for here document is too long"); |
9973
|
356409
|
|
|
|
|
*d++ = '\n'; |
9974
|
356409
|
|
|
|
|
*d = '\0'; |
9975
|
356409
|
|
|
|
|
len = d - PL_tokenbuf; |
9976
|
|
|
|
|
|
|
9977
|
|
|
|
|
|
#ifdef PERL_MAD |
9978
|
|
|
|
|
|
if (PL_madskills) { |
9979
|
|
|
|
|
|
tstart = PL_tokenbuf + 1; |
9980
|
|
|
|
|
|
PL_thisclose = newSVpvn(tstart, len - 1); |
9981
|
|
|
|
|
|
tstart = SvPVX(PL_linestr) + stuffstart; |
9982
|
|
|
|
|
|
PL_thisopen = newSVpvn(tstart, s - tstart); |
9983
|
|
|
|
|
|
stuffstart = s - SvPVX(PL_linestr); |
9984
|
|
|
|
|
|
} |
9985
|
|
|
|
|
|
#endif |
9986
|
|
|
|
|
|
#ifndef PERL_STRICT_CR |
9987
|
356409
|
|
|
|
|
d = strchr(s, '\r'); |
9988
|
356409
|
100
|
|
|
|
if (d) { |
9989
|
|
|
|
|
|
char * const olds = s; |
9990
|
|
|
|
|
|
s = d; |
9991
|
28
|
100
|
|
|
|
while (s < PL_bufend) { |
9992
|
14
|
50
|
|
|
|
if (*s == '\r') { |
9993
|
14
|
|
|
|
|
*d++ = '\n'; |
9994
|
14
|
50
|
|
|
|
if (*++s == '\n') |
9995
|
14
|
|
|
|
|
s++; |
9996
|
|
|
|
|
|
} |
9997
|
0
|
0
|
|
|
|
else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */ |
|
|
0
|
|
|
|
|
9998
|
0
|
|
|
|
|
*d++ = *s++; |
9999
|
0
|
|
|
|
|
s++; |
10000
|
|
|
|
|
|
} |
10001
|
|
|
|
|
|
else |
10002
|
7
|
|
|
|
|
*d++ = *s++; |
10003
|
|
|
|
|
|
} |
10004
|
14
|
|
|
|
|
*d = '\0'; |
10005
|
14
|
|
|
|
|
PL_bufend = d; |
10006
|
14
|
|
|
|
|
SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr)); |
10007
|
|
|
|
|
|
s = olds; |
10008
|
|
|
|
|
|
} |
10009
|
|
|
|
|
|
#endif |
10010
|
|
|
|
|
|
#ifdef PERL_MAD |
10011
|
|
|
|
|
|
if (PL_madskills) { |
10012
|
|
|
|
|
|
tstart = SvPVX(PL_linestr) + stuffstart; |
10013
|
|
|
|
|
|
if (PL_thisstuff) |
10014
|
|
|
|
|
|
sv_catpvn(PL_thisstuff, tstart, s - tstart); |
10015
|
|
|
|
|
|
else |
10016
|
|
|
|
|
|
PL_thisstuff = newSVpvn(tstart, s - tstart); |
10017
|
|
|
|
|
|
} |
10018
|
|
|
|
|
|
|
10019
|
|
|
|
|
|
stuffstart = s - SvPVX(PL_linestr); |
10020
|
|
|
|
|
|
#endif |
10021
|
|
|
|
|
|
|
10022
|
356409
|
|
|
|
|
tmpstr = newSV_type(SVt_PVIV); |
10023
|
356409
|
50
|
|
|
|
SvGROW(tmpstr, 80); |
|
|
50
|
|
|
|
|
10024
|
356409
|
100
|
|
|
|
if (term == '\'') { |
10025
|
|
|
|
|
|
op_type = OP_CONST; |
10026
|
222166
|
|
|
|
|
SvIV_set(tmpstr, -1); |
10027
|
|
|
|
|
|
} |
10028
|
134243
|
50
|
|
|
|
else if (term == '`') { |
10029
|
|
|
|
|
|
op_type = OP_BACKTICK; |
10030
|
0
|
|
|
|
|
SvIV_set(tmpstr, '\\'); |
10031
|
|
|
|
|
|
} |
10032
|
|
|
|
|
|
|
10033
|
356409
|
|
|
|
|
PL_multi_start = CopLINE(PL_curcop) + 1; |
10034
|
356409
|
|
|
|
|
PL_multi_open = PL_multi_close = '<'; |
10035
|
|
|
|
|
|
/* inside a string eval or quote-like operator */ |
10036
|
356409
|
100
|
|
|
|
if (!infile || PL_lex_inwhat) { |
|
|
100
|
|
|
|
|
10037
|
|
|
|
|
|
SV *linestr; |
10038
|
|
|
|
|
|
char *bufend; |
10039
|
|
|
|
|
|
char * const olds = s; |
10040
|
8934
|
|
|
|
|
PERL_CONTEXT * const cx = &cxstack[cxstack_ix]; |
10041
|
|
|
|
|
|
/* These two fields are not set until an inner lexing scope is |
10042
|
|
|
|
|
|
entered. But we need them set here. */ |
10043
|
8934
|
|
|
|
|
shared->ls_bufptr = s; |
10044
|
8934
|
|
|
|
|
shared->ls_linestr = PL_linestr; |
10045
|
8934
|
100
|
|
|
|
if (PL_lex_inwhat) |
10046
|
|
|
|
|
|
/* Look for a newline. If the current buffer does not have one, |
10047
|
|
|
|
|
|
peek into the line buffer of the parent lexing scope, going |
10048
|
|
|
|
|
|
up as many levels as necessary to find one with a newline |
10049
|
|
|
|
|
|
after bufptr. |
10050
|
|
|
|
|
|
*/ |
10051
|
126
|
100
|
|
|
|
while (!(s = (char *)memchr( |
10052
|
84
|
|
|
|
|
(void *)shared->ls_bufptr, '\n', |
10053
|
84
|
|
|
|
|
SvEND(shared->ls_linestr)-shared->ls_bufptr |
10054
|
|
|
|
|
|
))) { |
10055
|
40
|
|
|
|
|
shared = shared->ls_prev; |
10056
|
|
|
|
|
|
/* shared is only null if we have gone beyond the outermost |
10057
|
|
|
|
|
|
lexing scope. In a file, we will have broken out of the |
10058
|
|
|
|
|
|
loop in the previous iteration. In an eval, the string buf- |
10059
|
|
|
|
|
|
fer ends with "\n;", so the while condition above will have |
10060
|
|
|
|
|
|
evaluated to false. So shared can never be null. */ |
10061
|
|
|
|
|
|
assert(shared); |
10062
|
|
|
|
|
|
/* A LEXSHARED struct with a null ls_prev pointer is the outer- |
10063
|
|
|
|
|
|
most lexing scope. In a file, shared->ls_linestr at that |
10064
|
|
|
|
|
|
level is just one line, so there is no body to steal. */ |
10065
|
40
|
100
|
|
|
|
if (infile && !shared->ls_prev) { |
|
|
100
|
|
|
|
|
10066
|
|
|
|
|
|
s = olds; |
10067
|
|
|
|
|
|
goto streaming; |
10068
|
|
|
|
|
|
} |
10069
|
|
|
|
|
|
} |
10070
|
|
|
|
|
|
else { /* eval */ |
10071
|
8880
|
|
|
|
|
s = (char*)memchr((void*)s, '\n', PL_bufend - s); |
10072
|
|
|
|
|
|
assert(s); |
10073
|
|
|
|
|
|
} |
10074
|
8924
|
|
|
|
|
linestr = shared->ls_linestr; |
10075
|
8924
|
|
|
|
|
bufend = SvEND(linestr); |
10076
|
|
|
|
|
|
d = s; |
10077
|
6439283
|
100
|
|
|
|
while (s < bufend - len + 1 && |
|
|
100
|
|
|
|
|
10078
|
4289870
|
|
|
|
|
memNE(s,PL_tokenbuf,len) ) { |
10079
|
4280962
|
100
|
|
|
|
if (*s++ == '\n') |
10080
|
2204377
|
|
|
|
|
++shared->herelines; |
10081
|
|
|
|
|
|
} |
10082
|
8924
|
100
|
|
|
|
if (s >= bufend - len + 1) { |
10083
|
|
|
|
|
|
goto interminable; |
10084
|
|
|
|
|
|
} |
10085
|
8908
|
|
|
|
|
sv_setpvn(tmpstr,d+1,s-d); |
10086
|
|
|
|
|
|
#ifdef PERL_MAD |
10087
|
|
|
|
|
|
if (PL_madskills) { |
10088
|
|
|
|
|
|
if (PL_thisstuff) |
10089
|
|
|
|
|
|
sv_catpvn(PL_thisstuff, d + 1, s - d); |
10090
|
|
|
|
|
|
else |
10091
|
|
|
|
|
|
PL_thisstuff = newSVpvn(d + 1, s - d); |
10092
|
|
|
|
|
|
stuffstart = s - SvPVX(PL_linestr); |
10093
|
|
|
|
|
|
} |
10094
|
|
|
|
|
|
#endif |
10095
|
8908
|
|
|
|
|
s += len - 1; |
10096
|
|
|
|
|
|
/* the preceding stmt passes a newline */ |
10097
|
8908
|
|
|
|
|
shared->herelines++; |
10098
|
|
|
|
|
|
|
10099
|
|
|
|
|
|
/* s now points to the newline after the heredoc terminator. |
10100
|
|
|
|
|
|
d points to the newline before the body of the heredoc. |
10101
|
|
|
|
|
|
*/ |
10102
|
|
|
|
|
|
|
10103
|
|
|
|
|
|
/* We are going to modify linestr in place here, so set |
10104
|
|
|
|
|
|
aside copies of the string if necessary for re-evals or |
10105
|
|
|
|
|
|
(caller $n)[6]. */ |
10106
|
|
|
|
|
|
/* See the Paranoia note in case LEX_INTERPEND in yylex, for why we |
10107
|
|
|
|
|
|
check shared->re_eval_str. */ |
10108
|
8908
|
100
|
|
|
|
if (shared->re_eval_start || shared->re_eval_str) { |
|
|
50
|
|
|
|
|
10109
|
|
|
|
|
|
/* Set aside the rest of the regexp */ |
10110
|
6
|
50
|
|
|
|
if (!shared->re_eval_str) |
10111
|
6
|
|
|
|
|
shared->re_eval_str = |
10112
|
6
|
|
|
|
|
newSVpvn(shared->re_eval_start, |
10113
|
|
|
|
|
|
bufend - shared->re_eval_start); |
10114
|
6
|
|
|
|
|
shared->re_eval_start -= s-d; |
10115
|
|
|
|
|
|
} |
10116
|
13356
|
100
|
|
|
|
if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL && |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
10117
|
13344
|
100
|
|
|
|
CxOLD_OP_TYPE(cx) == OP_ENTEREVAL && |
10118
|
8896
|
|
|
|
|
cx->blk_eval.cur_text == linestr) |
10119
|
|
|
|
|
|
{ |
10120
|
158
|
|
|
|
|
cx->blk_eval.cur_text = newSVsv(linestr); |
10121
|
158
|
|
|
|
|
SvSCREAM_on(cx->blk_eval.cur_text); |
10122
|
|
|
|
|
|
} |
10123
|
|
|
|
|
|
/* Copy everything from s onwards back to d. */ |
10124
|
8908
|
|
|
|
|
Move(s,d,bufend-s + 1,char); |
10125
|
8908
|
|
|
|
|
SvCUR_set(linestr, SvCUR(linestr) - (s-d)); |
10126
|
|
|
|
|
|
/* Setting PL_bufend only applies when we have not dug deeper |
10127
|
|
|
|
|
|
into other scopes, because sublex_done sets PL_bufend to |
10128
|
|
|
|
|
|
SvEND(PL_linestr). */ |
10129
|
8908
|
100
|
|
|
|
if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr); |
10130
|
|
|
|
|
|
s = olds; |
10131
|
|
|
|
|
|
} |
10132
|
|
|
|
|
|
else |
10133
|
|
|
|
|
|
{ |
10134
|
|
|
|
|
|
SV *linestr_save; |
10135
|
|
|
|
|
|
streaming: |
10136
|
347485
|
|
|
|
|
sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */ |
10137
|
347485
|
|
|
|
|
term = PL_tokenbuf[1]; |
10138
|
347485
|
|
|
|
|
len--; |
10139
|
347485
|
|
|
|
|
linestr_save = PL_linestr; /* must restore this afterwards */ |
10140
|
|
|
|
|
|
d = s; /* and this */ |
10141
|
347485
|
|
|
|
|
PL_linestr = newSVpvs(""); |
10142
|
347485
|
|
|
|
|
PL_bufend = SvPVX(PL_linestr); |
10143
|
|
|
|
|
|
while (1) { |
10144
|
|
|
|
|
|
#ifdef PERL_MAD |
10145
|
|
|
|
|
|
if (PL_madskills) { |
10146
|
|
|
|
|
|
tstart = SvPVX(PL_linestr) + stuffstart; |
10147
|
|
|
|
|
|
if (PL_thisstuff) |
10148
|
|
|
|
|
|
sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart); |
10149
|
|
|
|
|
|
else |
10150
|
|
|
|
|
|
PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart); |
10151
|
|
|
|
|
|
} |
10152
|
|
|
|
|
|
#endif |
10153
|
16607154
|
|
|
|
|
PL_bufptr = PL_bufend; |
10154
|
16607154
|
|
|
|
|
CopLINE_set(PL_curcop, |
10155
|
|
|
|
|
|
PL_multi_start + shared->herelines); |
10156
|
16607154
|
100
|
|
|
|
if (!lex_next_chunk(LEX_NO_TERM) |
10157
|
74
|
100
|
|
|
|
&& (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) { |
|
|
100
|
|
|
|
|
10158
|
70
|
|
|
|
|
SvREFCNT_dec(linestr_save); |
10159
|
70
|
|
|
|
|
goto interminable; |
10160
|
|
|
|
|
|
} |
10161
|
16607084
|
|
|
|
|
CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1); |
10162
|
16607084
|
100
|
|
|
|
if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') { |
|
|
100
|
|
|
|
|
10163
|
72
|
|
|
|
|
s = lex_grow_linestr(SvLEN(PL_linestr) + 3); |
10164
|
|
|
|
|
|
/* ^That should be enough to avoid this needing to grow: */ |
10165
|
72
|
|
|
|
|
sv_catpvs(PL_linestr, "\n\0"); |
10166
|
|
|
|
|
|
assert(s == SvPVX(PL_linestr)); |
10167
|
72
|
|
|
|
|
PL_bufend = SvEND(PL_linestr); |
10168
|
|
|
|
|
|
} |
10169
|
16607084
|
|
|
|
|
s = PL_bufptr; |
10170
|
|
|
|
|
|
#ifdef PERL_MAD |
10171
|
|
|
|
|
|
stuffstart = s - SvPVX(PL_linestr); |
10172
|
|
|
|
|
|
#endif |
10173
|
16607084
|
|
|
|
|
shared->herelines++; |
10174
|
16607084
|
|
|
|
|
PL_last_lop = PL_last_uni = NULL; |
10175
|
|
|
|
|
|
#ifndef PERL_STRICT_CR |
10176
|
16607084
|
100
|
|
|
|
if (PL_bufend - PL_linestart >= 2) { |
10177
|
24423553
|
100
|
|
|
|
if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') || |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
10178
|
7999177
|
50
|
|
|
|
(PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r')) |
10179
|
|
|
|
|
|
{ |
10180
|
816
|
|
|
|
|
PL_bufend[-2] = '\n'; |
10181
|
816
|
|
|
|
|
PL_bufend--; |
10182
|
816
|
|
|
|
|
SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr)); |
10183
|
|
|
|
|
|
} |
10184
|
16423632
|
50
|
|
|
|
else if (PL_bufend[-1] == '\r') |
10185
|
0
|
|
|
|
|
PL_bufend[-1] = '\n'; |
10186
|
|
|
|
|
|
} |
10187
|
182636
|
50
|
|
|
|
else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r') |
|
|
50
|
|
|
|
|
10188
|
0
|
|
|
|
|
PL_bufend[-1] = '\n'; |
10189
|
|
|
|
|
|
#endif |
10190
|
16607084
|
100
|
|
|
|
if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) { |
|
|
100
|
|
|
|
|
10191
|
347415
|
|
|
|
|
SvREFCNT_dec(PL_linestr); |
10192
|
347415
|
|
|
|
|
PL_linestr = linestr_save; |
10193
|
347415
|
|
|
|
|
PL_linestart = SvPVX(linestr_save); |
10194
|
347415
|
|
|
|
|
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); |
10195
|
|
|
|
|
|
s = d; |
10196
|
347415
|
|
|
|
|
break; |
10197
|
|
|
|
|
|
} |
10198
|
|
|
|
|
|
else { |
10199
|
16259669
|
|
|
|
|
sv_catsv(tmpstr,PL_linestr); |
10200
|
|
|
|
|
|
} |
10201
|
16259669
|
|
|
|
|
} |
10202
|
|
|
|
|
|
} |
10203
|
356323
|
|
|
|
|
PL_multi_end = CopLINE(PL_curcop); |
10204
|
356323
|
100
|
|
|
|
if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) { |
10205
|
291782
|
|
|
|
|
SvPV_shrink_to_cur(tmpstr); |
10206
|
|
|
|
|
|
} |
10207
|
356323
|
100
|
|
|
|
if (!IN_BYTES) { |
10208
|
355821
|
50
|
|
|
|
if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr))) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
10209
|
36
|
|
|
|
|
SvUTF8_on(tmpstr); |
10210
|
355785
|
50
|
|
|
|
else if (PL_encoding) |
10211
|
0
|
|
|
|
|
sv_recode_to_utf8(tmpstr, PL_encoding); |
10212
|
|
|
|
|
|
} |
10213
|
356323
|
|
|
|
|
PL_lex_stuff = tmpstr; |
10214
|
356323
|
|
|
|
|
pl_yylval.ival = op_type; |
10215
|
356323
|
|
|
|
|
return s; |
10216
|
|
|
|
|
|
|
10217
|
|
|
|
|
|
interminable: |
10218
|
86
|
|
|
|
|
SvREFCNT_dec(tmpstr); |
10219
|
86
|
|
|
|
|
CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1); |
10220
|
86
|
|
|
|
|
missingterm(PL_tokenbuf + 1); |
10221
|
|
|
|
|
|
} |
10222
|
|
|
|
|
|
|
10223
|
|
|
|
|
|
/* scan_inputsymbol |
10224
|
|
|
|
|
|
takes: current position in input buffer |
10225
|
|
|
|
|
|
returns: new position in input buffer |
10226
|
|
|
|
|
|
side-effects: pl_yylval and lex_op are set. |
10227
|
|
|
|
|
|
|
10228
|
|
|
|
|
|
This code handles: |
10229
|
|
|
|
|
|
|
10230
|
|
|
|
|
|
<> read from ARGV |
10231
|
|
|
|
|
|
read from filehandle |
10232
|
|
|
|
|
|
read from package qualified filehandle |
10233
|
|
|
|
|
|
read from package qualified filehandle |
10234
|
|
|
|
|
|
<$fh> read from filehandle in $fh |
10235
|
|
|
|
|
|
<*.h> filename glob |
10236
|
|
|
|
|
|
|
10237
|
|
|
|
|
|
*/ |
10238
|
|
|
|
|
|
|
10239
|
|
|
|
|
|
STATIC char * |
10240
|
90900
|
|
|
|
|
S_scan_inputsymbol(pTHX_ char *start) |
10241
|
|
|
|
|
|
{ |
10242
|
|
|
|
|
|
dVAR; |
10243
|
|
|
|
|
|
char *s = start; /* current position in buffer */ |
10244
|
|
|
|
|
|
char *end; |
10245
|
|
|
|
|
|
I32 len; |
10246
|
90900
|
|
|
|
|
char *d = PL_tokenbuf; /* start of temp holding space */ |
10247
|
90900
|
|
|
|
|
const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */ |
10248
|
|
|
|
|
|
|
10249
|
|
|
|
|
|
PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL; |
10250
|
|
|
|
|
|
|
10251
|
90900
|
|
|
|
|
end = strchr(s, '\n'); |
10252
|
90900
|
100
|
|
|
|
if (!end) |
10253
|
16
|
|
|
|
|
end = PL_bufend; |
10254
|
90900
|
|
|
|
|
s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */ |
10255
|
|
|
|
|
|
|
10256
|
|
|
|
|
|
/* die if we didn't have space for the contents of the <>, |
10257
|
|
|
|
|
|
or if it didn't end, or if we see a newline |
10258
|
|
|
|
|
|
*/ |
10259
|
|
|
|
|
|
|
10260
|
90900
|
50
|
|
|
|
if (len >= (I32)sizeof PL_tokenbuf) |
10261
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Excessively long <> operator"); |
10262
|
90900
|
100
|
|
|
|
if (s >= end) |
10263
|
4
|
|
|
|
|
Perl_croak(aTHX_ "Unterminated <> operator"); |
10264
|
|
|
|
|
|
|
10265
|
|
|
|
|
|
s++; |
10266
|
|
|
|
|
|
|
10267
|
|
|
|
|
|
/* check for <$fh> |
10268
|
|
|
|
|
|
Remember, only scalar variables are interpreted as filehandles by |
10269
|
|
|
|
|
|
this code. Anything more complex (e.g., <$fh{$num}>) will be |
10270
|
|
|
|
|
|
treated as a glob() call. |
10271
|
|
|
|
|
|
This code makes use of the fact that except for the $ at the front, |
10272
|
|
|
|
|
|
a scalar variable and a filehandle look the same. |
10273
|
|
|
|
|
|
*/ |
10274
|
90896
|
100
|
|
|
|
if (*d == '$' && d[1]) d++; |
|
|
50
|
|
|
|
|
10275
|
|
|
|
|
|
|
10276
|
|
|
|
|
|
/* allow or */ |
10277
|
403640
|
100
|
|
|
|
while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':')) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
10278
|
312744
|
50
|
|
|
|
d += UTF ? UTF8SKIP(d) : 1; |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
10279
|
|
|
|
|
|
|
10280
|
|
|
|
|
|
/* If we've tried to read what we allow filehandles to look like, and |
10281
|
|
|
|
|
|
there's still text left, then it must be a glob() and not a getline. |
10282
|
|
|
|
|
|
Use scan_str to pull out the stuff between the <> and treat it |
10283
|
|
|
|
|
|
as nothing more than a string. |
10284
|
|
|
|
|
|
*/ |
10285
|
|
|
|
|
|
|
10286
|
90896
|
100
|
|
|
|
if (d - PL_tokenbuf != len) { |
10287
|
216
|
|
|
|
|
pl_yylval.ival = OP_GLOB; |
10288
|
216
|
|
|
|
|
s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE); |
10289
|
216
|
50
|
|
|
|
if (!s) |
10290
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Glob not terminated"); |
10291
|
|
|
|
|
|
return s; |
10292
|
|
|
|
|
|
} |
10293
|
|
|
|
|
|
else { |
10294
|
|
|
|
|
|
bool readline_overriden = FALSE; |
10295
|
|
|
|
|
|
GV *gv_readline; |
10296
|
|
|
|
|
|
GV **gvp; |
10297
|
|
|
|
|
|
/* we're in a filehandle read situation */ |
10298
|
90680
|
|
|
|
|
d = PL_tokenbuf; |
10299
|
|
|
|
|
|
|
10300
|
|
|
|
|
|
/* turn <> into */ |
10301
|
90680
|
100
|
|
|
|
if (!len) |
10302
|
2548
|
|
|
|
|
Copy("ARGV",d,5,char); |
10303
|
|
|
|
|
|
|
10304
|
|
|
|
|
|
/* Check whether readline() is overriden */ |
10305
|
90680
|
|
|
|
|
gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV); |
10306
|
90680
|
100
|
|
|
|
if ((gv_readline |
10307
|
410
|
50
|
|
|
|
&& GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
10308
|
90674
|
100
|
|
|
|
|| |
10309
|
90674
|
|
|
|
|
((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE)) |
10310
|
8
|
50
|
|
|
|
&& (gv_readline = *gvp) && isGV_with_GP(gv_readline) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
10311
|
6
|
50
|
|
|
|
&& GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
10312
|
|
|
|
|
|
readline_overriden = TRUE; |
10313
|
|
|
|
|
|
|
10314
|
|
|
|
|
|
/* if <$fh>, create the ops to turn the variable into a |
10315
|
|
|
|
|
|
filehandle |
10316
|
|
|
|
|
|
*/ |
10317
|
90680
|
100
|
|
|
|
if (*d == '$') { |
10318
|
|
|
|
|
|
/* try to find it in the pad for this block, otherwise find |
10319
|
|
|
|
|
|
add symbol table ops |
10320
|
|
|
|
|
|
*/ |
10321
|
55724
|
50
|
|
|
|
const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
10322
|
55724
|
100
|
|
|
|
if (tmp != NOT_IN_PAD) { |
10323
|
55604
|
100
|
|
|
|
if (PAD_COMPNAME_FLAGS_isOUR(tmp)) { |
10324
|
4
|
50
|
|
|
|
HV * const stash = PAD_COMPNAME_OURSTASH(tmp); |
10325
|
4
|
50
|
|
|
|
HEK * const stashname = HvNAME_HEK(stash); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
10326
|
4
|
|
|
|
|
SV * const sym = sv_2mortal(newSVhek(stashname)); |
10327
|
4
|
|
|
|
|
sv_catpvs(sym, "::"); |
10328
|
4
|
|
|
|
|
sv_catpv(sym, d+1); |
10329
|
4
|
|
|
|
|
d = SvPVX(sym); |
10330
|
4
|
|
|
|
|
goto intro_sym; |
10331
|
|
|
|
|
|
} |
10332
|
|
|
|
|
|
else { |
10333
|
55600
|
|
|
|
|
OP * const o = newOP(OP_PADSV, 0); |
10334
|
55600
|
|
|
|
|
o->op_targ = tmp; |
10335
|
82320
|
|
|
|
|
PL_lex_op = readline_overriden |
10336
|
4
|
|
|
|
|
? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, |
10337
|
|
|
|
|
|
op_append_elem(OP_LIST, o, |
10338
|
|
|
|
|
|
newCVREF(0, newGVOP(OP_GV,0,gv_readline)))) |
10339
|
55604
|
100
|
|
|
|
: (OP*)newUNOP(OP_READLINE, 0, o); |
10340
|
|
|
|
|
|
} |
10341
|
|
|
|
|
|
} |
10342
|
|
|
|
|
|
else { |
10343
|
|
|
|
|
|
GV *gv; |
10344
|
120
|
|
|
|
|
++d; |
10345
|
|
|
|
|
|
intro_sym: |
10346
|
124
|
100
|
|
|
|
gv = gv_fetchpv(d, |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
10347
|
|
|
|
|
|
(PL_in_eval |
10348
|
|
|
|
|
|
? (GV_ADDMULTI | GV_ADDINEVAL) |
10349
|
|
|
|
|
|
: GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ), |
10350
|
|
|
|
|
|
SVt_PV); |
10351
|
186
|
|
|
|
|
PL_lex_op = readline_overriden |
10352
|
4
|
|
|
|
|
? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, |
10353
|
|
|
|
|
|
op_append_elem(OP_LIST, |
10354
|
|
|
|
|
|
newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)), |
10355
|
|
|
|
|
|
newCVREF(0, newGVOP(OP_GV, 0, gv_readline)))) |
10356
|
128
|
100
|
|
|
|
: (OP*)newUNOP(OP_READLINE, 0, |
10357
|
|
|
|
|
|
newUNOP(OP_RV2SV, 0, |
10358
|
|
|
|
|
|
newGVOP(OP_GV, 0, gv))); |
10359
|
|
|
|
|
|
} |
10360
|
55724
|
100
|
|
|
|
if (!readline_overriden) |
10361
|
55716
|
|
|
|
|
PL_lex_op->op_flags |= OPf_SPECIAL; |
10362
|
|
|
|
|
|
/* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */ |
10363
|
55724
|
|
|
|
|
pl_yylval.ival = OP_NULL; |
10364
|
|
|
|
|
|
} |
10365
|
|
|
|
|
|
|
10366
|
|
|
|
|
|
/* If it's none of the above, it must be a literal filehandle |
10367
|
|
|
|
|
|
( or ) so build a simple readline OP */ |
10368
|
|
|
|
|
|
else { |
10369
|
34956
|
50
|
|
|
|
GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
10370
|
69912
|
|
|
|
|
PL_lex_op = readline_overriden |
10371
|
4
|
|
|
|
|
? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, |
10372
|
|
|
|
|
|
op_append_elem(OP_LIST, |
10373
|
|
|
|
|
|
newGVOP(OP_GV, 0, gv), |
10374
|
|
|
|
|
|
newCVREF(0, newGVOP(OP_GV, 0, gv_readline)))) |
10375
|
34960
|
100
|
|
|
|
: (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv)); |
10376
|
34956
|
|
|
|
|
pl_yylval.ival = OP_NULL; |
10377
|
|
|
|
|
|
} |
10378
|
|
|
|
|
|
} |
10379
|
|
|
|
|
|
|
10380
|
90788
|
|
|
|
|
return s; |
10381
|
|
|
|
|
|
} |
10382
|
|
|
|
|
|
|
10383
|
|
|
|
|
|
|
10384
|
|
|
|
|
|
/* scan_str |
10385
|
|
|
|
|
|
takes: |
10386
|
|
|
|
|
|
start position in buffer |
10387
|
|
|
|
|
|
keep_quoted preserve \ on the embedded delimiter(s) |
10388
|
|
|
|
|
|
keep_delims preserve the delimiters around the string |
10389
|
|
|
|
|
|
re_reparse compiling a run-time /(?{})/: |
10390
|
|
|
|
|
|
collapse // to /, and skip encoding src |
10391
|
|
|
|
|
|
deprecate_escaped_meta issue a deprecation warning for cer- |
10392
|
|
|
|
|
|
tain paired metacharacters that appear |
10393
|
|
|
|
|
|
escaped within it |
10394
|
|
|
|
|
|
returns: position to continue reading from buffer |
10395
|
|
|
|
|
|
side-effects: multi_start, multi_close, lex_repl or lex_stuff, and |
10396
|
|
|
|
|
|
updates the read buffer. |
10397
|
|
|
|
|
|
|
10398
|
|
|
|
|
|
This subroutine pulls a string out of the input. It is called for: |
10399
|
|
|
|
|
|
q single quotes q(literal text) |
10400
|
|
|
|
|
|
' single quotes 'literal text' |
10401
|
|
|
|
|
|
qq double quotes qq(interpolate $here please) |
10402
|
|
|
|
|
|
" double quotes "interpolate $here please" |
10403
|
|
|
|
|
|
qx backticks qx(/bin/ls -l) |
10404
|
|
|
|
|
|
` backticks `/bin/ls -l` |
10405
|
|
|
|
|
|
qw quote words @EXPORT_OK = qw( func() $spam ) |
10406
|
|
|
|
|
|
m// regexp match m/this/ |
10407
|
|
|
|
|
|
s/// regexp substitute s/this/that/ |
10408
|
|
|
|
|
|
tr/// string transliterate tr/this/that/ |
10409
|
|
|
|
|
|
y/// string transliterate y/this/that/ |
10410
|
|
|
|
|
|
($*@) sub prototypes sub foo ($) |
10411
|
|
|
|
|
|
(stuff) sub attr parameters sub foo : attr(stuff) |
10412
|
|
|
|
|
|
<> readline or globs , <>, <$fh>, or <*.c> |
10413
|
|
|
|
|
|
|
10414
|
|
|
|
|
|
In most of these cases (all but <>, patterns and transliterate) |
10415
|
|
|
|
|
|
yylex() calls scan_str(). m// makes yylex() call scan_pat() which |
10416
|
|
|
|
|
|
calls scan_str(). s/// makes yylex() call scan_subst() which calls |
10417
|
|
|
|
|
|
scan_str(). tr/// and y/// make yylex() call scan_trans() which |
10418
|
|
|
|
|
|
calls scan_str(). |
10419
|
|
|
|
|
|
|
10420
|
|
|
|
|
|
It skips whitespace before the string starts, and treats the first |
10421
|
|
|
|
|
|
character as the delimiter. If the delimiter is one of ([{< then |
10422
|
|
|
|
|
|
the corresponding "close" character )]}> is used as the closing |
10423
|
|
|
|
|
|
delimiter. It allows quoting of delimiters, and if the string has |
10424
|
|
|
|
|
|
balanced delimiters ([{<>}]) it allows nesting. |
10425
|
|
|
|
|
|
|
10426
|
|
|
|
|
|
On success, the SV with the resulting string is put into lex_stuff or, |
10427
|
|
|
|
|
|
if that is already non-NULL, into lex_repl. The second case occurs only |
10428
|
|
|
|
|
|
when parsing the RHS of the special constructs s/// and tr/// (y///). |
10429
|
|
|
|
|
|
For convenience, the terminating delimiter character is stuffed into |
10430
|
|
|
|
|
|
SvIVX of the SV. |
10431
|
|
|
|
|
|
*/ |
10432
|
|
|
|
|
|
|
10433
|
|
|
|
|
|
STATIC char * |
10434
|
56070300
|
|
|
|
|
S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, |
10435
|
|
|
|
|
|
bool deprecate_escaped_meta |
10436
|
|
|
|
|
|
) |
10437
|
|
|
|
|
|
{ |
10438
|
|
|
|
|
|
dVAR; |
10439
|
|
|
|
|
|
SV *sv; /* scalar value: string */ |
10440
|
|
|
|
|
|
const char *tmps; /* temp string, used for delimiter matching */ |
10441
|
|
|
|
|
|
char *s = start; /* current position in the buffer */ |
10442
|
|
|
|
|
|
char term; /* terminating character */ |
10443
|
|
|
|
|
|
char *to; /* current position in the sv's data */ |
10444
|
|
|
|
|
|
I32 brackets = 1; /* bracket nesting level */ |
10445
|
|
|
|
|
|
bool has_utf8 = FALSE; /* is there any utf8 content? */ |
10446
|
|
|
|
|
|
I32 termcode; /* terminating char. code */ |
10447
|
|
|
|
|
|
U8 termstr[UTF8_MAXBYTES]; /* terminating string */ |
10448
|
|
|
|
|
|
STRLEN termlen; /* length of terminating string */ |
10449
|
|
|
|
|
|
int last_off = 0; /* last position for nesting bracket */ |
10450
|
|
|
|
|
|
char *escaped_open = NULL; |
10451
|
|
|
|
|
|
line_t herelines; |
10452
|
|
|
|
|
|
#ifdef PERL_MAD |
10453
|
|
|
|
|
|
int stuffstart; |
10454
|
|
|
|
|
|
char *tstart; |
10455
|
|
|
|
|
|
#endif |
10456
|
|
|
|
|
|
|
10457
|
|
|
|
|
|
PERL_ARGS_ASSERT_SCAN_STR; |
10458
|
|
|
|
|
|
|
10459
|
|
|
|
|
|
/* skip space before the delimiter */ |
10460
|
56070300
|
100
|
|
|
|
if (isSPACE(*s)) { |
10461
|
79437
|
|
|
|
|
s = PEEKSPACE(s); |
10462
|
|
|
|
|
|
} |
10463
|
|
|
|
|
|
|
10464
|
|
|
|
|
|
#ifdef PERL_MAD |
10465
|
|
|
|
|
|
if (PL_realtokenstart >= 0) { |
10466
|
|
|
|
|
|
stuffstart = PL_realtokenstart; |
10467
|
|
|
|
|
|
PL_realtokenstart = -1; |
10468
|
|
|
|
|
|
} |
10469
|
|
|
|
|
|
else |
10470
|
|
|
|
|
|
stuffstart = start - SvPVX(PL_linestr); |
10471
|
|
|
|
|
|
#endif |
10472
|
|
|
|
|
|
/* mark where we are, in case we need to report errors */ |
10473
|
56070300
|
|
|
|
|
CLINE; |
10474
|
|
|
|
|
|
|
10475
|
|
|
|
|
|
/* after skipping whitespace, the next character is the terminator */ |
10476
|
56070300
|
|
|
|
|
term = *s; |
10477
|
56070300
|
50
|
|
|
|
if (!UTF) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
10478
|
54956378
|
|
|
|
|
termcode = termstr[0] = term; |
10479
|
54956378
|
|
|
|
|
termlen = 1; |
10480
|
|
|
|
|
|
} |
10481
|
|
|
|
|
|
else { |
10482
|
1113922
|
100
|
|
|
|
termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen); |
10483
|
1113922
|
|
|
|
|
Copy(s, termstr, termlen, U8); |
10484
|
1113922
|
100
|
|
|
|
if (!UTF8_IS_INVARIANT(term)) |
10485
|
|
|
|
|
|
has_utf8 = TRUE; |
10486
|
|
|
|
|
|
} |
10487
|
|
|
|
|
|
|
10488
|
|
|
|
|
|
/* mark where we are */ |
10489
|
56070300
|
|
|
|
|
PL_multi_start = CopLINE(PL_curcop); |
10490
|
56070300
|
|
|
|
|
PL_multi_open = term; |
10491
|
56070300
|
|
|
|
|
herelines = PL_parser->lex_shared->herelines; |
10492
|
|
|
|
|
|
|
10493
|
|
|
|
|
|
/* find corresponding closing delimiter */ |
10494
|
56070300
|
100
|
|
|
|
if (term && (tmps = strchr("([{< )]}> )]}>",term))) |
|
|
100
|
|
|
|
|
10495
|
3744237
|
|
|
|
|
termcode = termstr[0] = term = tmps[5]; |
10496
|
|
|
|
|
|
|
10497
|
56070300
|
|
|
|
|
PL_multi_close = term; |
10498
|
|
|
|
|
|
|
10499
|
|
|
|
|
|
/* A warning is raised if the input parameter requires it for escaped (by a |
10500
|
|
|
|
|
|
* backslash) paired metacharacters {} [] and () when the delimiters are |
10501
|
|
|
|
|
|
* those same characters, and the backslash is ineffective. This doesn't |
10502
|
|
|
|
|
|
* happen for <>, as they aren't metas. */ |
10503
|
56070300
|
100
|
|
|
|
if (deprecate_escaped_meta |
10504
|
4736851
|
100
|
|
|
|
&& (PL_multi_open == PL_multi_close |
10505
|
484315
|
100
|
|
|
|
|| PL_multi_open == '<' |
10506
|
476707
|
100
|
|
|
|
|| ! ckWARN_d(WARN_DEPRECATED))) |
10507
|
|
|
|
|
|
{ |
10508
|
|
|
|
|
|
deprecate_escaped_meta = FALSE; |
10509
|
|
|
|
|
|
} |
10510
|
|
|
|
|
|
|
10511
|
|
|
|
|
|
/* create a new SV to hold the contents. 79 is the SV's initial length. |
10512
|
|
|
|
|
|
What a random number. */ |
10513
|
56070300
|
|
|
|
|
sv = newSV_type(SVt_PVIV); |
10514
|
56070300
|
50
|
|
|
|
SvGROW(sv, 80); |
|
|
50
|
|
|
|
|
10515
|
56070300
|
|
|
|
|
SvIV_set(sv, termcode); |
10516
|
56070300
|
|
|
|
|
(void)SvPOK_only(sv); /* validate pointer */ |
10517
|
|
|
|
|
|
|
10518
|
|
|
|
|
|
/* move past delimiter and try to read a complete string */ |
10519
|
56070300
|
100
|
|
|
|
if (keep_delims) |
10520
|
146
|
|
|
|
|
sv_catpvn(sv, s, termlen); |
10521
|
56070300
|
|
|
|
|
s += termlen; |
10522
|
|
|
|
|
|
#ifdef PERL_MAD |
10523
|
|
|
|
|
|
tstart = SvPVX(PL_linestr) + stuffstart; |
10524
|
|
|
|
|
|
if (PL_madskills && !PL_thisopen && !keep_delims) { |
10525
|
|
|
|
|
|
PL_thisopen = newSVpvn(tstart, s - tstart); |
10526
|
|
|
|
|
|
stuffstart = s - SvPVX(PL_linestr); |
10527
|
|
|
|
|
|
} |
10528
|
|
|
|
|
|
#endif |
10529
|
|
|
|
|
|
for (;;) { |
10530
|
59872816
|
100
|
|
|
|
if (PL_encoding && !UTF && !re_reparse) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
10531
|
|
|
|
|
|
bool cont = TRUE; |
10532
|
|
|
|
|
|
|
10533
|
3320
|
100
|
|
|
|
while (cont) { |
10534
|
1692
|
|
|
|
|
int offset = s - SvPVX_const(PL_linestr); |
10535
|
1692
|
|
|
|
|
const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr, |
10536
|
|
|
|
|
|
&offset, (char*)termstr, termlen); |
10537
|
|
|
|
|
|
const char *ns; |
10538
|
|
|
|
|
|
char *svlast; |
10539
|
|
|
|
|
|
|
10540
|
1692
|
100
|
|
|
|
if (SvIsCOW(PL_linestr)) { |
10541
|
|
|
|
|
|
STRLEN bufend_pos, bufptr_pos, oldbufptr_pos; |
10542
|
|
|
|
|
|
STRLEN oldoldbufptr_pos, linestart_pos, last_uni_pos; |
10543
|
|
|
|
|
|
STRLEN last_lop_pos, re_eval_start_pos, s_pos; |
10544
|
44
|
|
|
|
|
char *buf = SvPVX(PL_linestr); |
10545
|
44
|
|
|
|
|
bufend_pos = PL_parser->bufend - buf; |
10546
|
44
|
|
|
|
|
bufptr_pos = PL_parser->bufptr - buf; |
10547
|
44
|
|
|
|
|
oldbufptr_pos = PL_parser->oldbufptr - buf; |
10548
|
44
|
|
|
|
|
oldoldbufptr_pos = PL_parser->oldoldbufptr - buf; |
10549
|
44
|
|
|
|
|
linestart_pos = PL_parser->linestart - buf; |
10550
|
50
|
100
|
|
|
|
last_uni_pos = PL_parser->last_uni |
10551
|
12
|
|
|
|
|
? PL_parser->last_uni - buf |
10552
|
|
|
|
|
|
: 0; |
10553
|
50
|
100
|
|
|
|
last_lop_pos = PL_parser->last_lop |
10554
|
12
|
|
|
|
|
? PL_parser->last_lop - buf |
10555
|
|
|
|
|
|
: 0; |
10556
|
44
|
50
|
|
|
|
re_eval_start_pos = |
10557
|
44
|
|
|
|
|
PL_parser->lex_shared->re_eval_start ? |
10558
|
0
|
|
|
|
|
PL_parser->lex_shared->re_eval_start - buf : 0; |
10559
|
44
|
|
|
|
|
s_pos = s - buf; |
10560
|
|
|
|
|
|
|
10561
|
44
|
|
|
|
|
sv_force_normal(PL_linestr); |
10562
|
|
|
|
|
|
|
10563
|
44
|
|
|
|
|
buf = SvPVX(PL_linestr); |
10564
|
44
|
|
|
|
|
PL_parser->bufend = buf + bufend_pos; |
10565
|
44
|
|
|
|
|
PL_parser->bufptr = buf + bufptr_pos; |
10566
|
44
|
|
|
|
|
PL_parser->oldbufptr = buf + oldbufptr_pos; |
10567
|
44
|
|
|
|
|
PL_parser->oldoldbufptr = buf + oldoldbufptr_pos; |
10568
|
44
|
|
|
|
|
PL_parser->linestart = buf + linestart_pos; |
10569
|
44
|
100
|
|
|
|
if (PL_parser->last_uni) |
10570
|
12
|
|
|
|
|
PL_parser->last_uni = buf + last_uni_pos; |
10571
|
44
|
100
|
|
|
|
if (PL_parser->last_lop) |
10572
|
12
|
|
|
|
|
PL_parser->last_lop = buf + last_lop_pos; |
10573
|
44
|
50
|
|
|
|
if (PL_parser->lex_shared->re_eval_start) |
10574
|
0
|
|
|
|
|
PL_parser->lex_shared->re_eval_start = |
10575
|
0
|
|
|
|
|
buf + re_eval_start_pos; |
10576
|
44
|
|
|
|
|
s = buf + s_pos; |
10577
|
|
|
|
|
|
} |
10578
|
1692
|
|
|
|
|
ns = SvPVX_const(PL_linestr) + offset; |
10579
|
1692
|
|
|
|
|
svlast = SvEND(sv) - 1; |
10580
|
|
|
|
|
|
|
10581
|
20360
|
100
|
|
|
|
for (; s < ns; s++) { |
10582
|
18668
|
100
|
|
|
|
if (*s == '\n' && !PL_rsfp && !PL_parser->filtered) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
10583
|
10
|
50
|
|
|
|
COPLINE_INC_WITH_HERELINES; |
10584
|
|
|
|
|
|
} |
10585
|
1692
|
50
|
|
|
|
if (!found) |
10586
|
|
|
|
|
|
goto read_more_line; |
10587
|
|
|
|
|
|
else { |
10588
|
|
|
|
|
|
/* handle quoted delimiters */ |
10589
|
1692
|
100
|
|
|
|
if (SvCUR(sv) > 1 && *(svlast-1) == '\\') { |
|
|
100
|
|
|
|
|
10590
|
|
|
|
|
|
const char *t; |
10591
|
96
|
50
|
|
|
|
for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';) |
|
|
50
|
|
|
|
|
10592
|
0
|
|
|
|
|
t--; |
10593
|
64
|
50
|
|
|
|
if ((svlast-1 - t) % 2) { |
10594
|
64
|
50
|
|
|
|
if (!keep_quoted) { |
10595
|
64
|
|
|
|
|
*(svlast-1) = term; |
10596
|
64
|
|
|
|
|
*svlast = '\0'; |
10597
|
64
|
|
|
|
|
SvCUR_set(sv, SvCUR(sv) - 1); |
10598
|
|
|
|
|
|
} |
10599
|
64
|
|
|
|
|
continue; |
10600
|
|
|
|
|
|
} |
10601
|
|
|
|
|
|
} |
10602
|
1628
|
100
|
|
|
|
if (PL_multi_open == PL_multi_close) { |
10603
|
|
|
|
|
|
cont = FALSE; |
10604
|
|
|
|
|
|
} |
10605
|
|
|
|
|
|
else { |
10606
|
|
|
|
|
|
const char *t; |
10607
|
|
|
|
|
|
char *w; |
10608
|
1190
|
100
|
|
|
|
for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) { |
10609
|
|
|
|
|
|
/* At here, all closes are "was quoted" one, |
10610
|
|
|
|
|
|
so we don't check PL_multi_close. */ |
10611
|
1144
|
100
|
|
|
|
if (*t == '\\') { |
10612
|
22
|
50
|
|
|
|
if (!keep_quoted && *(t+1) == PL_multi_open) |
|
|
50
|
|
|
|
|
10613
|
0
|
|
|
|
|
t++; |
10614
|
|
|
|
|
|
else |
10615
|
22
|
|
|
|
|
*w++ = *t++; |
10616
|
|
|
|
|
|
} |
10617
|
1122
|
50
|
|
|
|
else if (*t == PL_multi_open) |
10618
|
0
|
|
|
|
|
brackets++; |
10619
|
|
|
|
|
|
|
10620
|
1144
|
|
|
|
|
*w = *t; |
10621
|
|
|
|
|
|
} |
10622
|
46
|
50
|
|
|
|
if (w < t) { |
10623
|
0
|
|
|
|
|
*w++ = term; |
10624
|
0
|
|
|
|
|
*w = '\0'; |
10625
|
0
|
|
|
|
|
SvCUR_set(sv, w - SvPVX_const(sv)); |
10626
|
|
|
|
|
|
} |
10627
|
46
|
|
|
|
|
last_off = w - SvPVX(sv); |
10628
|
869
|
50
|
|
|
|
if (--brackets <= 0) |
10629
|
|
|
|
|
|
cont = FALSE; |
10630
|
|
|
|
|
|
} |
10631
|
|
|
|
|
|
} |
10632
|
|
|
|
|
|
} |
10633
|
1628
|
50
|
|
|
|
if (!keep_delims) { |
10634
|
1628
|
|
|
|
|
SvCUR_set(sv, SvCUR(sv) - 1); |
10635
|
1628
|
|
|
|
|
*SvEND(sv) = '\0'; |
10636
|
|
|
|
|
|
} |
10637
|
|
|
|
|
|
break; |
10638
|
|
|
|
|
|
} |
10639
|
|
|
|
|
|
|
10640
|
|
|
|
|
|
/* extend sv if need be */ |
10641
|
59871188
|
50
|
|
|
|
SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1); |
|
|
100
|
|
|
|
|
10642
|
|
|
|
|
|
/* set 'to' to the next character in the sv's string */ |
10643
|
59871188
|
|
|
|
|
to = SvPVX(sv)+SvCUR(sv); |
10644
|
|
|
|
|
|
|
10645
|
|
|
|
|
|
/* if open delimiter is the close delimiter read unbridle */ |
10646
|
59871188
|
100
|
|
|
|
if (PL_multi_open == PL_multi_close) { |
10647
|
642311262
|
100
|
|
|
|
for (; s < PL_bufend; s++,to++) { |
10648
|
|
|
|
|
|
/* embedded newlines increment the current line number */ |
10649
|
667095485
|
100
|
|
|
|
if (*s == '\n' && !PL_rsfp && !PL_parser->filtered) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
10650
|
14870
|
100
|
|
|
|
COPLINE_INC_WITH_HERELINES; |
10651
|
|
|
|
|
|
/* handle quoted delimiters */ |
10652
|
667095485
|
100
|
|
|
|
if (*s == '\\' && s+1 < PL_bufend && term != '\\') { |
|
|
100
|
|
|
|
|
10653
|
44756080
|
50
|
|
|
|
if (!keep_quoted |
10654
|
44756080
|
100
|
|
|
|
&& (s[1] == term |
10655
|
44265292
|
50
|
|
|
|
|| (re_reparse && s[1] == '\\')) |
|
|
0
|
|
|
|
|
10656
|
|
|
|
|
|
) |
10657
|
490788
|
|
|
|
|
s++; |
10658
|
|
|
|
|
|
/* any other quotes are simply copied straight through */ |
10659
|
|
|
|
|
|
else |
10660
|
44265292
|
|
|
|
|
*to++ = *s++; |
10661
|
|
|
|
|
|
} |
10662
|
|
|
|
|
|
/* terminate when run out of buffer (the for() condition), or |
10663
|
|
|
|
|
|
have found the terminator */ |
10664
|
622339405
|
100
|
|
|
|
else if (*s == term) { |
10665
|
52324391
|
100
|
|
|
|
if (termlen == 1) |
10666
|
|
|
|
|
|
break; |
10667
|
6
|
50
|
|
|
|
if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen)) |
|
|
50
|
|
|
|
|
10668
|
|
|
|
|
|
break; |
10669
|
|
|
|
|
|
} |
10670
|
570015014
|
100
|
|
|
|
else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
10671
|
|
|
|
|
|
has_utf8 = TRUE; |
10672
|
614771094
|
|
|
|
|
*to = *s; |
10673
|
|
|
|
|
|
} |
10674
|
|
|
|
|
|
} |
10675
|
|
|
|
|
|
|
10676
|
|
|
|
|
|
/* if the terminator isn't the same as the start character (e.g., |
10677
|
|
|
|
|
|
matched brackets), we have to allow more in the quoting, and |
10678
|
|
|
|
|
|
be prepared for nested brackets. |
10679
|
|
|
|
|
|
*/ |
10680
|
|
|
|
|
|
else { |
10681
|
|
|
|
|
|
/* read until we run out of string, or we find the terminator */ |
10682
|
119777949
|
100
|
|
|
|
for (; s < PL_bufend; s++,to++) { |
10683
|
|
|
|
|
|
/* embedded newlines increment the line count */ |
10684
|
120161325
|
100
|
|
|
|
if (*s == '\n' && !PL_rsfp && !PL_parser->filtered) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
10685
|
5024
|
50
|
|
|
|
COPLINE_INC_WITH_HERELINES; |
10686
|
|
|
|
|
|
/* backslashes can escape the open or closing characters */ |
10687
|
120161325
|
100
|
|
|
|
if (*s == '\\' && s+1 < PL_bufend) { |
|
|
50
|
|
|
|
|
10688
|
1414760
|
50
|
|
|
|
if (!keep_quoted && |
|
|
100
|
|
|
|
|
10689
|
1413216
|
100
|
|
|
|
((s[1] == PL_multi_open) || (s[1] == PL_multi_close))) |
10690
|
|
|
|
|
|
{ |
10691
|
2064
|
|
|
|
|
s++; |
10692
|
|
|
|
|
|
|
10693
|
|
|
|
|
|
/* Here, 'deprecate_escaped_meta' is true iff the |
10694
|
|
|
|
|
|
* delimiters are paired metacharacters, and 's' points |
10695
|
|
|
|
|
|
* to an occurrence of one of them within the string, |
10696
|
|
|
|
|
|
* which was preceded by a backslash. If this is a |
10697
|
|
|
|
|
|
* context where the delimiter is also a metacharacter, |
10698
|
|
|
|
|
|
* the backslash is useless, and deprecated. () and [] |
10699
|
|
|
|
|
|
* are meta in any context. {} are meta only when |
10700
|
|
|
|
|
|
* appearing in a quantifier or in things like '\p{' |
10701
|
|
|
|
|
|
* (but '\\p{' isn't meta). They also aren't meta |
10702
|
|
|
|
|
|
* unless there is a matching closed, escaped char |
10703
|
|
|
|
|
|
* later on within the string. If 's' points to an |
10704
|
|
|
|
|
|
* open, set a flag; if to a close, test that flag, and |
10705
|
|
|
|
|
|
* raise a warning if it was set */ |
10706
|
|
|
|
|
|
|
10707
|
2064
|
100
|
|
|
|
if (deprecate_escaped_meta) { |
10708
|
1944
|
100
|
|
|
|
if (*s == PL_multi_open) { |
10709
|
1528
|
100
|
|
|
|
if (*s != '{') { |
10710
|
|
|
|
|
|
escaped_open = s; |
10711
|
|
|
|
|
|
} |
10712
|
|
|
|
|
|
/* Look for a closing '\}' */ |
10713
|
1524
|
100
|
|
|
|
else if (regcurly(s, TRUE)) { |
10714
|
|
|
|
|
|
escaped_open = s; |
10715
|
|
|
|
|
|
} |
10716
|
|
|
|
|
|
/* Look for e.g. '\x{' */ |
10717
|
1520
|
100
|
|
|
|
else if (s - start > 2 |
10718
|
196
|
100
|
|
|
|
&& _generic_isCC(*(s-2), |
10719
|
|
|
|
|
|
_CC_BACKSLASH_FOO_LBRACE_IS_META)) |
10720
|
|
|
|
|
|
{ /* Exclude '\\x', '\\\\x', etc. */ |
10721
|
8
|
|
|
|
|
char *lookbehind = s - 4; |
10722
|
|
|
|
|
|
bool is_meta = TRUE; |
10723
|
32
|
50
|
|
|
|
while (lookbehind >= start |
10724
|
28
|
100
|
|
|
|
&& *lookbehind == '\\') |
10725
|
|
|
|
|
|
{ |
10726
|
20
|
|
|
|
|
is_meta = ! is_meta; |
10727
|
20
|
|
|
|
|
lookbehind--; |
10728
|
|
|
|
|
|
} |
10729
|
8
|
100
|
|
|
|
if (is_meta) { |
10730
|
|
|
|
|
|
escaped_open = s; |
10731
|
|
|
|
|
|
} |
10732
|
|
|
|
|
|
} |
10733
|
|
|
|
|
|
} |
10734
|
416
|
100
|
|
|
|
else if (escaped_open) { |
10735
|
12
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), |
10736
|
12
|
|
|
|
|
"Useless use of '\\'; doesn't escape metacharacter '%c'", PL_multi_open); |
10737
|
|
|
|
|
|
escaped_open = NULL; |
10738
|
|
|
|
|
|
} |
10739
|
|
|
|
|
|
} |
10740
|
|
|
|
|
|
} |
10741
|
|
|
|
|
|
else |
10742
|
951188
|
|
|
|
|
*to++ = *s++; |
10743
|
|
|
|
|
|
} |
10744
|
|
|
|
|
|
/* allow nested opens and closes */ |
10745
|
119208073
|
100
|
|
|
|
else if (*s == PL_multi_close && --brackets <= 0) |
|
|
100
|
|
|
|
|
10746
|
|
|
|
|
|
break; |
10747
|
115463886
|
100
|
|
|
|
else if (*s == PL_multi_open) |
10748
|
228397
|
|
|
|
|
brackets++; |
10749
|
115235489
|
100
|
|
|
|
else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
10750
|
|
|
|
|
|
has_utf8 = TRUE; |
10751
|
116417138
|
|
|
|
|
*to = *s; |
10752
|
|
|
|
|
|
} |
10753
|
|
|
|
|
|
} |
10754
|
|
|
|
|
|
/* terminate the copied string and update the sv's end-of-string */ |
10755
|
59871188
|
|
|
|
|
*to = '\0'; |
10756
|
59871188
|
|
|
|
|
SvCUR_set(sv, to - SvPVX_const(sv)); |
10757
|
|
|
|
|
|
|
10758
|
|
|
|
|
|
/* |
10759
|
|
|
|
|
|
* this next chunk reads more into the buffer if we're not done yet |
10760
|
|
|
|
|
|
*/ |
10761
|
|
|
|
|
|
|
10762
|
59871188
|
100
|
|
|
|
if (s < PL_bufend) |
10763
|
|
|
|
|
|
break; /* handle case where we are done yet :-) */ |
10764
|
|
|
|
|
|
|
10765
|
|
|
|
|
|
#ifndef PERL_STRICT_CR |
10766
|
3802610
|
100
|
|
|
|
if (to - SvPVX_const(sv) >= 2) { |
10767
|
5237457
|
100
|
|
|
|
if ((to[-2] == '\r' && to[-1] == '\n') || |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
10768
|
1879073
|
50
|
|
|
|
(to[-2] == '\n' && to[-1] == '\r')) |
10769
|
|
|
|
|
|
{ |
10770
|
84
|
|
|
|
|
to[-2] = '\n'; |
10771
|
84
|
|
|
|
|
to--; |
10772
|
84
|
|
|
|
|
SvCUR_set(sv, to - SvPVX_const(sv)); |
10773
|
|
|
|
|
|
} |
10774
|
3533780
|
50
|
|
|
|
else if (to[-1] == '\r') |
10775
|
0
|
|
|
|
|
to[-1] = '\n'; |
10776
|
|
|
|
|
|
} |
10777
|
268746
|
100
|
|
|
|
else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r') |
|
|
50
|
|
|
|
|
10778
|
0
|
|
|
|
|
to[-1] = '\n'; |
10779
|
|
|
|
|
|
#endif |
10780
|
|
|
|
|
|
|
10781
|
|
|
|
|
|
read_more_line: |
10782
|
|
|
|
|
|
/* if we're out of file, or a read fails, bail and reset the current |
10783
|
|
|
|
|
|
line marker so we can report where the unterminated string began |
10784
|
|
|
|
|
|
*/ |
10785
|
|
|
|
|
|
#ifdef PERL_MAD |
10786
|
|
|
|
|
|
if (PL_madskills) { |
10787
|
|
|
|
|
|
char * const tstart = SvPVX(PL_linestr) + stuffstart; |
10788
|
|
|
|
|
|
if (PL_thisstuff) |
10789
|
|
|
|
|
|
sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart); |
10790
|
|
|
|
|
|
else |
10791
|
|
|
|
|
|
PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart); |
10792
|
|
|
|
|
|
} |
10793
|
|
|
|
|
|
#endif |
10794
|
3802610
|
50
|
|
|
|
COPLINE_INC_WITH_HERELINES; |
10795
|
3802610
|
|
|
|
|
PL_bufptr = PL_bufend; |
10796
|
3802610
|
100
|
|
|
|
if (!lex_next_chunk(0)) { |
10797
|
94
|
|
|
|
|
sv_free(sv); |
10798
|
94
|
|
|
|
|
CopLINE_set(PL_curcop, (line_t)PL_multi_start); |
10799
|
94
|
|
|
|
|
return NULL; |
10800
|
|
|
|
|
|
} |
10801
|
3802516
|
|
|
|
|
s = PL_bufptr; |
10802
|
|
|
|
|
|
#ifdef PERL_MAD |
10803
|
|
|
|
|
|
stuffstart = 0; |
10804
|
|
|
|
|
|
#endif |
10805
|
3802516
|
|
|
|
|
} |
10806
|
|
|
|
|
|
|
10807
|
|
|
|
|
|
/* at this point, we have successfully read the delimited string */ |
10808
|
|
|
|
|
|
|
10809
|
56070206
|
100
|
|
|
|
if (!PL_encoding || UTF || re_reparse) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
10810
|
|
|
|
|
|
#ifdef PERL_MAD |
10811
|
|
|
|
|
|
if (PL_madskills) { |
10812
|
|
|
|
|
|
char * const tstart = SvPVX(PL_linestr) + stuffstart; |
10813
|
|
|
|
|
|
const int len = s - tstart; |
10814
|
|
|
|
|
|
if (PL_thisstuff) |
10815
|
|
|
|
|
|
sv_catpvn(PL_thisstuff, tstart, len); |
10816
|
|
|
|
|
|
else |
10817
|
|
|
|
|
|
PL_thisstuff = newSVpvn(tstart, len); |
10818
|
|
|
|
|
|
if (!PL_thisclose && !keep_delims) |
10819
|
|
|
|
|
|
PL_thisclose = newSVpvn(s,termlen); |
10820
|
|
|
|
|
|
} |
10821
|
|
|
|
|
|
#endif |
10822
|
|
|
|
|
|
|
10823
|
56068578
|
100
|
|
|
|
if (keep_delims) |
10824
|
146
|
|
|
|
|
sv_catpvn(sv, s, termlen); |
10825
|
56068578
|
|
|
|
|
s += termlen; |
10826
|
|
|
|
|
|
} |
10827
|
|
|
|
|
|
#ifdef PERL_MAD |
10828
|
|
|
|
|
|
else { |
10829
|
|
|
|
|
|
if (PL_madskills) { |
10830
|
|
|
|
|
|
char * const tstart = SvPVX(PL_linestr) + stuffstart; |
10831
|
|
|
|
|
|
const int len = s - tstart - termlen; |
10832
|
|
|
|
|
|
if (PL_thisstuff) |
10833
|
|
|
|
|
|
sv_catpvn(PL_thisstuff, tstart, len); |
10834
|
|
|
|
|
|
else |
10835
|
|
|
|
|
|
PL_thisstuff = newSVpvn(tstart, len); |
10836
|
|
|
|
|
|
if (!PL_thisclose && !keep_delims) |
10837
|
|
|
|
|
|
PL_thisclose = newSVpvn(s - termlen,termlen); |
10838
|
|
|
|
|
|
} |
10839
|
|
|
|
|
|
} |
10840
|
|
|
|
|
|
#endif |
10841
|
56070206
|
100
|
|
|
|
if (has_utf8 || (PL_encoding && !re_reparse)) |
|
|
100
|
|
|
|
|
10842
|
61958
|
|
|
|
|
SvUTF8_on(sv); |
10843
|
|
|
|
|
|
|
10844
|
56070206
|
|
|
|
|
PL_multi_end = CopLINE(PL_curcop); |
10845
|
56070206
|
|
|
|
|
CopLINE_set(PL_curcop, PL_multi_start); |
10846
|
56070206
|
|
|
|
|
PL_parser->lex_shared->herelines = herelines; |
10847
|
|
|
|
|
|
|
10848
|
|
|
|
|
|
/* if we allocated too much space, give some back */ |
10849
|
56070206
|
100
|
|
|
|
if (SvCUR(sv) + 5 < SvLEN(sv)) { |
10850
|
56035358
|
|
|
|
|
SvLEN_set(sv, SvCUR(sv) + 1); |
10851
|
56035358
|
|
|
|
|
SvPV_renew(sv, SvLEN(sv)); |
10852
|
|
|
|
|
|
} |
10853
|
|
|
|
|
|
|
10854
|
|
|
|
|
|
/* decide whether this is the first or second quoted string we've read |
10855
|
|
|
|
|
|
for this op |
10856
|
|
|
|
|
|
*/ |
10857
|
|
|
|
|
|
|
10858
|
56070206
|
100
|
|
|
|
if (PL_lex_stuff) |
10859
|
1597273
|
|
|
|
|
PL_sublex_info.repl = sv; |
10860
|
|
|
|
|
|
else |
10861
|
55300049
|
|
|
|
|
PL_lex_stuff = sv; |
10862
|
|
|
|
|
|
return s; |
10863
|
|
|
|
|
|
} |
10864
|
|
|
|
|
|
|
10865
|
|
|
|
|
|
/* |
10866
|
|
|
|
|
|
scan_num |
10867
|
|
|
|
|
|
takes: pointer to position in buffer |
10868
|
|
|
|
|
|
returns: pointer to new position in buffer |
10869
|
|
|
|
|
|
side-effects: builds ops for the constant in pl_yylval.op |
10870
|
|
|
|
|
|
|
10871
|
|
|
|
|
|
Read a number in any of the formats that Perl accepts: |
10872
|
|
|
|
|
|
|
10873
|
|
|
|
|
|
\d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12. |
10874
|
|
|
|
|
|
\.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34 |
10875
|
|
|
|
|
|
0b[01](_?[01])* |
10876
|
|
|
|
|
|
0[0-7](_?[0-7])* |
10877
|
|
|
|
|
|
0x[0-9A-Fa-f](_?[0-9A-Fa-f])* |
10878
|
|
|
|
|
|
|
10879
|
|
|
|
|
|
Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the |
10880
|
|
|
|
|
|
thing it reads. |
10881
|
|
|
|
|
|
|
10882
|
|
|
|
|
|
If it reads a number without a decimal point or an exponent, it will |
10883
|
|
|
|
|
|
try converting the number to an integer and see if it can do so |
10884
|
|
|
|
|
|
without loss of precision. |
10885
|
|
|
|
|
|
*/ |
10886
|
|
|
|
|
|
|
10887
|
|
|
|
|
|
char * |
10888
|
24714567
|
|
|
|
|
Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) |
10889
|
|
|
|
|
|
{ |
10890
|
|
|
|
|
|
dVAR; |
10891
|
|
|
|
|
|
const char *s = start; /* current position in buffer */ |
10892
|
|
|
|
|
|
char *d; /* destination in temp buffer */ |
10893
|
|
|
|
|
|
char *e; /* end of temp buffer */ |
10894
|
|
|
|
|
|
NV nv; /* number read, as a double */ |
10895
|
|
|
|
|
|
SV *sv = NULL; /* place to put the converted number */ |
10896
|
|
|
|
|
|
bool floatit; /* boolean: int or float? */ |
10897
|
|
|
|
|
|
const char *lastub = NULL; /* position of last underbar */ |
10898
|
|
|
|
|
|
static const char* const number_too_long = "Number too long"; |
10899
|
|
|
|
|
|
|
10900
|
|
|
|
|
|
PERL_ARGS_ASSERT_SCAN_NUM; |
10901
|
|
|
|
|
|
|
10902
|
|
|
|
|
|
/* We use the first character to decide what type of number this is */ |
10903
|
|
|
|
|
|
|
10904
|
24714567
|
|
|
|
|
switch (*s) { |
10905
|
|
|
|
|
|
default: |
10906
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s); |
10907
|
|
|
|
|
|
|
10908
|
|
|
|
|
|
/* if it starts with a 0, it could be an octal number, a decimal in |
10909
|
|
|
|
|
|
0.13 disguise, or a hexadecimal number, or a binary number. */ |
10910
|
|
|
|
|
|
case '0': |
10911
|
|
|
|
|
|
{ |
10912
|
|
|
|
|
|
/* variables: |
10913
|
|
|
|
|
|
u holds the "number so far" |
10914
|
|
|
|
|
|
shift the power of 2 of the base |
10915
|
|
|
|
|
|
(hex == 4, octal == 3, binary == 1) |
10916
|
|
|
|
|
|
overflowed was the number more than we can hold? |
10917
|
|
|
|
|
|
|
10918
|
|
|
|
|
|
Shift is used when we add a digit. It also serves as an "are |
10919
|
|
|
|
|
|
we in octal/hex/binary?" indicator to disallow hex characters |
10920
|
|
|
|
|
|
when in octal mode. |
10921
|
|
|
|
|
|
*/ |
10922
|
|
|
|
|
|
NV n = 0.0; |
10923
|
|
|
|
|
|
UV u = 0; |
10924
|
|
|
|
|
|
I32 shift; |
10925
|
|
|
|
|
|
bool overflowed = FALSE; |
10926
|
|
|
|
|
|
bool just_zero = TRUE; /* just plain 0 or binary number? */ |
10927
|
|
|
|
|
|
static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 }; |
10928
|
|
|
|
|
|
static const char* const bases[5] = |
10929
|
|
|
|
|
|
{ "", "binary", "", "octal", "hexadecimal" }; |
10930
|
|
|
|
|
|
static const char* const Bases[5] = |
10931
|
|
|
|
|
|
{ "", "Binary", "", "Octal", "Hexadecimal" }; |
10932
|
|
|
|
|
|
static const char* const maxima[5] = |
10933
|
|
|
|
|
|
{ "", |
10934
|
|
|
|
|
|
"0b11111111111111111111111111111111", |
10935
|
|
|
|
|
|
"", |
10936
|
|
|
|
|
|
"037777777777", |
10937
|
|
|
|
|
|
"0xffffffff" }; |
10938
|
|
|
|
|
|
const char *base, *Base, *max; |
10939
|
|
|
|
|
|
|
10940
|
|
|
|
|
|
/* check for hex */ |
10941
|
7760654
|
100
|
|
|
|
if (s[1] == 'x' || s[1] == 'X') { |
10942
|
|
|
|
|
|
shift = 4; |
10943
|
655383
|
|
|
|
|
s += 2; |
10944
|
|
|
|
|
|
just_zero = FALSE; |
10945
|
7105271
|
100
|
|
|
|
} else if (s[1] == 'b' || s[1] == 'B') { |
10946
|
|
|
|
|
|
shift = 1; |
10947
|
74
|
|
|
|
|
s += 2; |
10948
|
|
|
|
|
|
just_zero = FALSE; |
10949
|
|
|
|
|
|
} |
10950
|
|
|
|
|
|
/* check for a decimal in disguise */ |
10951
|
7105197
|
100
|
|
|
|
else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E') |
|
|
50
|
|
|
|
|
10952
|
|
|
|
|
|
goto decimal; |
10953
|
|
|
|
|
|
/* so it must be octal */ |
10954
|
|
|
|
|
|
else { |
10955
|
|
|
|
|
|
shift = 3; |
10956
|
7034995
|
|
|
|
|
s++; |
10957
|
|
|
|
|
|
} |
10958
|
|
|
|
|
|
|
10959
|
7690452
|
100
|
|
|
|
if (*s == '_') { |
10960
|
12
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), |
10961
|
|
|
|
|
|
"Misplaced _ in number"); |
10962
|
12
|
|
|
|
|
lastub = s++; |
10963
|
|
|
|
|
|
} |
10964
|
|
|
|
|
|
|
10965
|
7690452
|
|
|
|
|
base = bases[shift]; |
10966
|
7690452
|
|
|
|
|
Base = Bases[shift]; |
10967
|
9609127
|
|
|
|
|
max = maxima[shift]; |
10968
|
|
|
|
|
|
|
10969
|
|
|
|
|
|
/* read the rest of the number */ |
10970
|
|
|
|
|
|
for (;;) { |
10971
|
|
|
|
|
|
/* x is used in the overflow test, |
10972
|
|
|
|
|
|
b is the digit we're adding on. */ |
10973
|
|
|
|
|
|
UV x, b; |
10974
|
|
|
|
|
|
|
10975
|
11441764
|
|
|
|
|
switch (*s) { |
10976
|
|
|
|
|
|
|
10977
|
|
|
|
|
|
/* if we don't mention it, we're done */ |
10978
|
|
|
|
|
|
default: |
10979
|
|
|
|
|
|
goto out; |
10980
|
|
|
|
|
|
|
10981
|
|
|
|
|
|
/* _ are ignored -- but warned about if consecutive */ |
10982
|
|
|
|
|
|
case '_': |
10983
|
68
|
100
|
|
|
|
if (lastub && s == lastub + 1) |
|
|
50
|
|
|
|
|
10984
|
0
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), |
10985
|
|
|
|
|
|
"Misplaced _ in number"); |
10986
|
68
|
|
|
|
|
lastub = s++; |
10987
|
68
|
|
|
|
|
break; |
10988
|
|
|
|
|
|
|
10989
|
|
|
|
|
|
/* 8 and 9 are not octal */ |
10990
|
|
|
|
|
|
case '8': case '9': |
10991
|
130346
|
50
|
|
|
|
if (shift == 3) |
10992
|
0
|
|
|
|
|
yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s)); |
10993
|
|
|
|
|
|
/* FALL THROUGH */ |
10994
|
|
|
|
|
|
|
10995
|
|
|
|
|
|
/* octal digits */ |
10996
|
|
|
|
|
|
case '2': case '3': case '4': |
10997
|
|
|
|
|
|
case '5': case '6': case '7': |
10998
|
825032
|
100
|
|
|
|
if (shift == 1) |
10999
|
2
|
|
|
|
|
yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s)); |
11000
|
|
|
|
|
|
/* FALL THROUGH */ |
11001
|
|
|
|
|
|
|
11002
|
|
|
|
|
|
case '0': case '1': |
11003
|
3439904
|
|
|
|
|
b = *s++ & 15; /* ASCII digit -> value of digit */ |
11004
|
3439904
|
|
|
|
|
goto digit; |
11005
|
|
|
|
|
|
|
11006
|
|
|
|
|
|
/* hex digits */ |
11007
|
|
|
|
|
|
case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': |
11008
|
|
|
|
|
|
case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': |
11009
|
|
|
|
|
|
/* make sure they said 0x */ |
11010
|
311340
|
50
|
|
|
|
if (shift != 4) |
11011
|
|
|
|
|
|
goto out; |
11012
|
311340
|
|
|
|
|
b = (*s++ & 7) + 9; |
11013
|
|
|
|
|
|
|
11014
|
|
|
|
|
|
/* Prepare to put the digit we have onto the end |
11015
|
|
|
|
|
|
of the number so far. We check for overflows. |
11016
|
|
|
|
|
|
*/ |
11017
|
|
|
|
|
|
|
11018
|
|
|
|
|
|
digit: |
11019
|
|
|
|
|
|
just_zero = FALSE; |
11020
|
3751244
|
50
|
|
|
|
if (!overflowed) { |
11021
|
3751244
|
|
|
|
|
x = u << shift; /* make room for the digit */ |
11022
|
|
|
|
|
|
|
11023
|
3751244
|
100
|
|
|
|
if ((x >> shift) != u |
11024
|
38
|
100
|
|
|
|
&& !(PL_hints & HINT_NEW_BINARY)) { |
11025
|
|
|
|
|
|
overflowed = TRUE; |
11026
|
12
|
|
|
|
|
n = (NV) u; |
11027
|
12
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), |
11028
|
|
|
|
|
|
"Integer overflow in %s number", |
11029
|
|
|
|
|
|
base); |
11030
|
|
|
|
|
|
} else |
11031
|
3751232
|
|
|
|
|
u = x | b; /* add the digit to the end */ |
11032
|
|
|
|
|
|
} |
11033
|
3751244
|
100
|
|
|
|
if (overflowed) { |
11034
|
12
|
|
|
|
|
n *= nvshift[shift]; |
11035
|
|
|
|
|
|
/* If an NV has not enough bits in its |
11036
|
|
|
|
|
|
* mantissa to represent an UV this summing of |
11037
|
|
|
|
|
|
* small low-order numbers is a waste of time |
11038
|
|
|
|
|
|
* (because the NV cannot preserve the |
11039
|
|
|
|
|
|
* low-order bits anyway): we could just |
11040
|
|
|
|
|
|
* remember when did we overflow and in the |
11041
|
|
|
|
|
|
* end just multiply n by the right |
11042
|
|
|
|
|
|
* amount. */ |
11043
|
12
|
|
|
|
|
n += (NV) b; |
11044
|
|
|
|
|
|
} |
11045
|
|
|
|
|
|
break; |
11046
|
|
|
|
|
|
} |
11047
|
|
|
|
|
|
} |
11048
|
|
|
|
|
|
|
11049
|
|
|
|
|
|
/* if we get here, we had success: make a scalar value from |
11050
|
|
|
|
|
|
the number. |
11051
|
|
|
|
|
|
*/ |
11052
|
|
|
|
|
|
out: |
11053
|
|
|
|
|
|
|
11054
|
|
|
|
|
|
/* final misplaced underbar check */ |
11055
|
7690450
|
100
|
|
|
|
if (s[-1] == '_') { |
11056
|
4
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); |
11057
|
|
|
|
|
|
} |
11058
|
|
|
|
|
|
|
11059
|
7690450
|
100
|
|
|
|
if (overflowed) { |
11060
|
12
|
50
|
|
|
|
if (n > 4294967295.0) |
11061
|
12
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), |
11062
|
|
|
|
|
|
"%s number > %s non-portable", |
11063
|
|
|
|
|
|
Base, max); |
11064
|
12
|
|
|
|
|
sv = newSVnv(n); |
11065
|
|
|
|
|
|
} |
11066
|
|
|
|
|
|
else { |
11067
|
|
|
|
|
|
#if UVSIZE > 4 |
11068
|
7690438
|
100
|
|
|
|
if (u > 0xffffffff) |
11069
|
112
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), |
11070
|
|
|
|
|
|
"%s number > %s non-portable", |
11071
|
|
|
|
|
|
Base, max); |
11072
|
|
|
|
|
|
#endif |
11073
|
7690438
|
|
|
|
|
sv = newSVuv(u); |
11074
|
|
|
|
|
|
} |
11075
|
7690450
|
100
|
|
|
|
if (just_zero && (PL_hints & HINT_NEW_INTEGER)) |
|
|
100
|
|
|
|
|
11076
|
6
|
|
|
|
|
sv = new_constant(start, s - start, "integer", |
11077
|
|
|
|
|
|
sv, NULL, NULL, 0); |
11078
|
7690444
|
100
|
|
|
|
else if (PL_hints & HINT_NEW_BINARY) |
11079
|
50
|
|
|
|
|
sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0); |
11080
|
|
|
|
|
|
} |
11081
|
|
|
|
|
|
break; |
11082
|
|
|
|
|
|
|
11083
|
|
|
|
|
|
/* |
11084
|
|
|
|
|
|
handle decimal numbers. |
11085
|
|
|
|
|
|
we're also sent here when we read a 0 as the first digit |
11086
|
|
|
|
|
|
*/ |
11087
|
|
|
|
|
|
case '1': case '2': case '3': case '4': case '5': |
11088
|
|
|
|
|
|
case '6': case '7': case '8': case '9': case '.': |
11089
|
|
|
|
|
|
decimal: |
11090
|
17017513
|
|
|
|
|
d = PL_tokenbuf; |
11091
|
17017513
|
|
|
|
|
e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */ |
11092
|
|
|
|
|
|
floatit = FALSE; |
11093
|
|
|
|
|
|
|
11094
|
|
|
|
|
|
/* read next group of digits and _ and copy into d */ |
11095
|
48906545
|
100
|
|
|
|
while (isDIGIT(*s) || *s == '_') { |
|
|
100
|
|
|
|
|
11096
|
|
|
|
|
|
/* skip underscores, checking for misplaced ones |
11097
|
|
|
|
|
|
if -w is on |
11098
|
|
|
|
|
|
*/ |
11099
|
23729992
|
100
|
|
|
|
if (*s == '_') { |
11100
|
3562
|
100
|
|
|
|
if (lastub && s == lastub + 1) |
|
|
100
|
|
|
|
|
11101
|
4
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), |
11102
|
|
|
|
|
|
"Misplaced _ in number"); |
11103
|
3562
|
|
|
|
|
lastub = s++; |
11104
|
|
|
|
|
|
} |
11105
|
|
|
|
|
|
else { |
11106
|
|
|
|
|
|
/* check for end of fixed-length buffer */ |
11107
|
23726430
|
50
|
|
|
|
if (d >= e) |
11108
|
0
|
|
|
|
|
Perl_croak(aTHX_ "%s", number_too_long); |
11109
|
|
|
|
|
|
/* if we're ok, copy the character */ |
11110
|
23728211
|
|
|
|
|
*d++ = *s++; |
11111
|
|
|
|
|
|
} |
11112
|
|
|
|
|
|
} |
11113
|
|
|
|
|
|
|
11114
|
|
|
|
|
|
/* final misplaced underbar check */ |
11115
|
17017513
|
100
|
|
|
|
if (lastub && s == lastub + 1) { |
|
|
100
|
|
|
|
|
11116
|
20
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); |
11117
|
|
|
|
|
|
} |
11118
|
|
|
|
|
|
|
11119
|
|
|
|
|
|
/* read a decimal portion if there is one. avoid |
11120
|
|
|
|
|
|
3..5 being interpreted as the number 3. followed |
11121
|
|
|
|
|
|
by .5 |
11122
|
|
|
|
|
|
*/ |
11123
|
17017513
|
100
|
|
|
|
if (*s == '.' && s[1] != '.') { |
|
|
100
|
|
|
|
|
11124
|
|
|
|
|
|
floatit = TRUE; |
11125
|
819011
|
|
|
|
|
*d++ = *s++; |
11126
|
|
|
|
|
|
|
11127
|
819011
|
100
|
|
|
|
if (*s == '_') { |
11128
|
420673
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), |
11129
|
|
|
|
|
|
"Misplaced _ in number"); |
11130
|
|
|
|
|
|
lastub = s; |
11131
|
|
|
|
|
|
} |
11132
|
|
|
|
|
|
|
11133
|
|
|
|
|
|
/* copy, ignoring underbars, until we run out of digits. |
11134
|
|
|
|
|
|
*/ |
11135
|
3358062
|
100
|
|
|
|
for (; isDIGIT(*s) || *s == '_'; s++) { |
|
|
100
|
|
|
|
|
11136
|
|
|
|
|
|
/* fixed length buffer check */ |
11137
|
2937397
|
50
|
|
|
|
if (d >= e) |
11138
|
0
|
|
|
|
|
Perl_croak(aTHX_ "%s", number_too_long); |
11139
|
2937397
|
100
|
|
|
|
if (*s == '_') { |
11140
|
20798
|
100
|
|
|
|
if (lastub && s == lastub + 1) |
|
|
100
|
|
|
|
|
11141
|
10581
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), |
11142
|
|
|
|
|
|
"Misplaced _ in number"); |
11143
|
|
|
|
|
|
lastub = s; |
11144
|
|
|
|
|
|
} |
11145
|
|
|
|
|
|
else |
11146
|
2916599
|
|
|
|
|
*d++ = *s; |
11147
|
|
|
|
|
|
} |
11148
|
|
|
|
|
|
/* fractional part ending in underbar? */ |
11149
|
819011
|
100
|
|
|
|
if (s[-1] == '_') { |
11150
|
20
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), |
11151
|
|
|
|
|
|
"Misplaced _ in number"); |
11152
|
|
|
|
|
|
} |
11153
|
819011
|
100
|
|
|
|
if (*s == '.' && isDIGIT(s[1])) { |
|
|
50
|
|
|
|
|
11154
|
|
|
|
|
|
/* oops, it's really a v-string, but without the "v" */ |
11155
|
|
|
|
|
|
s = start; |
11156
|
|
|
|
|
|
goto vstring; |
11157
|
|
|
|
|
|
} |
11158
|
|
|
|
|
|
} |
11159
|
|
|
|
|
|
|
11160
|
|
|
|
|
|
/* read exponent part, if present */ |
11161
|
16996019
|
100
|
|
|
|
if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) { |
|
|
50
|
|
|
|
|
11162
|
|
|
|
|
|
floatit = TRUE; |
11163
|
11548
|
|
|
|
|
s++; |
11164
|
|
|
|
|
|
|
11165
|
|
|
|
|
|
/* regardless of whether user said 3E5 or 3e5, use lower 'e' */ |
11166
|
11548
|
|
|
|
|
*d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */ |
11167
|
|
|
|
|
|
|
11168
|
|
|
|
|
|
/* stray preinitial _ */ |
11169
|
11548
|
100
|
|
|
|
if (*s == '_') { |
11170
|
12
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), |
11171
|
|
|
|
|
|
"Misplaced _ in number"); |
11172
|
12
|
|
|
|
|
lastub = s++; |
11173
|
|
|
|
|
|
} |
11174
|
|
|
|
|
|
|
11175
|
|
|
|
|
|
/* allow positive or negative exponent */ |
11176
|
11548
|
100
|
|
|
|
if (*s == '+' || *s == '-') |
11177
|
1392
|
|
|
|
|
*d++ = *s++; |
11178
|
|
|
|
|
|
|
11179
|
|
|
|
|
|
/* stray initial _ */ |
11180
|
11548
|
100
|
|
|
|
if (*s == '_') { |
11181
|
8
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), |
11182
|
|
|
|
|
|
"Misplaced _ in number"); |
11183
|
5778
|
|
|
|
|
lastub = s++; |
11184
|
|
|
|
|
|
} |
11185
|
|
|
|
|
|
|
11186
|
|
|
|
|
|
/* read digits of exponent */ |
11187
|
24706
|
100
|
|
|
|
while (isDIGIT(*s) || *s == '_') { |
|
|
100
|
|
|
|
|
11188
|
13158
|
100
|
|
|
|
if (isDIGIT(*s)) { |
11189
|
13126
|
50
|
|
|
|
if (d >= e) |
11190
|
0
|
|
|
|
|
Perl_croak(aTHX_ "%s", number_too_long); |
11191
|
13126
|
|
|
|
|
*d++ = *s++; |
11192
|
|
|
|
|
|
} |
11193
|
|
|
|
|
|
else { |
11194
|
46
|
100
|
|
|
|
if (((lastub && s == lastub + 1) || |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
11195
|
30
|
100
|
|
|
|
(!isDIGIT(s[1]) && s[1] != '_'))) |
11196
|
16
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), |
11197
|
|
|
|
|
|
"Misplaced _ in number"); |
11198
|
6595
|
|
|
|
|
lastub = s++; |
11199
|
|
|
|
|
|
} |
11200
|
|
|
|
|
|
} |
11201
|
|
|
|
|
|
} |
11202
|
|
|
|
|
|
|
11203
|
|
|
|
|
|
|
11204
|
|
|
|
|
|
/* |
11205
|
|
|
|
|
|
We try to do an integer conversion first if no characters |
11206
|
|
|
|
|
|
indicating "float" have been found. |
11207
|
|
|
|
|
|
*/ |
11208
|
|
|
|
|
|
|
11209
|
16996019
|
100
|
|
|
|
if (!floatit) { |
11210
|
|
|
|
|
|
UV uv; |
11211
|
16187102
|
|
|
|
|
const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv); |
11212
|
|
|
|
|
|
|
11213
|
16187102
|
100
|
|
|
|
if (flags == IS_NUMBER_IN_UV) { |
11214
|
16181754
|
100
|
|
|
|
if (uv <= IV_MAX) |
11215
|
16176264
|
|
|
|
|
sv = newSViv(uv); /* Prefer IVs over UVs. */ |
11216
|
|
|
|
|
|
else |
11217
|
5490
|
|
|
|
|
sv = newSVuv(uv); |
11218
|
5348
|
50
|
|
|
|
} else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) { |
11219
|
0
|
0
|
|
|
|
if (uv <= (UV) IV_MIN) |
11220
|
0
|
|
|
|
|
sv = newSViv(-(IV)uv); |
11221
|
|
|
|
|
|
else |
11222
|
|
|
|
|
|
floatit = TRUE; |
11223
|
|
|
|
|
|
} else |
11224
|
|
|
|
|
|
floatit = TRUE; |
11225
|
|
|
|
|
|
} |
11226
|
16996019
|
100
|
|
|
|
if (floatit) { |
11227
|
|
|
|
|
|
/* terminate the string */ |
11228
|
814265
|
|
|
|
|
*d = '\0'; |
11229
|
814265
|
|
|
|
|
nv = Atof(PL_tokenbuf); |
11230
|
814265
|
|
|
|
|
sv = newSVnv(nv); |
11231
|
|
|
|
|
|
} |
11232
|
|
|
|
|
|
|
11233
|
25144672
|
100
|
|
|
|
if ( floatit |
|
|
100
|
|
|
|
|
11234
|
16996019
|
|
|
|
|
? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) { |
11235
|
496
|
100
|
|
|
|
const char *const key = floatit ? "float" : "integer"; |
11236
|
496
|
100
|
|
|
|
const STRLEN keylen = floatit ? 5 : 7; |
11237
|
496
|
|
|
|
|
sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf, |
11238
|
|
|
|
|
|
key, keylen, sv, NULL, NULL, 0); |
11239
|
|
|
|
|
|
} |
11240
|
|
|
|
|
|
break; |
11241
|
|
|
|
|
|
|
11242
|
|
|
|
|
|
/* if it starts with a v, it could be a v-string */ |
11243
|
|
|
|
|
|
case 'v': |
11244
|
|
|
|
|
|
vstring: |
11245
|
28096
|
|
|
|
|
sv = newSV(5); /* preallocate storage space */ |
11246
|
28096
|
|
|
|
|
ENTER_with_name("scan_vstring"); |
11247
|
28096
|
|
|
|
|
SAVEFREESV(sv); |
11248
|
28096
|
|
|
|
|
s = scan_vstring(s, PL_bufend, sv); |
11249
|
28092
|
|
|
|
|
SvREFCNT_inc_simple_void_NN(sv); |
11250
|
28092
|
|
|
|
|
LEAVE_with_name("scan_vstring"); |
11251
|
28092
|
|
|
|
|
break; |
11252
|
|
|
|
|
|
} |
11253
|
|
|
|
|
|
|
11254
|
|
|
|
|
|
/* make the op for the constant and return */ |
11255
|
|
|
|
|
|
|
11256
|
24714549
|
50
|
|
|
|
if (sv) |
11257
|
24714549
|
|
|
|
|
lvalp->opval = newSVOP(OP_CONST, 0, sv); |
11258
|
|
|
|
|
|
else |
11259
|
0
|
|
|
|
|
lvalp->opval = NULL; |
11260
|
|
|
|
|
|
|
11261
|
24714549
|
|
|
|
|
return (char *)s; |
11262
|
|
|
|
|
|
} |
11263
|
|
|
|
|
|
|
11264
|
|
|
|
|
|
STATIC char * |
11265
|
666
|
|
|
|
|
S_scan_formline(pTHX_ char *s) |
11266
|
|
|
|
|
|
{ |
11267
|
|
|
|
|
|
dVAR; |
11268
|
|
|
|
|
|
char *eol; |
11269
|
|
|
|
|
|
char *t; |
11270
|
666
|
|
|
|
|
SV * const stuff = newSVpvs(""); |
11271
|
|
|
|
|
|
bool needargs = FALSE; |
11272
|
|
|
|
|
|
bool eofmt = FALSE; |
11273
|
|
|
|
|
|
#ifdef PERL_MAD |
11274
|
|
|
|
|
|
char *tokenstart = s; |
11275
|
|
|
|
|
|
SV* savewhite = NULL; |
11276
|
|
|
|
|
|
|
11277
|
|
|
|
|
|
if (PL_madskills) { |
11278
|
|
|
|
|
|
savewhite = PL_thiswhite; |
11279
|
|
|
|
|
|
PL_thiswhite = 0; |
11280
|
|
|
|
|
|
} |
11281
|
|
|
|
|
|
#endif |
11282
|
|
|
|
|
|
|
11283
|
|
|
|
|
|
PERL_ARGS_ASSERT_SCAN_FORMLINE; |
11284
|
|
|
|
|
|
|
11285
|
1419
|
100
|
|
|
|
while (!needargs) { |
11286
|
770
|
100
|
|
|
|
if (*s == '.') { |
11287
|
330
|
|
|
|
|
t = s+1; |
11288
|
|
|
|
|
|
#ifdef PERL_STRICT_CR |
11289
|
|
|
|
|
|
while (SPACE_OR_TAB(*t)) |
11290
|
|
|
|
|
|
t++; |
11291
|
|
|
|
|
|
#else |
11292
|
495
|
50
|
|
|
|
while (SPACE_OR_TAB(*t) || *t == '\r') |
|
|
50
|
|
|
|
|
11293
|
0
|
|
|
|
|
t++; |
11294
|
|
|
|
|
|
#endif |
11295
|
330
|
100
|
|
|
|
if (*t == '\n' || t == PL_bufend) { |
|
|
50
|
|
|
|
|
11296
|
|
|
|
|
|
eofmt = TRUE; |
11297
|
|
|
|
|
|
break; |
11298
|
|
|
|
|
|
} |
11299
|
|
|
|
|
|
} |
11300
|
440
|
|
|
|
|
eol = (char *) memchr(s,'\n',PL_bufend-s); |
11301
|
440
|
100
|
|
|
|
if (!eol++) |
11302
|
24
|
|
|
|
|
eol = PL_bufend; |
11303
|
440
|
50
|
|
|
|
if (*s != '#') { |
11304
|
5644
|
100
|
|
|
|
for (t = s; t < eol; t++) { |
11305
|
5428
|
100
|
|
|
|
if (*t == '~' && t[1] == '~' && SvCUR(stuff)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
11306
|
|
|
|
|
|
needargs = FALSE; |
11307
|
|
|
|
|
|
goto enough; /* ~~ must be first line in formline */ |
11308
|
|
|
|
|
|
} |
11309
|
5424
|
100
|
|
|
|
if (*t == '@' || *t == '^') |
11310
|
|
|
|
|
|
needargs = TRUE; |
11311
|
|
|
|
|
|
} |
11312
|
436
|
100
|
|
|
|
if (eol > s) { |
11313
|
420
|
|
|
|
|
sv_catpvn(stuff, s, eol-s); |
11314
|
|
|
|
|
|
#ifndef PERL_STRICT_CR |
11315
|
420
|
100
|
|
|
|
if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') { |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
11316
|
0
|
|
|
|
|
char *end = SvPVX(stuff) + SvCUR(stuff); |
11317
|
0
|
|
|
|
|
end[-2] = '\n'; |
11318
|
0
|
|
|
|
|
end[-1] = '\0'; |
11319
|
0
|
|
|
|
|
SvCUR_set(stuff, SvCUR(stuff) - 1); |
11320
|
|
|
|
|
|
} |
11321
|
|
|
|
|
|
#endif |
11322
|
|
|
|
|
|
} |
11323
|
|
|
|
|
|
else |
11324
|
|
|
|
|
|
break; |
11325
|
|
|
|
|
|
} |
11326
|
|
|
|
|
|
s = (char*)eol; |
11327
|
420
|
100
|
|
|
|
if ((PL_rsfp || PL_parser->filtered) |
|
|
50
|
|
|
|
|
11328
|
300
|
100
|
|
|
|
&& PL_parser->form_lex_state == LEX_NORMAL) { |
11329
|
|
|
|
|
|
bool got_some; |
11330
|
|
|
|
|
|
#ifdef PERL_MAD |
11331
|
|
|
|
|
|
if (PL_madskills) { |
11332
|
|
|
|
|
|
if (PL_thistoken) |
11333
|
|
|
|
|
|
sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart); |
11334
|
|
|
|
|
|
else |
11335
|
|
|
|
|
|
PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart); |
11336
|
|
|
|
|
|
} |
11337
|
|
|
|
|
|
#endif |
11338
|
298
|
|
|
|
|
PL_bufptr = PL_bufend; |
11339
|
298
|
50
|
|
|
|
COPLINE_INC_WITH_HERELINES; |
11340
|
298
|
|
|
|
|
got_some = lex_next_chunk(0); |
11341
|
298
|
|
|
|
|
CopLINE_dec(PL_curcop); |
11342
|
298
|
|
|
|
|
s = PL_bufptr; |
11343
|
|
|
|
|
|
#ifdef PERL_MAD |
11344
|
|
|
|
|
|
tokenstart = PL_bufptr; |
11345
|
|
|
|
|
|
#endif |
11346
|
298
|
50
|
|
|
|
if (!got_some) |
11347
|
|
|
|
|
|
break; |
11348
|
|
|
|
|
|
} |
11349
|
420
|
|
|
|
|
incline(s); |
11350
|
|
|
|
|
|
} |
11351
|
|
|
|
|
|
enough: |
11352
|
666
|
100
|
|
|
|
if (!SvCUR(stuff) || needargs) |
|
|
100
|
|
|
|
|
11353
|
606
|
|
|
|
|
PL_lex_state = PL_parser->form_lex_state; |
11354
|
666
|
100
|
|
|
|
if (SvCUR(stuff)) { |
11355
|
376
|
|
|
|
|
PL_expect = XSTATE; |
11356
|
376
|
100
|
|
|
|
if (needargs) { |
11357
|
|
|
|
|
|
start_force(PL_curforce); |
11358
|
316
|
|
|
|
|
NEXTVAL_NEXTTOKE.ival = 0; |
11359
|
316
|
|
|
|
|
force_next(FORMLBRACK); |
11360
|
|
|
|
|
|
} |
11361
|
376
|
50
|
|
|
|
if (!IN_BYTES) { |
11362
|
376
|
50
|
|
|
|
if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff))) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
11363
|
14
|
|
|
|
|
SvUTF8_on(stuff); |
11364
|
362
|
50
|
|
|
|
else if (PL_encoding) |
11365
|
0
|
|
|
|
|
sv_recode_to_utf8(stuff, PL_encoding); |
11366
|
|
|
|
|
|
} |
11367
|
|
|
|
|
|
start_force(PL_curforce); |
11368
|
376
|
|
|
|
|
NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff); |
11369
|
376
|
|
|
|
|
force_next(THING); |
11370
|
|
|
|
|
|
} |
11371
|
|
|
|
|
|
else { |
11372
|
290
|
|
|
|
|
SvREFCNT_dec(stuff); |
11373
|
290
|
100
|
|
|
|
if (eofmt) |
11374
|
282
|
|
|
|
|
PL_lex_formbrack = 0; |
11375
|
|
|
|
|
|
} |
11376
|
|
|
|
|
|
#ifdef PERL_MAD |
11377
|
|
|
|
|
|
if (PL_madskills) { |
11378
|
|
|
|
|
|
if (PL_thistoken) |
11379
|
|
|
|
|
|
sv_catpvn(PL_thistoken, tokenstart, s - tokenstart); |
11380
|
|
|
|
|
|
else |
11381
|
|
|
|
|
|
PL_thistoken = newSVpvn(tokenstart, s - tokenstart); |
11382
|
|
|
|
|
|
PL_thiswhite = savewhite; |
11383
|
|
|
|
|
|
} |
11384
|
|
|
|
|
|
#endif |
11385
|
666
|
|
|
|
|
return s; |
11386
|
|
|
|
|
|
} |
11387
|
|
|
|
|
|
|
11388
|
|
|
|
|
|
I32 |
11389
|
14237458
|
|
|
|
|
Perl_start_subparse(pTHX_ I32 is_format, U32 flags) |
11390
|
|
|
|
|
|
{ |
11391
|
|
|
|
|
|
dVAR; |
11392
|
14237458
|
|
|
|
|
const I32 oldsavestack_ix = PL_savestack_ix; |
11393
|
14237458
|
|
|
|
|
CV* const outsidecv = PL_compcv; |
11394
|
|
|
|
|
|
|
11395
|
14237458
|
|
|
|
|
SAVEI32(PL_subline); |
11396
|
14237458
|
|
|
|
|
save_item(PL_subname); |
11397
|
14237458
|
|
|
|
|
SAVESPTR(PL_compcv); |
11398
|
|
|
|
|
|
|
11399
|
14237458
|
100
|
|
|
|
PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV)); |
11400
|
14237458
|
|
|
|
|
CvFLAGS(PL_compcv) |= flags; |
11401
|
|
|
|
|
|
|
11402
|
14237458
|
|
|
|
|
PL_subline = CopLINE(PL_curcop); |
11403
|
14237458
|
|
|
|
|
CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB); |
11404
|
28474916
|
|
|
|
|
CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv)); |
11405
|
14237458
|
|
|
|
|
CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax; |
11406
|
14237458
|
100
|
|
|
|
if (outsidecv && CvPADLIST(outsidecv)) |
|
|
50
|
|
|
|
|
11407
|
21158363
|
|
|
|
|
CvPADLIST(PL_compcv)->xpadl_outid = |
11408
|
14231076
|
|
|
|
|
PadlistNAMES(CvPADLIST(outsidecv)); |
11409
|
|
|
|
|
|
|
11410
|
14237458
|
|
|
|
|
return oldsavestack_ix; |
11411
|
|
|
|
|
|
} |
11412
|
|
|
|
|
|
|
11413
|
|
|
|
|
|
#ifdef __SC__ |
11414
|
|
|
|
|
|
#pragma segment Perl_yylex |
11415
|
|
|
|
|
|
#endif |
11416
|
|
|
|
|
|
static int |
11417
|
|
|
|
|
|
S_yywarn(pTHX_ const char *const s, U32 flags) |
11418
|
|
|
|
|
|
{ |
11419
|
|
|
|
|
|
dVAR; |
11420
|
|
|
|
|
|
|
11421
|
|
|
|
|
|
PERL_ARGS_ASSERT_YYWARN; |
11422
|
|
|
|
|
|
|
11423
|
108
|
|
|
|
|
PL_in_eval |= EVAL_WARNONLY; |
11424
|
108
|
|
|
|
|
yyerror_pv(s, flags); |
11425
|
108
|
|
|
|
|
PL_in_eval &= ~EVAL_WARNONLY; |
11426
|
|
|
|
|
|
return 0; |
11427
|
|
|
|
|
|
} |
11428
|
|
|
|
|
|
|
11429
|
|
|
|
|
|
int |
11430
|
1348
|
|
|
|
|
Perl_yyerror(pTHX_ const char *const s) |
11431
|
|
|
|
|
|
{ |
11432
|
|
|
|
|
|
PERL_ARGS_ASSERT_YYERROR; |
11433
|
1348
|
|
|
|
|
return yyerror_pvn(s, strlen(s), 0); |
11434
|
|
|
|
|
|
} |
11435
|
|
|
|
|
|
|
11436
|
|
|
|
|
|
int |
11437
|
810
|
|
|
|
|
Perl_yyerror_pv(pTHX_ const char *const s, U32 flags) |
11438
|
|
|
|
|
|
{ |
11439
|
|
|
|
|
|
PERL_ARGS_ASSERT_YYERROR_PV; |
11440
|
810
|
|
|
|
|
return yyerror_pvn(s, strlen(s), flags); |
11441
|
|
|
|
|
|
} |
11442
|
|
|
|
|
|
|
11443
|
|
|
|
|
|
int |
11444
|
2162
|
|
|
|
|
Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags) |
11445
|
|
|
|
|
|
{ |
11446
|
|
|
|
|
|
dVAR; |
11447
|
|
|
|
|
|
const char *context = NULL; |
11448
|
|
|
|
|
|
int contlen = -1; |
11449
|
|
|
|
|
|
SV *msg; |
11450
|
2162
|
|
|
|
|
SV * const where_sv = newSVpvs_flags("", SVs_TEMP); |
11451
|
2162
|
|
|
|
|
int yychar = PL_parser->yychar; |
11452
|
|
|
|
|
|
|
11453
|
|
|
|
|
|
PERL_ARGS_ASSERT_YYERROR_PVN; |
11454
|
|
|
|
|
|
|
11455
|
2162
|
100
|
|
|
|
if (!yychar || (yychar == ';' && !PL_rsfp)) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
11456
|
426
|
|
|
|
|
sv_catpvs(where_sv, "at EOF"); |
11457
|
2373
|
50
|
|
|
|
else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr && |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
11458
|
2473
|
100
|
|
|
|
PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr && |
|
|
100
|
|
|
|
|
11459
|
1124
|
|
|
|
|
PL_oldbufptr != PL_bufptr) { |
11460
|
|
|
|
|
|
/* |
11461
|
|
|
|
|
|
Only for NetWare: |
11462
|
|
|
|
|
|
The code below is removed for NetWare because it abends/crashes on NetWare |
11463
|
|
|
|
|
|
when the script has error such as not having the closing quotes like: |
11464
|
|
|
|
|
|
if ($var eq "value) |
11465
|
|
|
|
|
|
Checking of white spaces is anyway done in NetWare code. |
11466
|
|
|
|
|
|
*/ |
11467
|
|
|
|
|
|
#ifndef NETWARE |
11468
|
970
|
100
|
|
|
|
while (isSPACE(*PL_oldoldbufptr)) |
11469
|
114
|
|
|
|
|
PL_oldoldbufptr++; |
11470
|
|
|
|
|
|
#endif |
11471
|
856
|
|
|
|
|
context = PL_oldoldbufptr; |
11472
|
856
|
|
|
|
|
contlen = PL_bufptr - PL_oldoldbufptr; |
11473
|
|
|
|
|
|
} |
11474
|
955
|
50
|
|
|
|
else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr && |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
11475
|
225
|
50
|
|
|
|
PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) { |
11476
|
|
|
|
|
|
/* |
11477
|
|
|
|
|
|
Only for NetWare: |
11478
|
|
|
|
|
|
The code below is removed for NetWare because it abends/crashes on NetWare |
11479
|
|
|
|
|
|
when the script has error such as not having the closing quotes like: |
11480
|
|
|
|
|
|
if ($var eq "value) |
11481
|
|
|
|
|
|
Checking of white spaces is anyway done in NetWare code. |
11482
|
|
|
|
|
|
*/ |
11483
|
|
|
|
|
|
#ifndef NETWARE |
11484
|
188
|
100
|
|
|
|
while (isSPACE(*PL_oldbufptr)) |
11485
|
38
|
|
|
|
|
PL_oldbufptr++; |
11486
|
|
|
|
|
|
#endif |
11487
|
150
|
|
|
|
|
context = PL_oldbufptr; |
11488
|
150
|
|
|
|
|
contlen = PL_bufptr - PL_oldbufptr; |
11489
|
|
|
|
|
|
} |
11490
|
730
|
50
|
|
|
|
else if (yychar > 255) |
11491
|
0
|
|
|
|
|
sv_catpvs(where_sv, "next token ???"); |
11492
|
730
|
50
|
|
|
|
else if (yychar == -2) { /* YYEMPTY */ |
11493
|
960
|
100
|
|
|
|
if (PL_lex_state == LEX_NORMAL || |
|
|
50
|
|
|
|
|
11494
|
230
|
0
|
|
|
|
(PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL)) |
11495
|
270
|
|
|
|
|
sv_catpvs(where_sv, "at end of line"); |
11496
|
460
|
100
|
|
|
|
else if (PL_lex_inpat) |
11497
|
114
|
|
|
|
|
sv_catpvs(where_sv, "within pattern"); |
11498
|
|
|
|
|
|
else |
11499
|
346
|
|
|
|
|
sv_catpvs(where_sv, "within string"); |
11500
|
|
|
|
|
|
} |
11501
|
|
|
|
|
|
else { |
11502
|
0
|
|
|
|
|
sv_catpvs(where_sv, "next char "); |
11503
|
0
|
0
|
|
|
|
if (yychar < 32) |
11504
|
0
|
0
|
|
|
|
Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar)); |
|
|
0
|
|
|
|
|
11505
|
0
|
0
|
|
|
|
else if (isPRINT_LC(yychar)) { |
|
|
0
|
|
|
|
|
11506
|
0
|
|
|
|
|
const char string = yychar; |
11507
|
0
|
|
|
|
|
sv_catpvn(where_sv, &string, 1); |
11508
|
|
|
|
|
|
} |
11509
|
|
|
|
|
|
else |
11510
|
0
|
|
|
|
|
Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255); |
11511
|
|
|
|
|
|
} |
11512
|
2162
|
|
|
|
|
msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP); |
11513
|
4324
|
50
|
|
|
|
Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ", |
11514
|
6486
|
|
|
|
|
OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); |
11515
|
2162
|
100
|
|
|
|
if (context) |
11516
|
3479
|
50
|
|
|
|
Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n", |
|
|
100
|
|
|
|
|
11517
|
2472
|
100
|
|
|
|
UTF8fARG(UTF, contlen, context)); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
11518
|
|
|
|
|
|
else |
11519
|
1156
|
|
|
|
|
Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv)); |
11520
|
2162
|
100
|
|
|
|
if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) { |
|
|
50
|
|
|
|
|
11521
|
4
|
|
|
|
|
Perl_sv_catpvf(aTHX_ msg, |
11522
|
|
|
|
|
|
" (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n", |
11523
|
6
|
|
|
|
|
(int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start); |
11524
|
2
|
|
|
|
|
PL_multi_end = 0; |
11525
|
|
|
|
|
|
} |
11526
|
2162
|
100
|
|
|
|
if (PL_in_eval & EVAL_WARNONLY) { |
11527
|
108
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg)); |
11528
|
|
|
|
|
|
} |
11529
|
|
|
|
|
|
else |
11530
|
2054
|
|
|
|
|
qerror(msg); |
11531
|
2162
|
100
|
|
|
|
if (PL_error_count >= 10) { |
11532
|
|
|
|
|
|
SV * errsv; |
11533
|
58
|
50
|
|
|
|
if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv))) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
11534
|
87
|
50
|
|
|
|
Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n", |
11535
|
116
|
|
|
|
|
SVfARG(errsv), OutCopFILE(PL_curcop)); |
11536
|
|
|
|
|
|
else |
11537
|
0
|
0
|
|
|
|
Perl_croak(aTHX_ "%s has too many errors.\n", |
11538
|
0
|
|
|
|
|
OutCopFILE(PL_curcop)); |
11539
|
|
|
|
|
|
} |
11540
|
2104
|
|
|
|
|
PL_in_my = 0; |
11541
|
2104
|
|
|
|
|
PL_in_my_stash = NULL; |
11542
|
2104
|
|
|
|
|
return 0; |
11543
|
|
|
|
|
|
} |
11544
|
|
|
|
|
|
#ifdef __SC__ |
11545
|
|
|
|
|
|
#pragma segment Main |
11546
|
|
|
|
|
|
#endif |
11547
|
|
|
|
|
|
|
11548
|
|
|
|
|
|
STATIC char* |
11549
|
24674
|
|
|
|
|
S_swallow_bom(pTHX_ U8 *s) |
11550
|
|
|
|
|
|
{ |
11551
|
|
|
|
|
|
dVAR; |
11552
|
24674
|
|
|
|
|
const STRLEN slen = SvCUR(PL_linestr); |
11553
|
|
|
|
|
|
|
11554
|
|
|
|
|
|
PERL_ARGS_ASSERT_SWALLOW_BOM; |
11555
|
|
|
|
|
|
|
11556
|
24674
|
|
|
|
|
switch (s[0]) { |
11557
|
|
|
|
|
|
case 0xFF: |
11558
|
1998
|
50
|
|
|
|
if (s[1] == 0xFE) { |
11559
|
|
|
|
|
|
/* UTF-16 little-endian? (or UTF-32LE?) */ |
11560
|
1998
|
50
|
|
|
|
if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */ |
|
|
0
|
|
|
|
|
11561
|
|
|
|
|
|
/* diag_listed_as: Unsupported script encoding %s */ |
11562
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE"); |
11563
|
|
|
|
|
|
#ifndef PERL_NO_UTF16_FILTER |
11564
|
|
|
|
|
|
if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n"); |
11565
|
1998
|
|
|
|
|
s += 2; |
11566
|
1998
|
50
|
|
|
|
if (PL_bufend > (char*)s) { |
11567
|
1998
|
|
|
|
|
s = add_utf16_textfilter(s, TRUE); |
11568
|
|
|
|
|
|
} |
11569
|
|
|
|
|
|
#else |
11570
|
|
|
|
|
|
/* diag_listed_as: Unsupported script encoding %s */ |
11571
|
|
|
|
|
|
Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE"); |
11572
|
|
|
|
|
|
#endif |
11573
|
|
|
|
|
|
} |
11574
|
|
|
|
|
|
break; |
11575
|
|
|
|
|
|
case 0xFE: |
11576
|
1998
|
50
|
|
|
|
if (s[1] == 0xFF) { /* UTF-16 big-endian? */ |
11577
|
|
|
|
|
|
#ifndef PERL_NO_UTF16_FILTER |
11578
|
|
|
|
|
|
if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n"); |
11579
|
1998
|
|
|
|
|
s += 2; |
11580
|
1998
|
50
|
|
|
|
if (PL_bufend > (char *)s) { |
11581
|
1998
|
|
|
|
|
s = add_utf16_textfilter(s, FALSE); |
11582
|
|
|
|
|
|
} |
11583
|
|
|
|
|
|
#else |
11584
|
|
|
|
|
|
/* diag_listed_as: Unsupported script encoding %s */ |
11585
|
|
|
|
|
|
Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE"); |
11586
|
|
|
|
|
|
#endif |
11587
|
|
|
|
|
|
} |
11588
|
|
|
|
|
|
break; |
11589
|
|
|
|
|
|
case BOM_UTF8_FIRST_BYTE: { |
11590
|
|
|
|
|
|
const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */ |
11591
|
28
|
50
|
|
|
|
if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) { |
|
|
50
|
|
|
|
|
11592
|
|
|
|
|
|
if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n"); |
11593
|
28
|
|
|
|
|
s += len + 1; /* UTF-8 */ |
11594
|
|
|
|
|
|
} |
11595
|
|
|
|
|
|
break; |
11596
|
|
|
|
|
|
} |
11597
|
|
|
|
|
|
case 0: |
11598
|
2000
|
100
|
|
|
|
if (slen > 3) { |
11599
|
1996
|
50
|
|
|
|
if (s[1] == 0) { |
11600
|
0
|
0
|
|
|
|
if (s[2] == 0xFE && s[3] == 0xFF) { |
|
|
0
|
|
|
|
|
11601
|
|
|
|
|
|
/* UTF-32 big-endian */ |
11602
|
|
|
|
|
|
/* diag_listed_as: Unsupported script encoding %s */ |
11603
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE"); |
11604
|
|
|
|
|
|
} |
11605
|
|
|
|
|
|
} |
11606
|
1996
|
50
|
|
|
|
else if (s[2] == 0 && s[3] != 0) { |
|
|
50
|
|
|
|
|
11607
|
|
|
|
|
|
/* Leading bytes |
11608
|
|
|
|
|
|
* 00 xx 00 xx |
11609
|
|
|
|
|
|
* are a good indicator of UTF-16BE. */ |
11610
|
|
|
|
|
|
#ifndef PERL_NO_UTF16_FILTER |
11611
|
|
|
|
|
|
if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n"); |
11612
|
1996
|
|
|
|
|
s = add_utf16_textfilter(s, FALSE); |
11613
|
|
|
|
|
|
#else |
11614
|
|
|
|
|
|
/* diag_listed_as: Unsupported script encoding %s */ |
11615
|
|
|
|
|
|
Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE"); |
11616
|
|
|
|
|
|
#endif |
11617
|
|
|
|
|
|
} |
11618
|
|
|
|
|
|
} |
11619
|
|
|
|
|
|
|
11620
|
|
|
|
|
|
default: |
11621
|
20650
|
100
|
|
|
|
if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
11622
|
|
|
|
|
|
/* Leading bytes |
11623
|
|
|
|
|
|
* xx 00 xx 00 |
11624
|
|
|
|
|
|
* are a good indicator of UTF-16LE. */ |
11625
|
|
|
|
|
|
#ifndef PERL_NO_UTF16_FILTER |
11626
|
|
|
|
|
|
if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n"); |
11627
|
1996
|
|
|
|
|
s = add_utf16_textfilter(s, TRUE); |
11628
|
|
|
|
|
|
#else |
11629
|
|
|
|
|
|
/* diag_listed_as: Unsupported script encoding %s */ |
11630
|
|
|
|
|
|
Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE"); |
11631
|
|
|
|
|
|
#endif |
11632
|
|
|
|
|
|
} |
11633
|
|
|
|
|
|
} |
11634
|
24674
|
|
|
|
|
return (char*)s; |
11635
|
|
|
|
|
|
} |
11636
|
|
|
|
|
|
|
11637
|
|
|
|
|
|
|
11638
|
|
|
|
|
|
#ifndef PERL_NO_UTF16_FILTER |
11639
|
|
|
|
|
|
static I32 |
11640
|
23704
|
|
|
|
|
S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) |
11641
|
|
|
|
|
|
{ |
11642
|
|
|
|
|
|
dVAR; |
11643
|
23704
|
50
|
|
|
|
SV *const filter = FILTER_DATA(idx); |
11644
|
|
|
|
|
|
/* We re-use this each time round, throwing the contents away before we |
11645
|
|
|
|
|
|
return. */ |
11646
|
23704
|
|
|
|
|
SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter)); |
11647
|
|
|
|
|
|
SV *const utf8_buffer = filter; |
11648
|
23704
|
|
|
|
|
IV status = IoPAGE(filter); |
11649
|
23704
|
|
|
|
|
const bool reverse = cBOOL(IoLINES(filter)); |
11650
|
|
|
|
|
|
I32 retval; |
11651
|
|
|
|
|
|
|
11652
|
|
|
|
|
|
PERL_ARGS_ASSERT_UTF16_TEXTFILTER; |
11653
|
|
|
|
|
|
|
11654
|
|
|
|
|
|
/* As we're automatically added, at the lowest level, and hence only called |
11655
|
|
|
|
|
|
from this file, we can be sure that we're not called in block mode. Hence |
11656
|
|
|
|
|
|
don't bother writing code to deal with block mode. */ |
11657
|
23704
|
50
|
|
|
|
if (maxlen) { |
11658
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen); |
11659
|
|
|
|
|
|
} |
11660
|
23704
|
50
|
|
|
|
if (status < 0) { |
11661
|
14085
|
|
|
|
|
Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status); |
11662
|
|
|
|
|
|
} |
11663
|
|
|
|
|
|
DEBUG_P(PerlIO_printf(Perl_debug_log, |
11664
|
|
|
|
|
|
"utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n", |
11665
|
|
|
|
|
|
FPTR2DPTR(void *, S_utf16_textfilter), |
11666
|
|
|
|
|
|
reverse ? 'l' : 'b', idx, maxlen, status, |
11667
|
|
|
|
|
|
(UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer))); |
11668
|
|
|
|
|
|
|
11669
|
|
|
|
|
|
while (1) { |
11670
|
|
|
|
|
|
STRLEN chars; |
11671
|
|
|
|
|
|
STRLEN have; |
11672
|
|
|
|
|
|
I32 newlen; |
11673
|
|
|
|
|
|
U8 *end; |
11674
|
|
|
|
|
|
/* First, look in our buffer of existing UTF-8 data: */ |
11675
|
51874
|
|
|
|
|
char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer)); |
11676
|
|
|
|
|
|
|
11677
|
51874
|
100
|
|
|
|
if (nl) { |
11678
|
11724
|
|
|
|
|
++nl; |
11679
|
40150
|
100
|
|
|
|
} else if (status == 0) { |
11680
|
|
|
|
|
|
/* EOF */ |
11681
|
11980
|
|
|
|
|
IoPAGE(filter) = 0; |
11682
|
11980
|
|
|
|
|
nl = SvEND(utf8_buffer); |
11683
|
|
|
|
|
|
} |
11684
|
51874
|
100
|
|
|
|
if (nl) { |
11685
|
23704
|
|
|
|
|
STRLEN got = nl - SvPVX(utf8_buffer); |
11686
|
|
|
|
|
|
/* Did we have anything to append? */ |
11687
|
23704
|
|
|
|
|
retval = got != 0; |
11688
|
23704
|
|
|
|
|
sv_catpvn(sv, SvPVX(utf8_buffer), got); |
11689
|
|
|
|
|
|
/* Everything else in this code works just fine if SVp_POK isn't |
11690
|
|
|
|
|
|
set. This, however, needs it, and we need it to work, else |
11691
|
|
|
|
|
|
we loop infinitely because the buffer is never consumed. */ |
11692
|
37789
|
|
|
|
|
sv_chop(utf8_buffer, nl); |
11693
|
|
|
|
|
|
break; |
11694
|
|
|
|
|
|
} |
11695
|
|
|
|
|
|
|
11696
|
|
|
|
|
|
/* OK, not a complete line there, so need to read some more UTF-16. |
11697
|
|
|
|
|
|
Read an extra octect if the buffer currently has an odd number. */ |
11698
|
|
|
|
|
|
while (1) { |
11699
|
48464
|
100
|
|
|
|
if (status <= 0) |
11700
|
|
|
|
|
|
break; |
11701
|
40476
|
100
|
|
|
|
if (SvCUR(utf16_buffer) >= 2) { |
11702
|
|
|
|
|
|
/* Location of the high octet of the last complete code point. |
11703
|
|
|
|
|
|
Gosh, UTF-16 is a pain. All the benefits of variable length, |
11704
|
|
|
|
|
|
*coupled* with all the benefits of partial reads and |
11705
|
|
|
|
|
|
endianness. */ |
11706
|
40588
|
|
|
|
|
const U8 *const last_hi = (U8*)SvPVX(utf16_buffer) |
11707
|
20294
|
100
|
|
|
|
+ ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2)); |
11708
|
|
|
|
|
|
|
11709
|
20294
|
100
|
|
|
|
if (*last_hi < 0xd8 || *last_hi > 0xdb) { |
11710
|
|
|
|
|
|
break; |
11711
|
|
|
|
|
|
} |
11712
|
|
|
|
|
|
|
11713
|
|
|
|
|
|
/* We have the first half of a surrogate. Read more. */ |
11714
|
|
|
|
|
|
DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi)); |
11715
|
|
|
|
|
|
} |
11716
|
|
|
|
|
|
|
11717
|
20294
|
|
|
|
|
status = FILTER_READ(idx + 1, utf16_buffer, |
11718
|
|
|
|
|
|
160 + (SvCUR(utf16_buffer) & 1)); |
11719
|
|
|
|
|
|
DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer))); |
11720
|
|
|
|
|
|
DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);}); |
11721
|
20294
|
50
|
|
|
|
if (status < 0) { |
11722
|
|
|
|
|
|
/* Error */ |
11723
|
0
|
|
|
|
|
IoPAGE(filter) = status; |
11724
|
0
|
|
|
|
|
return status; |
11725
|
|
|
|
|
|
} |
11726
|
|
|
|
|
|
} |
11727
|
|
|
|
|
|
|
11728
|
28170
|
|
|
|
|
chars = SvCUR(utf16_buffer) >> 1; |
11729
|
28170
|
|
|
|
|
have = SvCUR(utf8_buffer); |
11730
|
28170
|
50
|
|
|
|
SvGROW(utf8_buffer, have + chars * 3 + 1); |
|
|
100
|
|
|
|
|
11731
|
|
|
|
|
|
|
11732
|
28170
|
100
|
|
|
|
if (reverse) { |
11733
|
14110
|
|
|
|
|
end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer), |
11734
|
|
|
|
|
|
(U8*)SvPVX_const(utf8_buffer) + have, |
11735
|
|
|
|
|
|
chars * 2, &newlen); |
11736
|
|
|
|
|
|
} else { |
11737
|
14060
|
|
|
|
|
end = utf16_to_utf8((U8*)SvPVX(utf16_buffer), |
11738
|
|
|
|
|
|
(U8*)SvPVX_const(utf8_buffer) + have, |
11739
|
|
|
|
|
|
chars * 2, &newlen); |
11740
|
|
|
|
|
|
} |
11741
|
28170
|
|
|
|
|
SvCUR_set(utf8_buffer, have + newlen); |
11742
|
28170
|
|
|
|
|
*end = '\0'; |
11743
|
|
|
|
|
|
|
11744
|
|
|
|
|
|
/* No need to keep this SV "well-formed" with a '\0' after the end, as |
11745
|
|
|
|
|
|
it's private to us, and utf16_to_utf8{,reversed} take a |
11746
|
|
|
|
|
|
(pointer,length) pair, rather than a NUL-terminated string. */ |
11747
|
28170
|
100
|
|
|
|
if(SvCUR(utf16_buffer) & 1) { |
11748
|
3938
|
|
|
|
|
*SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1]; |
11749
|
3938
|
|
|
|
|
SvCUR_set(utf16_buffer, 1); |
11750
|
|
|
|
|
|
} else { |
11751
|
24232
|
|
|
|
|
SvCUR_set(utf16_buffer, 0); |
11752
|
|
|
|
|
|
} |
11753
|
|
|
|
|
|
} |
11754
|
|
|
|
|
|
DEBUG_P(PerlIO_printf(Perl_debug_log, |
11755
|
|
|
|
|
|
"utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n", |
11756
|
|
|
|
|
|
status, |
11757
|
|
|
|
|
|
(UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer))); |
11758
|
|
|
|
|
|
DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);}); |
11759
|
23704
|
|
|
|
|
return retval; |
11760
|
|
|
|
|
|
} |
11761
|
|
|
|
|
|
|
11762
|
|
|
|
|
|
static U8 * |
11763
|
7988
|
|
|
|
|
S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed) |
11764
|
|
|
|
|
|
{ |
11765
|
7988
|
|
|
|
|
SV *filter = filter_add(S_utf16_textfilter, NULL); |
11766
|
|
|
|
|
|
|
11767
|
|
|
|
|
|
PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER; |
11768
|
|
|
|
|
|
|
11769
|
7988
|
|
|
|
|
IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s)); |
11770
|
7988
|
|
|
|
|
sv_setpvs(filter, ""); |
11771
|
7988
|
|
|
|
|
IoLINES(filter) = reversed; |
11772
|
7988
|
|
|
|
|
IoPAGE(filter) = 1; /* Not EOF */ |
11773
|
|
|
|
|
|
|
11774
|
|
|
|
|
|
/* Sadly, we have to return a valid pointer, come what may, so we have to |
11775
|
|
|
|
|
|
ignore any error return from this. */ |
11776
|
7988
|
|
|
|
|
SvCUR_set(PL_linestr, 0); |
11777
|
7988
|
50
|
|
|
|
if (FILTER_READ(0, PL_linestr, 0)) { |
11778
|
7988
|
|
|
|
|
SvUTF8_on(PL_linestr); |
11779
|
|
|
|
|
|
} else { |
11780
|
0
|
|
|
|
|
SvUTF8_on(PL_linestr); |
11781
|
|
|
|
|
|
} |
11782
|
7988
|
|
|
|
|
PL_bufend = SvEND(PL_linestr); |
11783
|
7988
|
|
|
|
|
return (U8*)SvPVX(PL_linestr); |
11784
|
|
|
|
|
|
} |
11785
|
|
|
|
|
|
#endif |
11786
|
|
|
|
|
|
|
11787
|
|
|
|
|
|
/* |
11788
|
|
|
|
|
|
Returns a pointer to the next character after the parsed |
11789
|
|
|
|
|
|
vstring, as well as updating the passed in sv. |
11790
|
|
|
|
|
|
|
11791
|
|
|
|
|
|
Function must be called like |
11792
|
|
|
|
|
|
|
11793
|
|
|
|
|
|
sv = sv_2mortal(newSV(5)); |
11794
|
|
|
|
|
|
s = scan_vstring(s,e,sv); |
11795
|
|
|
|
|
|
|
11796
|
|
|
|
|
|
where s and e are the start and end of the string. |
11797
|
|
|
|
|
|
The sv should already be large enough to store the vstring |
11798
|
|
|
|
|
|
passed in, for performance reasons. |
11799
|
|
|
|
|
|
|
11800
|
|
|
|
|
|
This function may croak if fatal warnings are enabled in the |
11801
|
|
|
|
|
|
calling scope, hence the sv_2mortal in the example (to prevent |
11802
|
|
|
|
|
|
a leak). Make sure to do SvREFCNT_inc afterwards if you use |
11803
|
|
|
|
|
|
sv_2mortal. |
11804
|
|
|
|
|
|
|
11805
|
|
|
|
|
|
*/ |
11806
|
|
|
|
|
|
|
11807
|
|
|
|
|
|
char * |
11808
|
32828
|
|
|
|
|
Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv) |
11809
|
|
|
|
|
|
{ |
11810
|
|
|
|
|
|
dVAR; |
11811
|
|
|
|
|
|
const char *pos = s; |
11812
|
|
|
|
|
|
const char *start = s; |
11813
|
|
|
|
|
|
|
11814
|
|
|
|
|
|
PERL_ARGS_ASSERT_SCAN_VSTRING; |
11815
|
|
|
|
|
|
|
11816
|
32828
|
100
|
|
|
|
if (*pos == 'v') pos++; /* get past 'v' */ |
11817
|
67428
|
100
|
|
|
|
while (pos < e && (isDIGIT(*pos) || *pos == '_')) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
11818
|
34600
|
|
|
|
|
pos++; |
11819
|
32828
|
100
|
|
|
|
if ( *pos != '.') { |
11820
|
|
|
|
|
|
/* this may not be a v-string if followed by => */ |
11821
|
|
|
|
|
|
const char *next = pos; |
11822
|
5416
|
100
|
|
|
|
while (next < e && isSPACE(*next)) |
|
|
100
|
|
|
|
|
11823
|
76
|
|
|
|
|
++next; |
11824
|
5340
|
100
|
|
|
|
if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
11825
|
|
|
|
|
|
/* return string not v-string */ |
11826
|
4
|
|
|
|
|
sv_setpvn(sv,(char *)s,pos-s); |
11827
|
4
|
|
|
|
|
return (char *)pos; |
11828
|
|
|
|
|
|
} |
11829
|
|
|
|
|
|
} |
11830
|
|
|
|
|
|
|
11831
|
32824
|
50
|
|
|
|
if (!isALPHA(*pos)) { |
11832
|
|
|
|
|
|
U8 tmpbuf[UTF8_MAXBYTES+1]; |
11833
|
|
|
|
|
|
|
11834
|
32824
|
100
|
|
|
|
if (*s == 'v') |
11835
|
11308
|
|
|
|
|
s++; /* get past 'v' */ |
11836
|
|
|
|
|
|
|
11837
|
61296
|
|
|
|
|
sv_setpvs(sv, ""); |
11838
|
|
|
|
|
|
|
11839
|
|
|
|
|
|
for (;;) { |
11840
|
|
|
|
|
|
/* this is atoi() that tolerates underscores */ |
11841
|
|
|
|
|
|
U8 *tmpend; |
11842
|
|
|
|
|
|
UV rev = 0; |
11843
|
|
|
|
|
|
const char *end = pos; |
11844
|
|
|
|
|
|
UV mult = 1; |
11845
|
250566
|
100
|
|
|
|
while (--end >= s) { |
11846
|
119158
|
100
|
|
|
|
if (*end != '_') { |
11847
|
|
|
|
|
|
const UV orev = rev; |
11848
|
119080
|
|
|
|
|
rev += (*end - '0') * mult; |
11849
|
119080
|
|
|
|
|
mult *= 10; |
11850
|
119080
|
100
|
|
|
|
if (orev > rev) |
11851
|
|
|
|
|
|
/* diag_listed_as: Integer overflow in %s number */ |
11852
|
60841
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), |
11853
|
|
|
|
|
|
"Integer overflow in decimal number"); |
11854
|
|
|
|
|
|
} |
11855
|
|
|
|
|
|
} |
11856
|
|
|
|
|
|
#ifdef EBCDIC |
11857
|
|
|
|
|
|
if (rev > 0x7FFFFFFF) |
11858
|
|
|
|
|
|
Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647"); |
11859
|
|
|
|
|
|
#endif |
11860
|
|
|
|
|
|
/* Append native character for the rev point */ |
11861
|
88324
|
|
|
|
|
tmpend = uvchr_to_utf8(tmpbuf, rev); |
11862
|
88324
|
|
|
|
|
sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); |
11863
|
88324
|
100
|
|
|
|
if (!NATIVE_IS_INVARIANT(rev)) |
11864
|
1342
|
|
|
|
|
SvUTF8_on(sv); |
11865
|
88324
|
100
|
|
|
|
if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1])) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
11866
|
55504
|
|
|
|
|
s = ++pos; |
11867
|
|
|
|
|
|
else { |
11868
|
|
|
|
|
|
s = pos; |
11869
|
|
|
|
|
|
break; |
11870
|
|
|
|
|
|
} |
11871
|
167210
|
100
|
|
|
|
while (pos < e && (isDIGIT(*pos) || *pos == '_')) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
11872
|
84674
|
|
|
|
|
pos++; |
11873
|
|
|
|
|
|
} |
11874
|
32820
|
|
|
|
|
SvPOK_on(sv); |
11875
|
32820
|
|
|
|
|
sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start); |
11876
|
32820
|
|
|
|
|
SvRMAGICAL_on(sv); |
11877
|
|
|
|
|
|
} |
11878
|
32822
|
|
|
|
|
return (char *)s; |
11879
|
|
|
|
|
|
} |
11880
|
|
|
|
|
|
|
11881
|
|
|
|
|
|
int |
11882
|
117971631
|
|
|
|
|
Perl_keyword_plugin_standard(pTHX_ |
11883
|
|
|
|
|
|
char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) |
11884
|
|
|
|
|
|
{ |
11885
|
|
|
|
|
|
PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD; |
11886
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
11887
|
|
|
|
|
|
PERL_UNUSED_ARG(keyword_ptr); |
11888
|
|
|
|
|
|
PERL_UNUSED_ARG(keyword_len); |
11889
|
|
|
|
|
|
PERL_UNUSED_ARG(op_ptr); |
11890
|
117971631
|
|
|
|
|
return KEYWORD_PLUGIN_DECLINE; |
11891
|
|
|
|
|
|
} |
11892
|
|
|
|
|
|
|
11893
|
|
|
|
|
|
#define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p) |
11894
|
|
|
|
|
|
static void |
11895
|
538
|
|
|
|
|
S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof) |
11896
|
|
|
|
|
|
{ |
11897
|
538
|
|
|
|
|
SAVEI32(PL_lex_brackets); |
11898
|
538
|
50
|
|
|
|
if (PL_lex_brackets > 100) |
11899
|
0
|
|
|
|
|
Renew(PL_lex_brackstack, PL_lex_brackets + 10, char); |
11900
|
538
|
|
|
|
|
PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF; |
11901
|
538
|
|
|
|
|
SAVEI32(PL_lex_allbrackets); |
11902
|
538
|
|
|
|
|
PL_lex_allbrackets = 0; |
11903
|
538
|
|
|
|
|
SAVEI8(PL_lex_fakeeof); |
11904
|
538
|
|
|
|
|
PL_lex_fakeeof = (U8)fakeeof; |
11905
|
538
|
100
|
|
|
|
if(yyparse(gramtype) && !PL_parser->error_count) |
|
|
50
|
|
|
|
|
11906
|
0
|
|
|
|
|
qerror(Perl_mess(aTHX_ "Parse error")); |
11907
|
534
|
|
|
|
|
} |
11908
|
|
|
|
|
|
|
11909
|
|
|
|
|
|
#define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p) |
11910
|
|
|
|
|
|
static OP * |
11911
|
538
|
|
|
|
|
S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof) |
11912
|
|
|
|
|
|
{ |
11913
|
|
|
|
|
|
OP *o; |
11914
|
538
|
|
|
|
|
ENTER; |
11915
|
538
|
|
|
|
|
SAVEVPTR(PL_eval_root); |
11916
|
538
|
|
|
|
|
PL_eval_root = NULL; |
11917
|
538
|
|
|
|
|
parse_recdescent(gramtype, fakeeof); |
11918
|
534
|
|
|
|
|
o = PL_eval_root; |
11919
|
534
|
|
|
|
|
LEAVE; |
11920
|
534
|
|
|
|
|
return o; |
11921
|
|
|
|
|
|
} |
11922
|
|
|
|
|
|
|
11923
|
|
|
|
|
|
#define parse_expr(p,f) S_parse_expr(aTHX_ p,f) |
11924
|
|
|
|
|
|
static OP * |
11925
|
284
|
|
|
|
|
S_parse_expr(pTHX_ I32 fakeeof, U32 flags) |
11926
|
|
|
|
|
|
{ |
11927
|
|
|
|
|
|
OP *exprop; |
11928
|
284
|
50
|
|
|
|
if (flags & ~PARSE_OPTIONAL) |
11929
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr"); |
11930
|
284
|
|
|
|
|
exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof); |
11931
|
284
|
100
|
|
|
|
if (!exprop && !(flags & PARSE_OPTIONAL)) { |
|
|
100
|
|
|
|
|
11932
|
4
|
100
|
|
|
|
if (!PL_parser->error_count) |
11933
|
2
|
|
|
|
|
qerror(Perl_mess(aTHX_ "Parse error")); |
11934
|
4
|
|
|
|
|
exprop = newOP(OP_NULL, 0); |
11935
|
|
|
|
|
|
} |
11936
|
284
|
|
|
|
|
return exprop; |
11937
|
|
|
|
|
|
} |
11938
|
|
|
|
|
|
|
11939
|
|
|
|
|
|
/* |
11940
|
|
|
|
|
|
=for apidoc Amx|OP *|parse_arithexpr|U32 flags |
11941
|
|
|
|
|
|
|
11942
|
|
|
|
|
|
Parse a Perl arithmetic expression. This may contain operators of precedence |
11943
|
|
|
|
|
|
down to the bit shift operators. The expression must be followed (and thus |
11944
|
|
|
|
|
|
terminated) either by a comparison or lower-precedence operator or by |
11945
|
|
|
|
|
|
something that would normally terminate an expression such as semicolon. |
11946
|
|
|
|
|
|
If I includes C then the expression is optional, |
11947
|
|
|
|
|
|
otherwise it is mandatory. It is up to the caller to ensure that the |
11948
|
|
|
|
|
|
dynamic parser state (L et al) is correctly set to reflect |
11949
|
|
|
|
|
|
the source of the code to be parsed and the lexical context for the |
11950
|
|
|
|
|
|
expression. |
11951
|
|
|
|
|
|
|
11952
|
|
|
|
|
|
The op tree representing the expression is returned. If an optional |
11953
|
|
|
|
|
|
expression is absent, a null pointer is returned, otherwise the pointer |
11954
|
|
|
|
|
|
will be non-null. |
11955
|
|
|
|
|
|
|
11956
|
|
|
|
|
|
If an error occurs in parsing or compilation, in most cases a valid op |
11957
|
|
|
|
|
|
tree is returned anyway. The error is reflected in the parser state, |
11958
|
|
|
|
|
|
normally resulting in a single exception at the top level of parsing |
11959
|
|
|
|
|
|
which covers all the compilation errors that occurred. Some compilation |
11960
|
|
|
|
|
|
errors, however, will throw an exception immediately. |
11961
|
|
|
|
|
|
|
11962
|
|
|
|
|
|
=cut |
11963
|
|
|
|
|
|
*/ |
11964
|
|
|
|
|
|
|
11965
|
|
|
|
|
|
OP * |
11966
|
68
|
|
|
|
|
Perl_parse_arithexpr(pTHX_ U32 flags) |
11967
|
|
|
|
|
|
{ |
11968
|
68
|
|
|
|
|
return parse_expr(LEX_FAKEEOF_COMPARE, flags); |
11969
|
|
|
|
|
|
} |
11970
|
|
|
|
|
|
|
11971
|
|
|
|
|
|
/* |
11972
|
|
|
|
|
|
=for apidoc Amx|OP *|parse_termexpr|U32 flags |
11973
|
|
|
|
|
|
|
11974
|
|
|
|
|
|
Parse a Perl term expression. This may contain operators of precedence |
11975
|
|
|
|
|
|
down to the assignment operators. The expression must be followed (and thus |
11976
|
|
|
|
|
|
terminated) either by a comma or lower-precedence operator or by |
11977
|
|
|
|
|
|
something that would normally terminate an expression such as semicolon. |
11978
|
|
|
|
|
|
If I includes C then the expression is optional, |
11979
|
|
|
|
|
|
otherwise it is mandatory. It is up to the caller to ensure that the |
11980
|
|
|
|
|
|
dynamic parser state (L et al) is correctly set to reflect |
11981
|
|
|
|
|
|
the source of the code to be parsed and the lexical context for the |
11982
|
|
|
|
|
|
expression. |
11983
|
|
|
|
|
|
|
11984
|
|
|
|
|
|
The op tree representing the expression is returned. If an optional |
11985
|
|
|
|
|
|
expression is absent, a null pointer is returned, otherwise the pointer |
11986
|
|
|
|
|
|
will be non-null. |
11987
|
|
|
|
|
|
|
11988
|
|
|
|
|
|
If an error occurs in parsing or compilation, in most cases a valid op |
11989
|
|
|
|
|
|
tree is returned anyway. The error is reflected in the parser state, |
11990
|
|
|
|
|
|
normally resulting in a single exception at the top level of parsing |
11991
|
|
|
|
|
|
which covers all the compilation errors that occurred. Some compilation |
11992
|
|
|
|
|
|
errors, however, will throw an exception immediately. |
11993
|
|
|
|
|
|
|
11994
|
|
|
|
|
|
=cut |
11995
|
|
|
|
|
|
*/ |
11996
|
|
|
|
|
|
|
11997
|
|
|
|
|
|
OP * |
11998
|
68
|
|
|
|
|
Perl_parse_termexpr(pTHX_ U32 flags) |
11999
|
|
|
|
|
|
{ |
12000
|
68
|
|
|
|
|
return parse_expr(LEX_FAKEEOF_COMMA, flags); |
12001
|
|
|
|
|
|
} |
12002
|
|
|
|
|
|
|
12003
|
|
|
|
|
|
/* |
12004
|
|
|
|
|
|
=for apidoc Amx|OP *|parse_listexpr|U32 flags |
12005
|
|
|
|
|
|
|
12006
|
|
|
|
|
|
Parse a Perl list expression. This may contain operators of precedence |
12007
|
|
|
|
|
|
down to the comma operator. The expression must be followed (and thus |
12008
|
|
|
|
|
|
terminated) either by a low-precedence logic operator such as C or by |
12009
|
|
|
|
|
|
something that would normally terminate an expression such as semicolon. |
12010
|
|
|
|
|
|
If I includes C then the expression is optional, |
12011
|
|
|
|
|
|
otherwise it is mandatory. It is up to the caller to ensure that the |
12012
|
|
|
|
|
|
dynamic parser state (L et al) is correctly set to reflect |
12013
|
|
|
|
|
|
the source of the code to be parsed and the lexical context for the |
12014
|
|
|
|
|
|
expression. |
12015
|
|
|
|
|
|
|
12016
|
|
|
|
|
|
The op tree representing the expression is returned. If an optional |
12017
|
|
|
|
|
|
expression is absent, a null pointer is returned, otherwise the pointer |
12018
|
|
|
|
|
|
will be non-null. |
12019
|
|
|
|
|
|
|
12020
|
|
|
|
|
|
If an error occurs in parsing or compilation, in most cases a valid op |
12021
|
|
|
|
|
|
tree is returned anyway. The error is reflected in the parser state, |
12022
|
|
|
|
|
|
normally resulting in a single exception at the top level of parsing |
12023
|
|
|
|
|
|
which covers all the compilation errors that occurred. Some compilation |
12024
|
|
|
|
|
|
errors, however, will throw an exception immediately. |
12025
|
|
|
|
|
|
|
12026
|
|
|
|
|
|
=cut |
12027
|
|
|
|
|
|
*/ |
12028
|
|
|
|
|
|
|
12029
|
|
|
|
|
|
OP * |
12030
|
80
|
|
|
|
|
Perl_parse_listexpr(pTHX_ U32 flags) |
12031
|
|
|
|
|
|
{ |
12032
|
80
|
|
|
|
|
return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags); |
12033
|
|
|
|
|
|
} |
12034
|
|
|
|
|
|
|
12035
|
|
|
|
|
|
/* |
12036
|
|
|
|
|
|
=for apidoc Amx|OP *|parse_fullexpr|U32 flags |
12037
|
|
|
|
|
|
|
12038
|
|
|
|
|
|
Parse a single complete Perl expression. This allows the full |
12039
|
|
|
|
|
|
expression grammar, including the lowest-precedence operators such |
12040
|
|
|
|
|
|
as C. The expression must be followed (and thus terminated) by a |
12041
|
|
|
|
|
|
token that an expression would normally be terminated by: end-of-file, |
12042
|
|
|
|
|
|
closing bracketing punctuation, semicolon, or one of the keywords that |
12043
|
|
|
|
|
|
signals a postfix expression-statement modifier. If I includes |
12044
|
|
|
|
|
|
C then the expression is optional, otherwise it is |
12045
|
|
|
|
|
|
mandatory. It is up to the caller to ensure that the dynamic parser |
12046
|
|
|
|
|
|
state (L et al) is correctly set to reflect the source of |
12047
|
|
|
|
|
|
the code to be parsed and the lexical context for the expression. |
12048
|
|
|
|
|
|
|
12049
|
|
|
|
|
|
The op tree representing the expression is returned. If an optional |
12050
|
|
|
|
|
|
expression is absent, a null pointer is returned, otherwise the pointer |
12051
|
|
|
|
|
|
will be non-null. |
12052
|
|
|
|
|
|
|
12053
|
|
|
|
|
|
If an error occurs in parsing or compilation, in most cases a valid op |
12054
|
|
|
|
|
|
tree is returned anyway. The error is reflected in the parser state, |
12055
|
|
|
|
|
|
normally resulting in a single exception at the top level of parsing |
12056
|
|
|
|
|
|
which covers all the compilation errors that occurred. Some compilation |
12057
|
|
|
|
|
|
errors, however, will throw an exception immediately. |
12058
|
|
|
|
|
|
|
12059
|
|
|
|
|
|
=cut |
12060
|
|
|
|
|
|
*/ |
12061
|
|
|
|
|
|
|
12062
|
|
|
|
|
|
OP * |
12063
|
68
|
|
|
|
|
Perl_parse_fullexpr(pTHX_ U32 flags) |
12064
|
|
|
|
|
|
{ |
12065
|
68
|
|
|
|
|
return parse_expr(LEX_FAKEEOF_NONEXPR, flags); |
12066
|
|
|
|
|
|
} |
12067
|
|
|
|
|
|
|
12068
|
|
|
|
|
|
/* |
12069
|
|
|
|
|
|
=for apidoc Amx|OP *|parse_block|U32 flags |
12070
|
|
|
|
|
|
|
12071
|
|
|
|
|
|
Parse a single complete Perl code block. This consists of an opening |
12072
|
|
|
|
|
|
brace, a sequence of statements, and a closing brace. The block |
12073
|
|
|
|
|
|
constitutes a lexical scope, so C variables and various compile-time |
12074
|
|
|
|
|
|
effects can be contained within it. It is up to the caller to ensure |
12075
|
|
|
|
|
|
that the dynamic parser state (L et al) is correctly set to |
12076
|
|
|
|
|
|
reflect the source of the code to be parsed and the lexical context for |
12077
|
|
|
|
|
|
the statement. |
12078
|
|
|
|
|
|
|
12079
|
|
|
|
|
|
The op tree representing the code block is returned. This is always a |
12080
|
|
|
|
|
|
real op, never a null pointer. It will normally be a C list, |
12081
|
|
|
|
|
|
including C or equivalent ops. No ops to construct any kind |
12082
|
|
|
|
|
|
of runtime scope are included by virtue of it being a block. |
12083
|
|
|
|
|
|
|
12084
|
|
|
|
|
|
If an error occurs in parsing or compilation, in most cases a valid op |
12085
|
|
|
|
|
|
tree (most likely null) is returned anyway. The error is reflected in |
12086
|
|
|
|
|
|
the parser state, normally resulting in a single exception at the top |
12087
|
|
|
|
|
|
level of parsing which covers all the compilation errors that occurred. |
12088
|
|
|
|
|
|
Some compilation errors, however, will throw an exception immediately. |
12089
|
|
|
|
|
|
|
12090
|
|
|
|
|
|
The I parameter is reserved for future use, and must always |
12091
|
|
|
|
|
|
be zero. |
12092
|
|
|
|
|
|
|
12093
|
|
|
|
|
|
=cut |
12094
|
|
|
|
|
|
*/ |
12095
|
|
|
|
|
|
|
12096
|
|
|
|
|
|
OP * |
12097
|
30
|
|
|
|
|
Perl_parse_block(pTHX_ U32 flags) |
12098
|
|
|
|
|
|
{ |
12099
|
30
|
50
|
|
|
|
if (flags) |
12100
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block"); |
12101
|
30
|
|
|
|
|
return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER); |
12102
|
|
|
|
|
|
} |
12103
|
|
|
|
|
|
|
12104
|
|
|
|
|
|
/* |
12105
|
|
|
|
|
|
=for apidoc Amx|OP *|parse_barestmt|U32 flags |
12106
|
|
|
|
|
|
|
12107
|
|
|
|
|
|
Parse a single unadorned Perl statement. This may be a normal imperative |
12108
|
|
|
|
|
|
statement or a declaration that has compile-time effect. It does not |
12109
|
|
|
|
|
|
include any label or other affixture. It is up to the caller to ensure |
12110
|
|
|
|
|
|
that the dynamic parser state (L et al) is correctly set to |
12111
|
|
|
|
|
|
reflect the source of the code to be parsed and the lexical context for |
12112
|
|
|
|
|
|
the statement. |
12113
|
|
|
|
|
|
|
12114
|
|
|
|
|
|
The op tree representing the statement is returned. This may be a |
12115
|
|
|
|
|
|
null pointer if the statement is null, for example if it was actually |
12116
|
|
|
|
|
|
a subroutine definition (which has compile-time side effects). If not |
12117
|
|
|
|
|
|
null, it will be ops directly implementing the statement, suitable to |
12118
|
|
|
|
|
|
pass to L. It will not normally include a C or |
12119
|
|
|
|
|
|
equivalent op (except for those embedded in a scope contained entirely |
12120
|
|
|
|
|
|
within the statement). |
12121
|
|
|
|
|
|
|
12122
|
|
|
|
|
|
If an error occurs in parsing or compilation, in most cases a valid op |
12123
|
|
|
|
|
|
tree (most likely null) is returned anyway. The error is reflected in |
12124
|
|
|
|
|
|
the parser state, normally resulting in a single exception at the top |
12125
|
|
|
|
|
|
level of parsing which covers all the compilation errors that occurred. |
12126
|
|
|
|
|
|
Some compilation errors, however, will throw an exception immediately. |
12127
|
|
|
|
|
|
|
12128
|
|
|
|
|
|
The I parameter is reserved for future use, and must always |
12129
|
|
|
|
|
|
be zero. |
12130
|
|
|
|
|
|
|
12131
|
|
|
|
|
|
=cut |
12132
|
|
|
|
|
|
*/ |
12133
|
|
|
|
|
|
|
12134
|
|
|
|
|
|
OP * |
12135
|
114
|
|
|
|
|
Perl_parse_barestmt(pTHX_ U32 flags) |
12136
|
|
|
|
|
|
{ |
12137
|
114
|
50
|
|
|
|
if (flags) |
12138
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt"); |
12139
|
114
|
|
|
|
|
return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER); |
12140
|
|
|
|
|
|
} |
12141
|
|
|
|
|
|
|
12142
|
|
|
|
|
|
/* |
12143
|
|
|
|
|
|
=for apidoc Amx|SV *|parse_label|U32 flags |
12144
|
|
|
|
|
|
|
12145
|
|
|
|
|
|
Parse a single label, possibly optional, of the type that may prefix a |
12146
|
|
|
|
|
|
Perl statement. It is up to the caller to ensure that the dynamic parser |
12147
|
|
|
|
|
|
state (L et al) is correctly set to reflect the source of |
12148
|
|
|
|
|
|
the code to be parsed. If I includes C then the |
12149
|
|
|
|
|
|
label is optional, otherwise it is mandatory. |
12150
|
|
|
|
|
|
|
12151
|
|
|
|
|
|
The name of the label is returned in the form of a fresh scalar. If an |
12152
|
|
|
|
|
|
optional label is absent, a null pointer is returned. |
12153
|
|
|
|
|
|
|
12154
|
|
|
|
|
|
If an error occurs in parsing, which can only occur if the label is |
12155
|
|
|
|
|
|
mandatory, a valid label is returned anyway. The error is reflected in |
12156
|
|
|
|
|
|
the parser state, normally resulting in a single exception at the top |
12157
|
|
|
|
|
|
level of parsing which covers all the compilation errors that occurred. |
12158
|
|
|
|
|
|
|
12159
|
|
|
|
|
|
=cut |
12160
|
|
|
|
|
|
*/ |
12161
|
|
|
|
|
|
|
12162
|
|
|
|
|
|
SV * |
12163
|
144
|
|
|
|
|
Perl_parse_label(pTHX_ U32 flags) |
12164
|
|
|
|
|
|
{ |
12165
|
144
|
50
|
|
|
|
if (flags & ~PARSE_OPTIONAL) |
12166
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label"); |
12167
|
144
|
100
|
|
|
|
if (PL_lex_state == LEX_KNOWNEXT) { |
12168
|
48
|
|
|
|
|
PL_parser->yychar = yylex(); |
12169
|
48
|
100
|
|
|
|
if (PL_parser->yychar == LABEL) { |
12170
|
40
|
|
|
|
|
char * const lpv = pl_yylval.pval; |
12171
|
40
|
|
|
|
|
STRLEN llen = strlen(lpv); |
12172
|
40
|
|
|
|
|
PL_parser->yychar = YYEMPTY; |
12173
|
40
|
100
|
|
|
|
return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0); |
12174
|
|
|
|
|
|
} else { |
12175
|
8
|
|
|
|
|
yyunlex(); |
12176
|
8
|
|
|
|
|
goto no_label; |
12177
|
|
|
|
|
|
} |
12178
|
|
|
|
|
|
} else { |
12179
|
|
|
|
|
|
char *s, *t; |
12180
|
|
|
|
|
|
STRLEN wlen, bufptr_pos; |
12181
|
96
|
|
|
|
|
lex_read_space(0); |
12182
|
96
|
|
|
|
|
t = s = PL_bufptr; |
12183
|
96
|
50
|
|
|
|
if (!isIDFIRST_lazy_if(s, UTF)) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
12184
|
|
|
|
|
|
goto no_label; |
12185
|
84
|
|
|
|
|
t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen); |
12186
|
84
|
100
|
|
|
|
if (word_takes_any_delimeter(s, wlen)) |
12187
|
|
|
|
|
|
goto no_label; |
12188
|
80
|
|
|
|
|
bufptr_pos = s - SvPVX(PL_linestr); |
12189
|
80
|
|
|
|
|
PL_bufptr = t; |
12190
|
80
|
|
|
|
|
lex_read_space(LEX_KEEP_PREVIOUS); |
12191
|
80
|
|
|
|
|
t = PL_bufptr; |
12192
|
80
|
|
|
|
|
s = SvPVX(PL_linestr) + bufptr_pos; |
12193
|
80
|
100
|
|
|
|
if (t[0] == ':' && t[1] != ':') { |
|
|
50
|
|
|
|
|
12194
|
76
|
|
|
|
|
PL_oldoldbufptr = PL_oldbufptr; |
12195
|
76
|
|
|
|
|
PL_oldbufptr = s; |
12196
|
76
|
|
|
|
|
PL_bufptr = t+1; |
12197
|
76
|
50
|
|
|
|
return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
12198
|
|
|
|
|
|
} else { |
12199
|
4
|
|
|
|
|
PL_bufptr = s; |
12200
|
|
|
|
|
|
no_label: |
12201
|
28
|
100
|
|
|
|
if (flags & PARSE_OPTIONAL) { |
12202
|
|
|
|
|
|
return NULL; |
12203
|
|
|
|
|
|
} else { |
12204
|
8
|
|
|
|
|
qerror(Perl_mess(aTHX_ "Parse error")); |
12205
|
76
|
|
|
|
|
return newSVpvs("x"); |
12206
|
|
|
|
|
|
} |
12207
|
|
|
|
|
|
} |
12208
|
|
|
|
|
|
} |
12209
|
|
|
|
|
|
} |
12210
|
|
|
|
|
|
|
12211
|
|
|
|
|
|
/* |
12212
|
|
|
|
|
|
=for apidoc Amx|OP *|parse_fullstmt|U32 flags |
12213
|
|
|
|
|
|
|
12214
|
|
|
|
|
|
Parse a single complete Perl statement. This may be a normal imperative |
12215
|
|
|
|
|
|
statement or a declaration that has compile-time effect, and may include |
12216
|
|
|
|
|
|
optional labels. It is up to the caller to ensure that the dynamic |
12217
|
|
|
|
|
|
parser state (L et al) is correctly set to reflect the source |
12218
|
|
|
|
|
|
of the code to be parsed and the lexical context for the statement. |
12219
|
|
|
|
|
|
|
12220
|
|
|
|
|
|
The op tree representing the statement is returned. This may be a |
12221
|
|
|
|
|
|
null pointer if the statement is null, for example if it was actually |
12222
|
|
|
|
|
|
a subroutine definition (which has compile-time side effects). If not |
12223
|
|
|
|
|
|
null, it will be the result of a L call, normally including |
12224
|
|
|
|
|
|
a C or equivalent op. |
12225
|
|
|
|
|
|
|
12226
|
|
|
|
|
|
If an error occurs in parsing or compilation, in most cases a valid op |
12227
|
|
|
|
|
|
tree (most likely null) is returned anyway. The error is reflected in |
12228
|
|
|
|
|
|
the parser state, normally resulting in a single exception at the top |
12229
|
|
|
|
|
|
level of parsing which covers all the compilation errors that occurred. |
12230
|
|
|
|
|
|
Some compilation errors, however, will throw an exception immediately. |
12231
|
|
|
|
|
|
|
12232
|
|
|
|
|
|
The I parameter is reserved for future use, and must always |
12233
|
|
|
|
|
|
be zero. |
12234
|
|
|
|
|
|
|
12235
|
|
|
|
|
|
=cut |
12236
|
|
|
|
|
|
*/ |
12237
|
|
|
|
|
|
|
12238
|
|
|
|
|
|
OP * |
12239
|
68
|
|
|
|
|
Perl_parse_fullstmt(pTHX_ U32 flags) |
12240
|
|
|
|
|
|
{ |
12241
|
68
|
50
|
|
|
|
if (flags) |
12242
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt"); |
12243
|
68
|
|
|
|
|
return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER); |
12244
|
|
|
|
|
|
} |
12245
|
|
|
|
|
|
|
12246
|
|
|
|
|
|
/* |
12247
|
|
|
|
|
|
=for apidoc Amx|OP *|parse_stmtseq|U32 flags |
12248
|
|
|
|
|
|
|
12249
|
|
|
|
|
|
Parse a sequence of zero or more Perl statements. These may be normal |
12250
|
|
|
|
|
|
imperative statements, including optional labels, or declarations |
12251
|
|
|
|
|
|
that have compile-time effect, or any mixture thereof. The statement |
12252
|
|
|
|
|
|
sequence ends when a closing brace or end-of-file is encountered in a |
12253
|
|
|
|
|
|
place where a new statement could have validly started. It is up to |
12254
|
|
|
|
|
|
the caller to ensure that the dynamic parser state (L et al) |
12255
|
|
|
|
|
|
is correctly set to reflect the source of the code to be parsed and the |
12256
|
|
|
|
|
|
lexical context for the statements. |
12257
|
|
|
|
|
|
|
12258
|
|
|
|
|
|
The op tree representing the statement sequence is returned. This may |
12259
|
|
|
|
|
|
be a null pointer if the statements were all null, for example if there |
12260
|
|
|
|
|
|
were no statements or if there were only subroutine definitions (which |
12261
|
|
|
|
|
|
have compile-time side effects). If not null, it will be a C |
12262
|
|
|
|
|
|
list, normally including C or equivalent ops. |
12263
|
|
|
|
|
|
|
12264
|
|
|
|
|
|
If an error occurs in parsing or compilation, in most cases a valid op |
12265
|
|
|
|
|
|
tree is returned anyway. The error is reflected in the parser state, |
12266
|
|
|
|
|
|
normally resulting in a single exception at the top level of parsing |
12267
|
|
|
|
|
|
which covers all the compilation errors that occurred. Some compilation |
12268
|
|
|
|
|
|
errors, however, will throw an exception immediately. |
12269
|
|
|
|
|
|
|
12270
|
|
|
|
|
|
The I parameter is reserved for future use, and must always |
12271
|
|
|
|
|
|
be zero. |
12272
|
|
|
|
|
|
|
12273
|
|
|
|
|
|
=cut |
12274
|
|
|
|
|
|
*/ |
12275
|
|
|
|
|
|
|
12276
|
|
|
|
|
|
OP * |
12277
|
42
|
|
|
|
|
Perl_parse_stmtseq(pTHX_ U32 flags) |
12278
|
|
|
|
|
|
{ |
12279
|
|
|
|
|
|
OP *stmtseqop; |
12280
|
|
|
|
|
|
I32 c; |
12281
|
42
|
50
|
|
|
|
if (flags) |
12282
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq"); |
12283
|
42
|
|
|
|
|
stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING); |
12284
|
42
|
|
|
|
|
c = lex_peek_unichar(0); |
12285
|
42
|
100
|
|
|
|
if (c != -1 && c != /*{*/'}') |
12286
|
4
|
|
|
|
|
qerror(Perl_mess(aTHX_ "Parse error")); |
12287
|
42
|
|
|
|
|
return stmtseqop; |
12288
|
|
|
|
|
|
} |
12289
|
|
|
|
|
|
|
12290
|
|
|
|
|
|
/* |
12291
|
|
|
|
|
|
* Local variables: |
12292
|
|
|
|
|
|
* c-indentation-style: bsd |
12293
|
|
|
|
|
|
* c-basic-offset: 4 |
12294
|
|
|
|
|
|
* indent-tabs-mode: nil |
12295
|
|
|
|
|
|
* End: |
12296
|
|
|
|
|
|
* |
12297
|
|
|
|
|
|
* ex: set ts=8 sts=4 sw=4 et: |
12298
|
|
|
|
|
|
*/ |