line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
/* universal.c |
2
|
|
|
|
|
|
* |
3
|
|
|
|
|
|
* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, |
4
|
|
|
|
|
|
* 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
|
|
|
|
|
|
* '"The roots of those mountains must be roots indeed; there must be |
13
|
|
|
|
|
|
* great secrets buried there which have not been discovered since the |
14
|
|
|
|
|
|
* beginning."' --Gandalf, relating Gollum's history |
15
|
|
|
|
|
|
* |
16
|
|
|
|
|
|
* [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"] |
17
|
|
|
|
|
|
*/ |
18
|
|
|
|
|
|
|
19
|
|
|
|
|
|
/* This file contains the code that implements the functions in Perl's |
20
|
|
|
|
|
|
* UNIVERSAL package, such as UNIVERSAL->can(). |
21
|
|
|
|
|
|
* |
22
|
|
|
|
|
|
* It is also used to store XS functions that need to be present in |
23
|
|
|
|
|
|
* miniperl for a lack of a better place to put them. It might be |
24
|
|
|
|
|
|
* clever to move them to separate XS files which would then be pulled |
25
|
|
|
|
|
|
* in by some to-be-written build process. |
26
|
|
|
|
|
|
*/ |
27
|
|
|
|
|
|
|
28
|
|
|
|
|
|
#include "EXTERN.h" |
29
|
|
|
|
|
|
#define PERL_IN_UNIVERSAL_C |
30
|
|
|
|
|
|
#include "perl.h" |
31
|
|
|
|
|
|
|
32
|
|
|
|
|
|
#ifdef USE_PERLIO |
33
|
|
|
|
|
|
#include "perliol.h" /* For the PERLIO_F_XXX */ |
34
|
|
|
|
|
|
#endif |
35
|
|
|
|
|
|
|
36
|
|
|
|
|
|
/* |
37
|
|
|
|
|
|
* Contributed by Graham Barr |
38
|
|
|
|
|
|
* The main guts of traverse_isa was actually copied from gv_fetchmeth |
39
|
|
|
|
|
|
*/ |
40
|
|
|
|
|
|
|
41
|
|
|
|
|
|
STATIC bool |
42
|
10626665
|
|
|
|
|
S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags) |
43
|
|
|
|
|
|
{ |
44
|
|
|
|
|
|
dVAR; |
45
|
10626665
|
100
|
|
|
|
const struct mro_meta *const meta = HvMROMETA(stash); |
46
|
10626665
|
|
|
|
|
HV *isa = meta->isa; |
47
|
|
|
|
|
|
const HV *our_stash; |
48
|
|
|
|
|
|
|
49
|
|
|
|
|
|
PERL_ARGS_ASSERT_ISA_LOOKUP; |
50
|
|
|
|
|
|
|
51
|
10626665
|
100
|
|
|
|
if (!isa) { |
52
|
17632
|
|
|
|
|
(void)mro_get_linear_isa(stash); |
53
|
17632
|
|
|
|
|
isa = meta->isa; |
54
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
56
|
10626665
|
100
|
|
|
|
if (hv_common(isa, NULL, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0), |
57
|
|
|
|
|
|
HV_FETCH_ISEXISTS, NULL, 0)) { |
58
|
|
|
|
|
|
/* Direct name lookup worked. */ |
59
|
|
|
|
|
|
return TRUE; |
60
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
|
62
|
|
|
|
|
|
/* A stash/class can go by many names (ie. User == main::User), so |
63
|
|
|
|
|
|
we use the HvENAME in the stash itself, which is canonical, falling |
64
|
|
|
|
|
|
back to HvNAME if necessary. */ |
65
|
3800032
|
|
|
|
|
our_stash = gv_stashpvn(name, len, flags); |
66
|
|
|
|
|
|
|
67
|
3800032
|
100
|
|
|
|
if (our_stash) { |
68
|
3753020
|
50
|
|
|
|
HEK *canon_name = HvENAME_HEK(our_stash); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
69
|
3753020
|
50
|
|
|
|
if (!canon_name) canon_name = HvNAME_HEK(our_stash); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
70
|
|
|
|
|
|
|
71
|
3753020
|
100
|
|
|
|
if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name), |
72
|
|
|
|
|
|
HEK_FLAGS(canon_name), |
73
|
|
|
|
|
|
HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) { |
74
|
|
|
|
|
|
return TRUE; |
75
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
78
|
7217206
|
|
|
|
|
return FALSE; |
79
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
81
|
|
|
|
|
|
/* |
82
|
|
|
|
|
|
=head1 SV Manipulation Functions |
83
|
|
|
|
|
|
|
84
|
|
|
|
|
|
=for apidoc sv_derived_from_pvn |
85
|
|
|
|
|
|
|
86
|
|
|
|
|
|
Returns a boolean indicating whether the SV is derived from the specified class |
87
|
|
|
|
|
|
I. To check derivation at the Perl level, call C as a |
88
|
|
|
|
|
|
normal Perl method. |
89
|
|
|
|
|
|
|
90
|
|
|
|
|
|
Currently, the only significant value for C is SVf_UTF8. |
91
|
|
|
|
|
|
|
92
|
|
|
|
|
|
=cut |
93
|
|
|
|
|
|
|
94
|
|
|
|
|
|
=for apidoc sv_derived_from_sv |
95
|
|
|
|
|
|
|
96
|
|
|
|
|
|
Exactly like L, but takes the name string in the form |
97
|
|
|
|
|
|
of an SV instead of a string/length pair. |
98
|
|
|
|
|
|
|
99
|
|
|
|
|
|
=cut |
100
|
|
|
|
|
|
|
101
|
|
|
|
|
|
*/ |
102
|
|
|
|
|
|
|
103
|
|
|
|
|
|
bool |
104
|
7497394
|
|
|
|
|
Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags) |
105
|
|
|
|
|
|
{ |
106
|
|
|
|
|
|
char *namepv; |
107
|
|
|
|
|
|
STRLEN namelen; |
108
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV; |
109
|
7497394
|
50
|
|
|
|
namepv = SvPV(namesv, namelen); |
110
|
7497394
|
100
|
|
|
|
if (SvUTF8(namesv)) |
111
|
674
|
|
|
|
|
flags |= SVf_UTF8; |
112
|
7497394
|
|
|
|
|
return sv_derived_from_pvn(sv, namepv, namelen, flags); |
113
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
115
|
|
|
|
|
|
/* |
116
|
|
|
|
|
|
=for apidoc sv_derived_from |
117
|
|
|
|
|
|
|
118
|
|
|
|
|
|
Exactly like L, but doesn't take a C parameter. |
119
|
|
|
|
|
|
|
120
|
|
|
|
|
|
=cut |
121
|
|
|
|
|
|
*/ |
122
|
|
|
|
|
|
|
123
|
|
|
|
|
|
bool |
124
|
3391935
|
|
|
|
|
Perl_sv_derived_from(pTHX_ SV *sv, const char *const name) |
125
|
|
|
|
|
|
{ |
126
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_DERIVED_FROM; |
127
|
3391935
|
|
|
|
|
return sv_derived_from_pvn(sv, name, strlen(name), 0); |
128
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
130
|
|
|
|
|
|
/* |
131
|
|
|
|
|
|
=for apidoc sv_derived_from_pv |
132
|
|
|
|
|
|
|
133
|
|
|
|
|
|
Exactly like L, but takes a nul-terminated string |
134
|
|
|
|
|
|
instead of a string/length pair. |
135
|
|
|
|
|
|
|
136
|
|
|
|
|
|
=cut |
137
|
|
|
|
|
|
*/ |
138
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
140
|
|
|
|
|
|
bool |
141
|
0
|
|
|
|
|
Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags) |
142
|
|
|
|
|
|
{ |
143
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV; |
144
|
0
|
|
|
|
|
return sv_derived_from_pvn(sv, name, strlen(name), flags); |
145
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
147
|
|
|
|
|
|
bool |
148
|
11048015
|
|
|
|
|
Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags) |
149
|
11048015
|
100
|
|
|
|
{ |
150
|
|
|
|
|
|
dVAR; |
151
|
|
|
|
|
|
HV *stash; |
152
|
|
|
|
|
|
|
153
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN; |
154
|
|
|
|
|
|
|
155
|
5517175
|
|
|
|
|
SvGETMAGIC(sv); |
156
|
|
|
|
|
|
|
157
|
11048015
|
100
|
|
|
|
if (SvROK(sv)) { |
158
|
|
|
|
|
|
const char *type; |
159
|
10789833
|
|
|
|
|
sv = SvRV(sv); |
160
|
10789833
|
|
|
|
|
type = sv_reftype(sv,0); |
161
|
10789833
|
50
|
|
|
|
if (type && strEQ(type,name)) |
|
|
100
|
|
|
|
|
162
|
|
|
|
|
|
return TRUE; |
163
|
10627467
|
100
|
|
|
|
stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL; |
164
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
else { |
166
|
258182
|
|
|
|
|
stash = gv_stashsv(sv, 0); |
167
|
258182
|
100
|
|
|
|
if (!stash) |
168
|
116184
|
|
|
|
|
stash = gv_stashpvs("UNIVERSAL", 0); |
169
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
171
|
10967012
|
100
|
|
|
|
return stash ? isa_lookup(stash, name, len, flags) : FALSE; |
|
|
100
|
|
|
|
|
172
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
174
|
|
|
|
|
|
/* |
175
|
|
|
|
|
|
=for apidoc sv_does_sv |
176
|
|
|
|
|
|
|
177
|
|
|
|
|
|
Returns a boolean indicating whether the SV performs a specific, named role. |
178
|
|
|
|
|
|
The SV can be a Perl object or the name of a Perl class. |
179
|
|
|
|
|
|
|
180
|
|
|
|
|
|
=cut |
181
|
|
|
|
|
|
*/ |
182
|
|
|
|
|
|
|
183
|
|
|
|
|
|
#include "XSUB.h" |
184
|
|
|
|
|
|
|
185
|
|
|
|
|
|
bool |
186
|
172
|
|
|
|
|
Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags) |
187
|
340
|
50
|
|
|
|
{ |
|
|
50
|
|
|
|
|
188
|
|
|
|
|
|
SV *classname; |
189
|
|
|
|
|
|
bool does_it; |
190
|
|
|
|
|
|
SV *methodname; |
191
|
172
|
|
|
|
|
dSP; |
192
|
|
|
|
|
|
|
193
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_DOES_SV; |
194
|
|
|
|
|
|
PERL_UNUSED_ARG(flags); |
195
|
|
|
|
|
|
|
196
|
172
|
|
|
|
|
ENTER; |
197
|
172
|
|
|
|
|
SAVETMPS; |
198
|
|
|
|
|
|
|
199
|
86
|
|
|
|
|
SvGETMAGIC(sv); |
200
|
|
|
|
|
|
|
201
|
172
|
50
|
|
|
|
if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) { |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
202
|
0
|
|
|
|
|
LEAVE; |
203
|
0
|
|
|
|
|
return FALSE; |
204
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
206
|
172
|
50
|
|
|
|
if (sv_isobject(sv)) { |
207
|
0
|
|
|
|
|
classname = sv_ref(NULL,SvRV(sv),TRUE); |
208
|
|
|
|
|
|
} else { |
209
|
|
|
|
|
|
classname = sv; |
210
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
212
|
172
|
100
|
|
|
|
if (sv_eq(classname, namesv)) { |
213
|
4
|
|
|
|
|
LEAVE; |
214
|
4
|
|
|
|
|
return TRUE; |
215
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
217
|
168
|
50
|
|
|
|
PUSHMARK(SP); |
218
|
84
|
|
|
|
|
EXTEND(SP, 2); |
219
|
168
|
|
|
|
|
PUSHs(sv); |
220
|
168
|
|
|
|
|
PUSHs(namesv); |
221
|
168
|
|
|
|
|
PUTBACK; |
222
|
|
|
|
|
|
|
223
|
168
|
|
|
|
|
methodname = newSVpvs_flags("isa", SVs_TEMP); |
224
|
|
|
|
|
|
/* ugly hack: use the SvSCREAM flag so S_method_common |
225
|
|
|
|
|
|
* can figure out we're calling DOES() and not isa(), |
226
|
|
|
|
|
|
* and report eventual errors correctly. --rgs */ |
227
|
168
|
|
|
|
|
SvSCREAM_on(methodname); |
228
|
168
|
|
|
|
|
call_sv(methodname, G_SCALAR | G_METHOD); |
229
|
164
|
|
|
|
|
SPAGAIN; |
230
|
|
|
|
|
|
|
231
|
164
|
50
|
|
|
|
does_it = SvTRUE( TOPs ); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
232
|
164
|
50
|
|
|
|
FREETMPS; |
233
|
164
|
|
|
|
|
LEAVE; |
234
|
|
|
|
|
|
|
235
|
166
|
|
|
|
|
return does_it; |
236
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
238
|
|
|
|
|
|
/* |
239
|
|
|
|
|
|
=for apidoc sv_does |
240
|
|
|
|
|
|
|
241
|
|
|
|
|
|
Like L, but doesn't take a C parameter. |
242
|
|
|
|
|
|
|
243
|
|
|
|
|
|
=cut |
244
|
|
|
|
|
|
*/ |
245
|
|
|
|
|
|
|
246
|
|
|
|
|
|
bool |
247
|
0
|
|
|
|
|
Perl_sv_does(pTHX_ SV *sv, const char *const name) |
248
|
|
|
|
|
|
{ |
249
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_DOES; |
250
|
0
|
|
|
|
|
return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0); |
251
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
253
|
|
|
|
|
|
/* |
254
|
|
|
|
|
|
=for apidoc sv_does_pv |
255
|
|
|
|
|
|
|
256
|
|
|
|
|
|
Like L, but takes a nul-terminated string instead of an SV. |
257
|
|
|
|
|
|
|
258
|
|
|
|
|
|
=cut |
259
|
|
|
|
|
|
*/ |
260
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
262
|
|
|
|
|
|
bool |
263
|
0
|
|
|
|
|
Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags) |
264
|
|
|
|
|
|
{ |
265
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_DOES_PV; |
266
|
0
|
|
|
|
|
return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags); |
267
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
269
|
|
|
|
|
|
/* |
270
|
|
|
|
|
|
=for apidoc sv_does_pvn |
271
|
|
|
|
|
|
|
272
|
|
|
|
|
|
Like L, but takes a string/length pair instead of an SV. |
273
|
|
|
|
|
|
|
274
|
|
|
|
|
|
=cut |
275
|
|
|
|
|
|
*/ |
276
|
|
|
|
|
|
|
277
|
|
|
|
|
|
bool |
278
|
0
|
|
|
|
|
Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags) |
279
|
|
|
|
|
|
{ |
280
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_DOES_PVN; |
281
|
|
|
|
|
|
|
282
|
0
|
|
|
|
|
return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags); |
283
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
285
|
|
|
|
|
|
/* |
286
|
|
|
|
|
|
=for apidoc croak_xs_usage |
287
|
|
|
|
|
|
|
288
|
|
|
|
|
|
A specialised variant of C for emitting the usage message for xsubs |
289
|
|
|
|
|
|
|
290
|
|
|
|
|
|
croak_xs_usage(cv, "eee_yow"); |
291
|
|
|
|
|
|
|
292
|
|
|
|
|
|
works out the package name and subroutine name from C, and then calls |
293
|
|
|
|
|
|
C. Hence if C is C<&ouch::awk>, it would call C as: |
294
|
|
|
|
|
|
|
295
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow"); |
296
|
|
|
|
|
|
|
297
|
|
|
|
|
|
=cut |
298
|
|
|
|
|
|
*/ |
299
|
|
|
|
|
|
|
300
|
|
|
|
|
|
void |
301
|
68
|
|
|
|
|
Perl_croak_xs_usage(const CV *const cv, const char *const params) |
302
|
|
|
|
|
|
{ |
303
|
|
|
|
|
|
const GV *const gv = CvGV(cv); |
304
|
|
|
|
|
|
|
305
|
|
|
|
|
|
PERL_ARGS_ASSERT_CROAK_XS_USAGE; |
306
|
|
|
|
|
|
|
307
|
68
|
50
|
|
|
|
if (gv) { |
308
|
68
|
|
|
|
|
const HV *const stash = GvSTASH(gv); |
309
|
|
|
|
|
|
|
310
|
68
|
50
|
|
|
|
if (HvNAME_get(stash)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
311
|
170
|
50
|
|
|
|
Perl_croak_nocontext("Usage: %"HEKf"::%"HEKf"(%s)", |
|
|
50
|
|
|
|
|
312
|
136
|
50
|
|
|
|
HEKfARG(HvNAME_HEK(stash)), |
313
|
68
|
|
|
|
|
HEKfARG(GvNAME_HEK(gv)), |
314
|
|
|
|
|
|
params); |
315
|
|
|
|
|
|
else |
316
|
0
|
|
|
|
|
Perl_croak_nocontext("Usage: %"HEKf"(%s)", |
317
|
0
|
|
|
|
|
HEKfARG(GvNAME_HEK(gv)), params); |
318
|
|
|
|
|
|
} else { |
319
|
|
|
|
|
|
/* Pants. I don't think that it should be possible to get here. */ |
320
|
0
|
|
|
|
|
Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); |
321
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
324
|
7510358
|
|
|
|
|
XS(XS_UNIVERSAL_isa) |
325
|
|
|
|
|
|
{ |
326
|
|
|
|
|
|
dVAR; |
327
|
7510358
|
|
|
|
|
dXSARGS; |
328
|
|
|
|
|
|
|
329
|
7510358
|
50
|
|
|
|
if (items != 2) |
330
|
0
|
|
|
|
|
croak_xs_usage(cv, "reference, kind"); |
331
|
7510358
|
100
|
|
|
|
else { |
332
|
7510358
|
|
|
|
|
SV * const sv = ST(0); |
333
|
|
|
|
|
|
|
334
|
3752485
|
|
|
|
|
SvGETMAGIC(sv); |
335
|
|
|
|
|
|
|
336
|
7510358
|
100
|
|
|
|
if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
337
|
12964
|
|
|
|
|
XSRETURN_UNDEF; |
338
|
|
|
|
|
|
|
339
|
7497394
|
100
|
|
|
|
ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0)); |
340
|
7503876
|
|
|
|
|
XSRETURN(1); |
341
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
344
|
75499808
|
|
|
|
|
XS(XS_UNIVERSAL_can) |
345
|
75499808
|
100
|
|
|
|
{ |
346
|
|
|
|
|
|
dVAR; |
347
|
75499808
|
|
|
|
|
dXSARGS; |
348
|
|
|
|
|
|
SV *sv; |
349
|
|
|
|
|
|
SV *rv; |
350
|
|
|
|
|
|
HV *pkg = NULL; |
351
|
|
|
|
|
|
GV *iogv; |
352
|
|
|
|
|
|
|
353
|
75499808
|
50
|
|
|
|
if (items != 2) |
354
|
0
|
|
|
|
|
croak_xs_usage(cv, "object-ref, method"); |
355
|
|
|
|
|
|
|
356
|
75499808
|
|
|
|
|
sv = ST(0); |
357
|
|
|
|
|
|
|
358
|
37749908
|
|
|
|
|
SvGETMAGIC(sv); |
359
|
|
|
|
|
|
|
360
|
|
|
|
|
|
/* Reject undef and empty string. Note that the string form takes |
361
|
|
|
|
|
|
precedence here over the numeric form, as (!1)->foo treats the |
362
|
|
|
|
|
|
invocant as the empty string, though it is a dualvar. */ |
363
|
75499808
|
50
|
|
|
|
if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv))) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
364
|
0
|
|
|
|
|
XSRETURN_UNDEF; |
365
|
|
|
|
|
|
|
366
|
|
|
|
|
|
rv = &PL_sv_undef; |
367
|
|
|
|
|
|
|
368
|
75499808
|
100
|
|
|
|
if (SvROK(sv)) { |
369
|
75373974
|
|
|
|
|
sv = MUTABLE_SV(SvRV(sv)); |
370
|
75373974
|
100
|
|
|
|
if (SvOBJECT(sv)) |
371
|
75373702
|
|
|
|
|
pkg = SvSTASH(sv); |
372
|
272
|
100
|
|
|
|
else if (isGV_with_GP(sv) && GvIO(sv)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
373
|
270
|
50
|
|
|
|
pkg = SvSTASH(GvIO(sv)); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
374
|
|
|
|
|
|
} |
375
|
125834
|
100
|
|
|
|
else if (isGV_with_GP(sv) && GvIO(sv)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
376
|
2
|
50
|
|
|
|
pkg = SvSTASH(GvIO(sv)); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
377
|
125832
|
100
|
|
|
|
else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
378
|
2
|
50
|
|
|
|
pkg = SvSTASH(GvIO(iogv)); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
379
|
|
|
|
|
|
else { |
380
|
125830
|
|
|
|
|
pkg = gv_stashsv(sv, 0); |
381
|
125830
|
100
|
|
|
|
if (!pkg) |
382
|
242
|
|
|
|
|
pkg = gv_stashpv("UNIVERSAL", 0); |
383
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
385
|
75499808
|
100
|
|
|
|
if (pkg) { |
386
|
75499806
|
|
|
|
|
GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0); |
387
|
75499806
|
100
|
|
|
|
if (gv && isGV(gv)) |
|
|
50
|
|
|
|
|
388
|
64051058
|
|
|
|
|
rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv)))); |
389
|
|
|
|
|
|
} |
390
|
|
|
|
|
|
|
391
|
75499808
|
|
|
|
|
ST(0) = rv; |
392
|
75499808
|
|
|
|
|
XSRETURN(1); |
393
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
395
|
172
|
|
|
|
|
XS(XS_UNIVERSAL_DOES) |
396
|
|
|
|
|
|
{ |
397
|
|
|
|
|
|
dVAR; |
398
|
172
|
|
|
|
|
dXSARGS; |
399
|
|
|
|
|
|
PERL_UNUSED_ARG(cv); |
400
|
|
|
|
|
|
|
401
|
172
|
50
|
|
|
|
if (items != 2) |
402
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Usage: invocant->DOES(kind)"); |
403
|
|
|
|
|
|
else { |
404
|
172
|
|
|
|
|
SV * const sv = ST(0); |
405
|
172
|
100
|
|
|
|
if (sv_does_sv( sv, ST(1), 0 )) |
406
|
10
|
|
|
|
|
XSRETURN_YES; |
407
|
|
|
|
|
|
|
408
|
163
|
|
|
|
|
XSRETURN_NO; |
409
|
|
|
|
|
|
} |
410
|
|
|
|
|
|
} |
411
|
|
|
|
|
|
|
412
|
25620
|
|
|
|
|
XS(XS_UNIVERSAL_VERSION) |
413
|
|
|
|
|
|
{ |
414
|
|
|
|
|
|
dVAR; |
415
|
25620
|
|
|
|
|
dXSARGS; |
416
|
|
|
|
|
|
HV *pkg; |
417
|
|
|
|
|
|
GV **gvp; |
418
|
|
|
|
|
|
GV *gv; |
419
|
|
|
|
|
|
SV *sv; |
420
|
|
|
|
|
|
const char *undef; |
421
|
|
|
|
|
|
PERL_UNUSED_ARG(cv); |
422
|
|
|
|
|
|
|
423
|
25620
|
100
|
|
|
|
if (SvROK(ST(0))) { |
424
|
130
|
|
|
|
|
sv = MUTABLE_SV(SvRV(ST(0))); |
425
|
130
|
50
|
|
|
|
if (!SvOBJECT(sv)) |
426
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Cannot find version of an unblessed reference"); |
427
|
130
|
|
|
|
|
pkg = SvSTASH(sv); |
428
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
else { |
430
|
25490
|
|
|
|
|
pkg = gv_stashsv(ST(0), 0); |
431
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
433
|
25620
|
100
|
|
|
|
gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL; |
434
|
|
|
|
|
|
|
435
|
25620
|
100
|
|
|
|
if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
436
|
25476
|
|
|
|
|
SV * const nsv = sv_newmortal(); |
437
|
25476
|
|
|
|
|
sv_setsv(nsv, sv); |
438
|
|
|
|
|
|
sv = nsv; |
439
|
25476
|
100
|
|
|
|
if ( !sv_isobject(sv) || !sv_derived_from(sv, "version")) |
|
|
50
|
|
|
|
|
440
|
25356
|
|
|
|
|
upg_version(sv, FALSE); |
441
|
|
|
|
|
|
|
442
|
|
|
|
|
|
undef = NULL; |
443
|
|
|
|
|
|
} |
444
|
|
|
|
|
|
else { |
445
|
|
|
|
|
|
sv = &PL_sv_undef; |
446
|
|
|
|
|
|
undef = "(undef)"; |
447
|
|
|
|
|
|
} |
448
|
|
|
|
|
|
|
449
|
25586
|
100
|
|
|
|
if (items > 1) { |
450
|
20824
|
|
|
|
|
SV *req = ST(1); |
451
|
|
|
|
|
|
|
452
|
20824
|
100
|
|
|
|
if (undef) { |
453
|
62
|
100
|
|
|
|
if (pkg) { |
454
|
40
|
50
|
|
|
|
const HEK * const name = HvNAME_HEK(pkg); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
455
|
40
|
|
|
|
|
Perl_croak(aTHX_ |
456
|
|
|
|
|
|
"%"HEKf" does not define $%"HEKf |
457
|
|
|
|
|
|
"::VERSION--version check failed", |
458
|
|
|
|
|
|
HEKfARG(name), HEKfARG(name)); |
459
|
|
|
|
|
|
} else { |
460
|
22
|
|
|
|
|
Perl_croak(aTHX_ |
461
|
|
|
|
|
|
"%"SVf" defines neither package nor VERSION--version check failed", |
462
|
22
|
|
|
|
|
SVfARG(ST(0)) ); |
463
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
466
|
20762
|
50
|
|
|
|
if ( !sv_isobject(req) || !sv_derived_from(req, "version")) { |
|
|
0
|
|
|
|
|
467
|
|
|
|
|
|
/* req may very well be R/O, so create a new object */ |
468
|
20762
|
|
|
|
|
req = sv_2mortal( new_version(req) ); |
469
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
471
|
20760
|
100
|
|
|
|
if ( vcmp( req, sv ) > 0 ) { |
472
|
204
|
100
|
|
|
|
if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) { |
473
|
115
|
50
|
|
|
|
Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--" |
|
|
50
|
|
|
|
|
474
|
|
|
|
|
|
"this is only version %"SVf"", |
475
|
92
|
50
|
|
|
|
HEKfARG(HvNAME_HEK(pkg)), |
476
|
46
|
|
|
|
|
SVfARG(sv_2mortal(vnormal(req))), |
477
|
46
|
|
|
|
|
SVfARG(sv_2mortal(vnormal(sv)))); |
478
|
|
|
|
|
|
} else { |
479
|
395
|
50
|
|
|
|
Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--" |
|
|
50
|
|
|
|
|
480
|
|
|
|
|
|
"this is only version %"SVf, |
481
|
316
|
50
|
|
|
|
HEKfARG(HvNAME_HEK(pkg)), |
482
|
158
|
|
|
|
|
SVfARG(sv_2mortal(vstringify(req))), |
483
|
158
|
|
|
|
|
SVfARG(sv_2mortal(vstringify(sv)))); |
484
|
|
|
|
|
|
} |
485
|
|
|
|
|
|
} |
486
|
|
|
|
|
|
|
487
|
|
|
|
|
|
} |
488
|
|
|
|
|
|
|
489
|
25318
|
100
|
|
|
|
if ( SvOK(sv) && sv_derived_from(sv, "version") ) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
490
|
25236
|
|
|
|
|
ST(0) = sv_2mortal(vstringify(sv)); |
491
|
|
|
|
|
|
} else { |
492
|
82
|
|
|
|
|
ST(0) = sv; |
493
|
|
|
|
|
|
} |
494
|
|
|
|
|
|
|
495
|
25318
|
|
|
|
|
XSRETURN(1); |
496
|
|
|
|
|
|
} |
497
|
|
|
|
|
|
|
498
|
23266
|
|
|
|
|
XS(XS_version_new) |
499
|
|
|
|
|
|
{ |
500
|
|
|
|
|
|
dVAR; |
501
|
23266
|
|
|
|
|
dXSARGS; |
502
|
23266
|
100
|
|
|
|
if (items > 3 || items < 1) |
503
|
6
|
|
|
|
|
croak_xs_usage(cv, "class, version"); |
504
|
23260
|
|
|
|
|
SP -= items; |
505
|
|
|
|
|
|
{ |
506
|
23260
|
|
|
|
|
SV *vs = ST(1); |
507
|
|
|
|
|
|
SV *rv; |
508
|
|
|
|
|
|
STRLEN len; |
509
|
|
|
|
|
|
const char *classname; |
510
|
|
|
|
|
|
U32 flags; |
511
|
23260
|
100
|
|
|
|
if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */ |
512
|
40
|
|
|
|
|
const HV * stash = SvSTASH(SvRV(ST(0))); |
513
|
40
|
50
|
|
|
|
classname = HvNAME(stash); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
514
|
40
|
50
|
|
|
|
len = HvNAMELEN(stash); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
515
|
40
|
50
|
|
|
|
flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0; |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
516
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
else { |
518
|
23220
|
50
|
|
|
|
classname = SvPV(ST(0), len); |
519
|
23220
|
|
|
|
|
flags = SvUTF8(ST(0)); |
520
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
522
|
23260
|
100
|
|
|
|
if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */ |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
523
|
|
|
|
|
|
/* create empty object */ |
524
|
48
|
|
|
|
|
vs = sv_newmortal(); |
525
|
48
|
|
|
|
|
sv_setpvs(vs, "0"); |
526
|
|
|
|
|
|
} |
527
|
23212
|
100
|
|
|
|
else if ( items == 3 ) { |
528
|
40
|
|
|
|
|
vs = sv_newmortal(); |
529
|
40
|
50
|
|
|
|
Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2))); |
530
|
|
|
|
|
|
} |
531
|
|
|
|
|
|
|
532
|
23260
|
|
|
|
|
rv = new_version(vs); |
533
|
22826
|
50
|
|
|
|
if ( strnNE(classname,"version", len) ) /* inherited new() */ |
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
534
|
1762
|
|
|
|
|
sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags)); |
535
|
|
|
|
|
|
|
536
|
22826
|
|
|
|
|
mPUSHs(rv); |
537
|
22826
|
|
|
|
|
PUTBACK; |
538
|
22826
|
|
|
|
|
return; |
539
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
} |
541
|
|
|
|
|
|
|
542
|
37722
|
|
|
|
|
XS(XS_version_stringify) |
543
|
|
|
|
|
|
{ |
544
|
|
|
|
|
|
dVAR; |
545
|
37722
|
|
|
|
|
dXSARGS; |
546
|
37722
|
50
|
|
|
|
if (items < 1) |
547
|
0
|
|
|
|
|
croak_xs_usage(cv, "lobj, ..."); |
548
|
37722
|
|
|
|
|
SP -= items; |
549
|
|
|
|
|
|
{ |
550
|
37722
|
|
|
|
|
SV * lobj = ST(0); |
551
|
|
|
|
|
|
|
552
|
37722
|
50
|
|
|
|
if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) { |
|
|
50
|
|
|
|
|
553
|
37722
|
|
|
|
|
lobj = SvRV(lobj); |
554
|
|
|
|
|
|
} |
555
|
|
|
|
|
|
else |
556
|
0
|
|
|
|
|
Perl_croak(aTHX_ "lobj is not of type version"); |
557
|
|
|
|
|
|
|
558
|
37722
|
|
|
|
|
mPUSHs(vstringify(lobj)); |
559
|
|
|
|
|
|
|
560
|
37720
|
|
|
|
|
PUTBACK; |
561
|
37720
|
|
|
|
|
return; |
562
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
565
|
252
|
|
|
|
|
XS(XS_version_numify) |
566
|
|
|
|
|
|
{ |
567
|
|
|
|
|
|
dVAR; |
568
|
252
|
|
|
|
|
dXSARGS; |
569
|
252
|
50
|
|
|
|
if (items < 1) |
570
|
0
|
|
|
|
|
croak_xs_usage(cv, "lobj, ..."); |
571
|
252
|
|
|
|
|
SP -= items; |
572
|
|
|
|
|
|
{ |
573
|
252
|
|
|
|
|
SV * lobj = ST(0); |
574
|
|
|
|
|
|
|
575
|
252
|
50
|
|
|
|
if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) { |
|
|
50
|
|
|
|
|
576
|
252
|
|
|
|
|
lobj = SvRV(lobj); |
577
|
|
|
|
|
|
} |
578
|
|
|
|
|
|
else |
579
|
0
|
|
|
|
|
Perl_croak(aTHX_ "lobj is not of type version"); |
580
|
|
|
|
|
|
|
581
|
252
|
|
|
|
|
mPUSHs(vnumify(lobj)); |
582
|
|
|
|
|
|
|
583
|
250
|
|
|
|
|
PUTBACK; |
584
|
250
|
|
|
|
|
return; |
585
|
|
|
|
|
|
} |
586
|
|
|
|
|
|
} |
587
|
|
|
|
|
|
|
588
|
304
|
|
|
|
|
XS(XS_version_normal) |
589
|
|
|
|
|
|
{ |
590
|
|
|
|
|
|
dVAR; |
591
|
304
|
|
|
|
|
dXSARGS; |
592
|
304
|
50
|
|
|
|
if (items < 1) |
593
|
0
|
|
|
|
|
croak_xs_usage(cv, "lobj, ..."); |
594
|
304
|
|
|
|
|
SP -= items; |
595
|
|
|
|
|
|
{ |
596
|
304
|
|
|
|
|
SV * lobj = ST(0); |
597
|
|
|
|
|
|
|
598
|
304
|
50
|
|
|
|
if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) { |
|
|
50
|
|
|
|
|
599
|
304
|
|
|
|
|
lobj = SvRV(lobj); |
600
|
|
|
|
|
|
} |
601
|
|
|
|
|
|
else |
602
|
0
|
|
|
|
|
Perl_croak(aTHX_ "lobj is not of type version"); |
603
|
|
|
|
|
|
|
604
|
304
|
|
|
|
|
mPUSHs(vnormal(lobj)); |
605
|
|
|
|
|
|
|
606
|
302
|
|
|
|
|
PUTBACK; |
607
|
302
|
|
|
|
|
return; |
608
|
|
|
|
|
|
} |
609
|
|
|
|
|
|
} |
610
|
|
|
|
|
|
|
611
|
90648
|
|
|
|
|
XS(XS_version_vcmp) |
612
|
|
|
|
|
|
{ |
613
|
|
|
|
|
|
dVAR; |
614
|
90648
|
|
|
|
|
dXSARGS; |
615
|
90648
|
50
|
|
|
|
if (items < 1) |
616
|
0
|
|
|
|
|
croak_xs_usage(cv, "lobj, ..."); |
617
|
90648
|
|
|
|
|
SP -= items; |
618
|
|
|
|
|
|
{ |
619
|
90648
|
|
|
|
|
SV * lobj = ST(0); |
620
|
|
|
|
|
|
|
621
|
90648
|
50
|
|
|
|
if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) { |
|
|
50
|
|
|
|
|
622
|
90648
|
|
|
|
|
lobj = SvRV(lobj); |
623
|
|
|
|
|
|
} |
624
|
|
|
|
|
|
else |
625
|
0
|
|
|
|
|
Perl_croak(aTHX_ "lobj is not of type version"); |
626
|
|
|
|
|
|
|
627
|
|
|
|
|
|
{ |
628
|
|
|
|
|
|
SV *rs; |
629
|
|
|
|
|
|
SV *rvs; |
630
|
90648
|
|
|
|
|
SV * robj = ST(1); |
631
|
135792
|
50
|
|
|
|
const IV swap = (IV)SvIV(ST(2)); |
632
|
|
|
|
|
|
|
633
|
90648
|
100
|
|
|
|
if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") ) |
|
|
50
|
|
|
|
|
634
|
|
|
|
|
|
{ |
635
|
89002
|
100
|
|
|
|
robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP)); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
636
|
88982
|
|
|
|
|
sv_2mortal(robj); |
637
|
|
|
|
|
|
} |
638
|
90628
|
|
|
|
|
rvs = SvRV(robj); |
639
|
|
|
|
|
|
|
640
|
90628
|
100
|
|
|
|
if ( swap ) |
641
|
|
|
|
|
|
{ |
642
|
104
|
|
|
|
|
rs = newSViv(vcmp(rvs,lobj)); |
643
|
|
|
|
|
|
} |
644
|
|
|
|
|
|
else |
645
|
|
|
|
|
|
{ |
646
|
90524
|
|
|
|
|
rs = newSViv(vcmp(lobj,rvs)); |
647
|
|
|
|
|
|
} |
648
|
|
|
|
|
|
|
649
|
90626
|
|
|
|
|
mPUSHs(rs); |
650
|
|
|
|
|
|
} |
651
|
|
|
|
|
|
|
652
|
90626
|
|
|
|
|
PUTBACK; |
653
|
90626
|
|
|
|
|
return; |
654
|
|
|
|
|
|
} |
655
|
|
|
|
|
|
} |
656
|
|
|
|
|
|
|
657
|
11850
|
|
|
|
|
XS(XS_version_boolean) |
658
|
|
|
|
|
|
{ |
659
|
|
|
|
|
|
dVAR; |
660
|
11850
|
|
|
|
|
dXSARGS; |
661
|
11850
|
50
|
|
|
|
if (items < 1) |
662
|
0
|
|
|
|
|
croak_xs_usage(cv, "lobj, ..."); |
663
|
11850
|
|
|
|
|
SP -= items; |
664
|
11850
|
50
|
|
|
|
if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) { |
|
|
50
|
|
|
|
|
665
|
11850
|
|
|
|
|
SV * const lobj = SvRV(ST(0)); |
666
|
11850
|
|
|
|
|
SV * const rs = |
667
|
11850
|
|
|
|
|
newSViv( vcmp(lobj, |
668
|
|
|
|
|
|
sv_2mortal(new_version( |
669
|
|
|
|
|
|
sv_2mortal(newSVpvs("0")) |
670
|
|
|
|
|
|
)) |
671
|
|
|
|
|
|
) |
672
|
|
|
|
|
|
); |
673
|
11850
|
|
|
|
|
mPUSHs(rs); |
674
|
11850
|
|
|
|
|
PUTBACK; |
675
|
11850
|
|
|
|
|
return; |
676
|
|
|
|
|
|
} |
677
|
|
|
|
|
|
else |
678
|
0
|
|
|
|
|
Perl_croak(aTHX_ "lobj is not of type version"); |
679
|
|
|
|
|
|
} |
680
|
|
|
|
|
|
|
681
|
158
|
|
|
|
|
XS(XS_version_noop) |
682
|
|
|
|
|
|
{ |
683
|
|
|
|
|
|
dVAR; |
684
|
158
|
|
|
|
|
dXSARGS; |
685
|
158
|
50
|
|
|
|
if (items < 1) |
686
|
0
|
|
|
|
|
croak_xs_usage(cv, "lobj, ..."); |
687
|
158
|
50
|
|
|
|
if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) |
|
|
50
|
|
|
|
|
688
|
158
|
|
|
|
|
Perl_croak(aTHX_ "operation not supported with version object"); |
689
|
|
|
|
|
|
else |
690
|
0
|
|
|
|
|
Perl_croak(aTHX_ "lobj is not of type version"); |
691
|
|
|
|
|
|
#ifndef HASATTRIBUTE_NORETURN |
692
|
|
|
|
|
|
XSRETURN_EMPTY; |
693
|
|
|
|
|
|
#endif |
694
|
|
|
|
|
|
} |
695
|
|
|
|
|
|
|
696
|
668
|
|
|
|
|
XS(XS_version_is_alpha) |
697
|
|
|
|
|
|
{ |
698
|
|
|
|
|
|
dVAR; |
699
|
668
|
|
|
|
|
dXSARGS; |
700
|
668
|
50
|
|
|
|
if (items != 1) |
701
|
0
|
|
|
|
|
croak_xs_usage(cv, "lobj"); |
702
|
|
|
|
|
|
SP -= items; |
703
|
668
|
50
|
|
|
|
if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) { |
|
|
50
|
|
|
|
|
704
|
668
|
|
|
|
|
SV * const lobj = ST(0); |
705
|
668
|
100
|
|
|
|
if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) ) |
706
|
46
|
|
|
|
|
XSRETURN_YES; |
707
|
|
|
|
|
|
else |
708
|
622
|
|
|
|
|
XSRETURN_NO; |
709
|
|
|
|
|
|
PUTBACK; |
710
|
|
|
|
|
|
return; |
711
|
|
|
|
|
|
} |
712
|
|
|
|
|
|
else |
713
|
334
|
|
|
|
|
Perl_croak(aTHX_ "lobj is not of type version"); |
714
|
|
|
|
|
|
} |
715
|
|
|
|
|
|
|
716
|
114
|
|
|
|
|
XS(XS_version_qv) |
717
|
|
|
|
|
|
{ |
718
|
|
|
|
|
|
dVAR; |
719
|
114
|
|
|
|
|
dXSARGS; |
720
|
|
|
|
|
|
PERL_UNUSED_ARG(cv); |
721
|
114
|
|
|
|
|
SP -= items; |
722
|
|
|
|
|
|
{ |
723
|
114
|
|
|
|
|
SV * ver = ST(0); |
724
|
|
|
|
|
|
SV * rv; |
725
|
114
|
|
|
|
|
STRLEN len = 0; |
726
|
|
|
|
|
|
const char * classname = ""; |
727
|
|
|
|
|
|
U32 flags = 0; |
728
|
114
|
100
|
|
|
|
if ( items == 2 && SvOK(ST(1)) ) { |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
729
|
102
|
|
|
|
|
ver = ST(1); |
730
|
102
|
50
|
|
|
|
if ( sv_isobject(ST(0)) ) { /* class called as an object method */ |
731
|
0
|
|
|
|
|
const HV * stash = SvSTASH(SvRV(ST(0))); |
732
|
0
|
0
|
|
|
|
classname = HvNAME(stash); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
733
|
0
|
0
|
|
|
|
len = HvNAMELEN(stash); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
734
|
0
|
0
|
|
|
|
flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0; |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
735
|
|
|
|
|
|
} |
736
|
|
|
|
|
|
else { |
737
|
102
|
50
|
|
|
|
classname = SvPV(ST(0), len); |
738
|
102
|
|
|
|
|
flags = SvUTF8(ST(0)); |
739
|
|
|
|
|
|
} |
740
|
|
|
|
|
|
} |
741
|
114
|
100
|
|
|
|
if ( !SvVOK(ver) ) { /* not already a v-string */ |
|
|
50
|
|
|
|
|
742
|
98
|
|
|
|
|
rv = sv_newmortal(); |
743
|
98
|
|
|
|
|
sv_setsv(rv,ver); /* make a duplicate */ |
744
|
98
|
|
|
|
|
upg_version(rv, TRUE); |
745
|
|
|
|
|
|
} else { |
746
|
16
|
|
|
|
|
rv = sv_2mortal(new_version(ver)); |
747
|
|
|
|
|
|
} |
748
|
114
|
100
|
|
|
|
if ( items == 2 |
749
|
102
|
50
|
|
|
|
&& strnNE(classname,"version", len) ) { /* inherited new() */ |
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
750
|
54
|
|
|
|
|
sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags)); |
751
|
|
|
|
|
|
} |
752
|
114
|
|
|
|
|
PUSHs(rv); |
753
|
|
|
|
|
|
} |
754
|
114
|
|
|
|
|
PUTBACK; |
755
|
114
|
|
|
|
|
return; |
756
|
|
|
|
|
|
} |
757
|
|
|
|
|
|
|
758
|
19608
|
|
|
|
|
XS(XS_version_is_qv) |
759
|
|
|
|
|
|
{ |
760
|
|
|
|
|
|
dVAR; |
761
|
19608
|
|
|
|
|
dXSARGS; |
762
|
19608
|
50
|
|
|
|
if (items != 1) |
763
|
0
|
|
|
|
|
croak_xs_usage(cv, "lobj"); |
764
|
|
|
|
|
|
SP -= items; |
765
|
19608
|
50
|
|
|
|
if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) { |
|
|
50
|
|
|
|
|
766
|
19608
|
|
|
|
|
SV * const lobj = ST(0); |
767
|
19608
|
100
|
|
|
|
if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) ) |
768
|
302
|
|
|
|
|
XSRETURN_YES; |
769
|
|
|
|
|
|
else |
770
|
19306
|
|
|
|
|
XSRETURN_NO; |
771
|
|
|
|
|
|
PUTBACK; |
772
|
|
|
|
|
|
return; |
773
|
|
|
|
|
|
} |
774
|
|
|
|
|
|
else |
775
|
9804
|
|
|
|
|
Perl_croak(aTHX_ "lobj is not of type version"); |
776
|
|
|
|
|
|
} |
777
|
|
|
|
|
|
|
778
|
3346
|
|
|
|
|
XS(XS_utf8_is_utf8) |
779
|
|
|
|
|
|
{ |
780
|
|
|
|
|
|
dVAR; |
781
|
3346
|
|
|
|
|
dXSARGS; |
782
|
3346
|
50
|
|
|
|
if (items != 1) |
783
|
0
|
|
|
|
|
croak_xs_usage(cv, "sv"); |
784
|
3346
|
100
|
|
|
|
else { |
785
|
3346
|
|
|
|
|
SV * const sv = ST(0); |
786
|
1681
|
|
|
|
|
SvGETMAGIC(sv); |
787
|
3346
|
100
|
|
|
|
if (SvUTF8(sv)) |
788
|
884
|
|
|
|
|
XSRETURN_YES; |
789
|
|
|
|
|
|
else |
790
|
2904
|
|
|
|
|
XSRETURN_NO; |
791
|
|
|
|
|
|
} |
792
|
|
|
|
|
|
XSRETURN_EMPTY; |
793
|
|
|
|
|
|
} |
794
|
|
|
|
|
|
|
795
|
292
|
|
|
|
|
XS(XS_utf8_valid) |
796
|
|
|
|
|
|
{ |
797
|
|
|
|
|
|
dVAR; |
798
|
292
|
|
|
|
|
dXSARGS; |
799
|
292
|
50
|
|
|
|
if (items != 1) |
800
|
0
|
|
|
|
|
croak_xs_usage(cv, "sv"); |
801
|
|
|
|
|
|
else { |
802
|
292
|
|
|
|
|
SV * const sv = ST(0); |
803
|
|
|
|
|
|
STRLEN len; |
804
|
292
|
50
|
|
|
|
const char * const s = SvPV_const(sv,len); |
805
|
292
|
100
|
|
|
|
if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len)) |
|
|
50
|
|
|
|
|
806
|
292
|
|
|
|
|
XSRETURN_YES; |
807
|
|
|
|
|
|
else |
808
|
146
|
|
|
|
|
XSRETURN_NO; |
809
|
|
|
|
|
|
} |
810
|
|
|
|
|
|
XSRETURN_EMPTY; |
811
|
|
|
|
|
|
} |
812
|
|
|
|
|
|
|
813
|
931500
|
|
|
|
|
XS(XS_utf8_encode) |
814
|
|
|
|
|
|
{ |
815
|
|
|
|
|
|
dVAR; |
816
|
931500
|
|
|
|
|
dXSARGS; |
817
|
931500
|
50
|
|
|
|
if (items != 1) |
818
|
0
|
|
|
|
|
croak_xs_usage(cv, "sv"); |
819
|
931500
|
|
|
|
|
sv_utf8_encode(ST(0)); |
820
|
931498
|
100
|
|
|
|
SvSETMAGIC(ST(0)); |
821
|
931498
|
|
|
|
|
XSRETURN_EMPTY; |
822
|
|
|
|
|
|
} |
823
|
|
|
|
|
|
|
824
|
4932
|
|
|
|
|
XS(XS_utf8_decode) |
825
|
|
|
|
|
|
{ |
826
|
|
|
|
|
|
dVAR; |
827
|
4932
|
|
|
|
|
dXSARGS; |
828
|
4932
|
50
|
|
|
|
if (items != 1) |
829
|
0
|
|
|
|
|
croak_xs_usage(cv, "sv"); |
830
|
|
|
|
|
|
else { |
831
|
4932
|
|
|
|
|
SV * const sv = ST(0); |
832
|
|
|
|
|
|
bool RETVAL; |
833
|
4932
|
100
|
|
|
|
SvPV_force_nolen(sv); |
834
|
4930
|
|
|
|
|
RETVAL = sv_utf8_decode(sv); |
835
|
4930
|
100
|
|
|
|
SvSETMAGIC(sv); |
836
|
4930
|
100
|
|
|
|
ST(0) = boolSV(RETVAL); |
837
|
|
|
|
|
|
} |
838
|
4930
|
|
|
|
|
XSRETURN(1); |
839
|
|
|
|
|
|
} |
840
|
|
|
|
|
|
|
841
|
892150
|
|
|
|
|
XS(XS_utf8_upgrade) |
842
|
|
|
|
|
|
{ |
843
|
|
|
|
|
|
dVAR; |
844
|
892150
|
|
|
|
|
dXSARGS; |
845
|
892150
|
50
|
|
|
|
if (items != 1) |
846
|
0
|
|
|
|
|
croak_xs_usage(cv, "sv"); |
847
|
|
|
|
|
|
else { |
848
|
892150
|
|
|
|
|
SV * const sv = ST(0); |
849
|
|
|
|
|
|
STRLEN RETVAL; |
850
|
892150
|
50
|
|
|
|
dXSTARG; |
851
|
|
|
|
|
|
|
852
|
892150
|
|
|
|
|
RETVAL = sv_utf8_upgrade(sv); |
853
|
892150
|
50
|
|
|
|
XSprePUSH; PUSHi((IV)RETVAL); |
854
|
|
|
|
|
|
} |
855
|
892150
|
|
|
|
|
XSRETURN(1); |
856
|
|
|
|
|
|
} |
857
|
|
|
|
|
|
|
858
|
336842
|
|
|
|
|
XS(XS_utf8_downgrade) |
859
|
|
|
|
|
|
{ |
860
|
|
|
|
|
|
dVAR; |
861
|
336842
|
|
|
|
|
dXSARGS; |
862
|
336842
|
50
|
|
|
|
if (items < 1 || items > 2) |
863
|
0
|
|
|
|
|
croak_xs_usage(cv, "sv, failok=0"); |
864
|
|
|
|
|
|
else { |
865
|
336842
|
|
|
|
|
SV * const sv = ST(0); |
866
|
336842
|
100
|
|
|
|
const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1)); |
|
|
50
|
|
|
|
|
867
|
336842
|
|
|
|
|
const bool RETVAL = sv_utf8_downgrade(sv, failok); |
868
|
|
|
|
|
|
|
869
|
336838
|
100
|
|
|
|
ST(0) = boolSV(RETVAL); |
870
|
|
|
|
|
|
} |
871
|
336838
|
|
|
|
|
XSRETURN(1); |
872
|
|
|
|
|
|
} |
873
|
|
|
|
|
|
|
874
|
12922
|
|
|
|
|
XS(XS_utf8_native_to_unicode) |
875
|
|
|
|
|
|
{ |
876
|
|
|
|
|
|
dVAR; |
877
|
12922
|
|
|
|
|
dXSARGS; |
878
|
12922
|
50
|
|
|
|
const UV uv = SvUV(ST(0)); |
879
|
|
|
|
|
|
|
880
|
12922
|
50
|
|
|
|
if (items > 1) |
881
|
0
|
|
|
|
|
croak_xs_usage(cv, "sv"); |
882
|
|
|
|
|
|
|
883
|
12922
|
|
|
|
|
ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv))); |
884
|
12922
|
|
|
|
|
XSRETURN(1); |
885
|
|
|
|
|
|
} |
886
|
|
|
|
|
|
|
887
|
581416
|
|
|
|
|
XS(XS_utf8_unicode_to_native) |
888
|
|
|
|
|
|
{ |
889
|
|
|
|
|
|
dVAR; |
890
|
581416
|
|
|
|
|
dXSARGS; |
891
|
581416
|
50
|
|
|
|
const UV uv = SvUV(ST(0)); |
892
|
|
|
|
|
|
|
893
|
581416
|
50
|
|
|
|
if (items > 1) |
894
|
0
|
|
|
|
|
croak_xs_usage(cv, "sv"); |
895
|
|
|
|
|
|
|
896
|
581416
|
|
|
|
|
ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv))); |
897
|
581416
|
|
|
|
|
XSRETURN(1); |
898
|
|
|
|
|
|
} |
899
|
|
|
|
|
|
|
900
|
300294
|
|
|
|
|
XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ |
901
|
|
|
|
|
|
{ |
902
|
|
|
|
|
|
dVAR; |
903
|
300294
|
|
|
|
|
dXSARGS; |
904
|
300294
|
|
|
|
|
SV * const svz = ST(0); |
905
|
|
|
|
|
|
SV * sv; |
906
|
|
|
|
|
|
PERL_UNUSED_ARG(cv); |
907
|
|
|
|
|
|
|
908
|
|
|
|
|
|
/* [perl #77776] - called as &foo() not foo() */ |
909
|
300294
|
100
|
|
|
|
if (!SvROK(svz)) |
910
|
8
|
|
|
|
|
croak_xs_usage(cv, "SCALAR[, ON]"); |
911
|
|
|
|
|
|
|
912
|
300286
|
|
|
|
|
sv = SvRV(svz); |
913
|
|
|
|
|
|
|
914
|
300286
|
100
|
|
|
|
if (items == 1) { |
915
|
34
|
100
|
|
|
|
if (SvREADONLY(sv)) |
916
|
22
|
|
|
|
|
XSRETURN_YES; |
917
|
|
|
|
|
|
else |
918
|
12
|
|
|
|
|
XSRETURN_NO; |
919
|
|
|
|
|
|
} |
920
|
300252
|
50
|
|
|
|
else if (items == 2) { |
921
|
300252
|
50
|
|
|
|
if (SvTRUE(ST(1))) { |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
922
|
|
|
|
|
|
#ifdef PERL_OLD_COPY_ON_WRITE |
923
|
|
|
|
|
|
if (SvIsCOW(sv)) sv_force_normal(sv); |
924
|
|
|
|
|
|
#endif |
925
|
300106
|
|
|
|
|
SvREADONLY_on(sv); |
926
|
300106
|
100
|
|
|
|
if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) { |
|
|
50
|
|
|
|
|
927
|
|
|
|
|
|
/* for constant.pm; nobody else should be calling this |
928
|
|
|
|
|
|
on arrays anyway. */ |
929
|
|
|
|
|
|
SV **svp; |
930
|
2880
|
100
|
|
|
|
for (svp = AvARRAY(sv) + AvFILLp(sv) |
931
|
2624
|
|
|
|
|
; svp >= AvARRAY(sv) |
932
|
2112
|
|
|
|
|
; --svp) |
933
|
2112
|
50
|
|
|
|
if (*svp) SvPADTMP_on(*svp); |
934
|
|
|
|
|
|
} |
935
|
300106
|
|
|
|
|
XSRETURN_YES; |
936
|
|
|
|
|
|
} |
937
|
|
|
|
|
|
else { |
938
|
|
|
|
|
|
/* I hope you really know what you are doing. */ |
939
|
146
|
|
|
|
|
SvREADONLY_off(sv); |
940
|
146
|
|
|
|
|
XSRETURN_NO; |
941
|
|
|
|
|
|
} |
942
|
|
|
|
|
|
} |
943
|
158963
|
|
|
|
|
XSRETURN_UNDEF; /* Can't happen. */ |
944
|
|
|
|
|
|
} |
945
|
80
|
|
|
|
|
XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ |
946
|
|
|
|
|
|
{ |
947
|
|
|
|
|
|
dVAR; |
948
|
80
|
|
|
|
|
dXSARGS; |
949
|
80
|
|
|
|
|
SV * const svz = ST(0); |
950
|
|
|
|
|
|
SV * sv; |
951
|
|
|
|
|
|
U32 refcnt; |
952
|
|
|
|
|
|
PERL_UNUSED_ARG(cv); |
953
|
|
|
|
|
|
|
954
|
|
|
|
|
|
/* [perl #77776] - called as &foo() not foo() */ |
955
|
80
|
100
|
|
|
|
if ((items != 1 && items != 2) || !SvROK(svz)) |
|
|
100
|
|
|
|
|
956
|
8
|
|
|
|
|
croak_xs_usage(cv, "SCALAR[, REFCOUNT]"); |
957
|
|
|
|
|
|
|
958
|
72
|
|
|
|
|
sv = SvRV(svz); |
959
|
|
|
|
|
|
|
960
|
|
|
|
|
|
/* I hope you really know what you are doing. */ |
961
|
|
|
|
|
|
/* idea is for SvREFCNT(sv) to be accessed only once */ |
962
|
|
|
|
|
|
refcnt = items == 2 ? |
963
|
|
|
|
|
|
/* we free one ref on exit */ |
964
|
8
|
50
|
|
|
|
(SvREFCNT(sv) = SvUV(ST(1)) + 1) |
965
|
80
|
100
|
|
|
|
: SvREFCNT(sv); |
966
|
72
|
|
|
|
|
XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */ |
967
|
|
|
|
|
|
|
968
|
|
|
|
|
|
} |
969
|
|
|
|
|
|
|
970
|
238
|
|
|
|
|
XS(XS_Internals_hv_clear_placehold) |
971
|
|
|
|
|
|
{ |
972
|
|
|
|
|
|
dVAR; |
973
|
238
|
|
|
|
|
dXSARGS; |
974
|
|
|
|
|
|
|
975
|
238
|
100
|
|
|
|
if (items != 1 || !SvROK(ST(0))) |
|
|
100
|
|
|
|
|
976
|
8
|
|
|
|
|
croak_xs_usage(cv, "hv"); |
977
|
|
|
|
|
|
else { |
978
|
230
|
|
|
|
|
HV * const hv = MUTABLE_HV(SvRV(ST(0))); |
979
|
230
|
|
|
|
|
hv_clear_placeholders(hv); |
980
|
230
|
|
|
|
|
XSRETURN(0); |
981
|
|
|
|
|
|
} |
982
|
|
|
|
|
|
} |
983
|
|
|
|
|
|
|
984
|
6108
|
|
|
|
|
XS(XS_PerlIO_get_layers) |
985
|
|
|
|
|
|
{ |
986
|
|
|
|
|
|
dVAR; |
987
|
6108
|
|
|
|
|
dXSARGS; |
988
|
6108
|
50
|
|
|
|
if (items < 1 || items % 2 == 0) |
|
|
50
|
|
|
|
|
989
|
0
|
|
|
|
|
croak_xs_usage(cv, "filehandle[,args]"); |
990
|
|
|
|
|
|
#ifdef USE_PERLIO |
991
|
|
|
|
|
|
{ |
992
|
|
|
|
|
|
SV * sv; |
993
|
|
|
|
|
|
GV * gv; |
994
|
|
|
|
|
|
IO * io; |
995
|
|
|
|
|
|
bool input = TRUE; |
996
|
|
|
|
|
|
bool details = FALSE; |
997
|
|
|
|
|
|
|
998
|
6108
|
100
|
|
|
|
if (items > 1) { |
999
|
|
|
|
|
|
SV * const *svp; |
1000
|
56
|
100
|
|
|
|
for (svp = MARK + 2; svp <= SP; svp += 2) { |
1001
|
|
|
|
|
|
SV * const * const varp = svp; |
1002
|
|
|
|
|
|
SV * const * const valp = svp + 1; |
1003
|
|
|
|
|
|
STRLEN klen; |
1004
|
36
|
50
|
|
|
|
const char * const key = SvPV_const(*varp, klen); |
1005
|
|
|
|
|
|
|
1006
|
36
|
|
|
|
|
switch (*key) { |
1007
|
|
|
|
|
|
case 'i': |
1008
|
2
|
50
|
|
|
|
if (klen == 5 && memEQ(key, "input", 5)) { |
|
|
50
|
|
|
|
|
1009
|
2
|
50
|
|
|
|
input = SvTRUE(*valp); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
1010
|
2
|
|
|
|
|
break; |
1011
|
|
|
|
|
|
} |
1012
|
|
|
|
|
|
goto fail; |
1013
|
|
|
|
|
|
case 'o': |
1014
|
18
|
50
|
|
|
|
if (klen == 6 && memEQ(key, "output", 6)) { |
|
|
50
|
|
|
|
|
1015
|
18
|
50
|
|
|
|
input = !SvTRUE(*valp); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
1016
|
18
|
|
|
|
|
break; |
1017
|
|
|
|
|
|
} |
1018
|
|
|
|
|
|
goto fail; |
1019
|
|
|
|
|
|
case 'd': |
1020
|
16
|
50
|
|
|
|
if (klen == 7 && memEQ(key, "details", 7)) { |
|
|
50
|
|
|
|
|
1021
|
16
|
50
|
|
|
|
details = SvTRUE(*valp); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
1022
|
16
|
|
|
|
|
break; |
1023
|
|
|
|
|
|
} |
1024
|
|
|
|
|
|
goto fail; |
1025
|
|
|
|
|
|
default: |
1026
|
|
|
|
|
|
fail: |
1027
|
0
|
|
|
|
|
Perl_croak(aTHX_ |
1028
|
|
|
|
|
|
"get_layers: unknown argument '%s'", |
1029
|
|
|
|
|
|
key); |
1030
|
|
|
|
|
|
} |
1031
|
|
|
|
|
|
} |
1032
|
|
|
|
|
|
|
1033
|
20
|
|
|
|
|
SP -= (items - 1); |
1034
|
|
|
|
|
|
} |
1035
|
|
|
|
|
|
|
1036
|
6108
|
|
|
|
|
sv = POPs; |
1037
|
6108
|
100
|
|
|
|
gv = MAYBE_DEREF_GV(sv); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
1038
|
|
|
|
|
|
|
1039
|
6108
|
100
|
|
|
|
if (!gv && !SvROK(sv)) |
|
|
100
|
|
|
|
|
1040
|
36
|
|
|
|
|
gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO); |
1041
|
|
|
|
|
|
|
1042
|
6108
|
100
|
|
|
|
if (gv && (io = GvIO(gv))) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1043
|
6109
|
100
|
|
|
|
AV* const av = PerlIO_get_layers(aTHX_ input ? |
1044
|
18
|
|
|
|
|
IoIFP(io) : IoOFP(io)); |
1045
|
|
|
|
|
|
SSize_t i; |
1046
|
6100
|
|
|
|
|
const SSize_t last = av_len(av); |
1047
|
|
|
|
|
|
SSize_t nitem = 0; |
1048
|
|
|
|
|
|
|
1049
|
30632
|
50
|
|
|
|
for (i = last; i >= 0; i -= 3) { |
|
|
100
|
|
|
|
|
1050
|
12266
|
|
|
|
|
SV * const * const namsvp = av_fetch(av, i - 2, FALSE); |
1051
|
12266
|
|
|
|
|
SV * const * const argsvp = av_fetch(av, i - 1, FALSE); |
1052
|
12266
|
|
|
|
|
SV * const * const flgsvp = av_fetch(av, i, FALSE); |
1053
|
|
|
|
|
|
|
1054
|
12266
|
50
|
|
|
|
const bool namok = namsvp && *namsvp && SvPOK(*namsvp); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1055
|
12266
|
50
|
|
|
|
const bool argok = argsvp && *argsvp && SvPOK(*argsvp); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
1056
|
12266
|
50
|
|
|
|
const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1057
|
|
|
|
|
|
|
1058
|
6133
|
|
|
|
|
EXTEND(SP, 3); /* Three is the max in all branches: better check just once */ |
1059
|
12266
|
100
|
|
|
|
if (details) { |
1060
|
|
|
|
|
|
/* Indents of 5? Yuck. */ |
1061
|
|
|
|
|
|
/* We know that PerlIO_get_layers creates a new SV for |
1062
|
|
|
|
|
|
the name and flags, so we can just take a reference |
1063
|
|
|
|
|
|
and "steal" it when we free the AV below. */ |
1064
|
40
|
50
|
|
|
|
PUSHs(namok |
1065
|
|
|
|
|
|
? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)) |
1066
|
|
|
|
|
|
: &PL_sv_undef); |
1067
|
40
|
100
|
|
|
|
PUSHs(argok |
1068
|
|
|
|
|
|
? newSVpvn_flags(SvPVX_const(*argsvp), |
1069
|
|
|
|
|
|
SvCUR(*argsvp), |
1070
|
|
|
|
|
|
(SvUTF8(*argsvp) ? SVf_UTF8 : 0) |
1071
|
|
|
|
|
|
| SVs_TEMP) |
1072
|
|
|
|
|
|
: &PL_sv_undef); |
1073
|
40
|
50
|
|
|
|
PUSHs(flgok |
1074
|
|
|
|
|
|
? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp)) |
1075
|
|
|
|
|
|
: &PL_sv_undef); |
1076
|
40
|
|
|
|
|
nitem += 3; |
1077
|
|
|
|
|
|
} |
1078
|
|
|
|
|
|
else { |
1079
|
12226
|
50
|
|
|
|
if (namok && argok) |
|
|
100
|
|
|
|
|
1080
|
34
|
|
|
|
|
PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", |
1081
|
|
|
|
|
|
SVfARG(*namsvp), |
1082
|
|
|
|
|
|
SVfARG(*argsvp)))); |
1083
|
12192
|
50
|
|
|
|
else if (namok) |
1084
|
12192
|
|
|
|
|
PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))); |
1085
|
|
|
|
|
|
else |
1086
|
0
|
|
|
|
|
PUSHs(&PL_sv_undef); |
1087
|
12226
|
|
|
|
|
nitem++; |
1088
|
12226
|
50
|
|
|
|
if (flgok) { |
1089
|
12226
|
|
|
|
|
const IV flags = SvIVX(*flgsvp); |
1090
|
|
|
|
|
|
|
1091
|
12226
|
100
|
|
|
|
if (flags & PERLIO_F_UTF8) { |
1092
|
52
|
|
|
|
|
PUSHs(newSVpvs_flags("utf8", SVs_TEMP)); |
1093
|
52
|
|
|
|
|
nitem++; |
1094
|
|
|
|
|
|
} |
1095
|
|
|
|
|
|
} |
1096
|
|
|
|
|
|
} |
1097
|
|
|
|
|
|
} |
1098
|
|
|
|
|
|
|
1099
|
6100
|
|
|
|
|
SvREFCNT_dec(av); |
1100
|
|
|
|
|
|
|
1101
|
6100
|
|
|
|
|
XSRETURN(nitem); |
1102
|
|
|
|
|
|
} |
1103
|
|
|
|
|
|
} |
1104
|
|
|
|
|
|
#endif |
1105
|
|
|
|
|
|
|
1106
|
3058
|
|
|
|
|
XSRETURN(0); |
1107
|
|
|
|
|
|
} |
1108
|
|
|
|
|
|
|
1109
|
|
|
|
|
|
|
1110
|
20086
|
|
|
|
|
XS(XS_re_is_regexp) |
1111
|
|
|
|
|
|
{ |
1112
|
|
|
|
|
|
dVAR; |
1113
|
20086
|
|
|
|
|
dXSARGS; |
1114
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); |
1115
|
|
|
|
|
|
|
1116
|
20086
|
50
|
|
|
|
if (items != 1) |
1117
|
0
|
|
|
|
|
croak_xs_usage(cv, "sv"); |
1118
|
|
|
|
|
|
|
1119
|
20086
|
100
|
|
|
|
if (SvRXOK(ST(0))) { |
1120
|
14788
|
|
|
|
|
XSRETURN_YES; |
1121
|
|
|
|
|
|
} else { |
1122
|
12692
|
|
|
|
|
XSRETURN_NO; |
1123
|
|
|
|
|
|
} |
1124
|
|
|
|
|
|
} |
1125
|
|
|
|
|
|
|
1126
|
4
|
|
|
|
|
XS(XS_re_regnames_count) |
1127
|
|
|
|
|
|
{ |
1128
|
4
|
50
|
|
|
|
REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; |
1129
|
|
|
|
|
|
SV * ret; |
1130
|
|
|
|
|
|
dVAR; |
1131
|
4
|
|
|
|
|
dXSARGS; |
1132
|
|
|
|
|
|
|
1133
|
4
|
50
|
|
|
|
if (items != 0) |
1134
|
0
|
|
|
|
|
croak_xs_usage(cv, ""); |
1135
|
|
|
|
|
|
|
1136
|
4
|
|
|
|
|
SP -= items; |
1137
|
4
|
|
|
|
|
PUTBACK; |
1138
|
|
|
|
|
|
|
1139
|
4
|
50
|
|
|
|
if (!rx) |
1140
|
0
|
|
|
|
|
XSRETURN_UNDEF; |
1141
|
|
|
|
|
|
|
1142
|
4
|
|
|
|
|
ret = CALLREG_NAMED_BUFF_COUNT(rx); |
1143
|
|
|
|
|
|
|
1144
|
4
|
|
|
|
|
SPAGAIN; |
1145
|
4
|
50
|
|
|
|
PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); |
1146
|
4
|
|
|
|
|
XSRETURN(1); |
1147
|
|
|
|
|
|
} |
1148
|
|
|
|
|
|
|
1149
|
4
|
|
|
|
|
XS(XS_re_regname) |
1150
|
|
|
|
|
|
{ |
1151
|
|
|
|
|
|
dVAR; |
1152
|
4
|
|
|
|
|
dXSARGS; |
1153
|
|
|
|
|
|
REGEXP * rx; |
1154
|
|
|
|
|
|
U32 flags; |
1155
|
|
|
|
|
|
SV * ret; |
1156
|
|
|
|
|
|
|
1157
|
4
|
50
|
|
|
|
if (items < 1 || items > 2) |
1158
|
0
|
|
|
|
|
croak_xs_usage(cv, "name[, all ]"); |
1159
|
|
|
|
|
|
|
1160
|
4
|
|
|
|
|
SP -= items; |
1161
|
4
|
|
|
|
|
PUTBACK; |
1162
|
|
|
|
|
|
|
1163
|
4
|
50
|
|
|
|
rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; |
1164
|
|
|
|
|
|
|
1165
|
4
|
50
|
|
|
|
if (!rx) |
1166
|
0
|
|
|
|
|
XSRETURN_UNDEF; |
1167
|
|
|
|
|
|
|
1168
|
4
|
50
|
|
|
|
if (items == 2 && SvTRUE(ST(1))) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
1169
|
|
|
|
|
|
flags = RXapif_ALL; |
1170
|
|
|
|
|
|
} else { |
1171
|
|
|
|
|
|
flags = RXapif_ONE; |
1172
|
|
|
|
|
|
} |
1173
|
4
|
|
|
|
|
ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME)); |
1174
|
|
|
|
|
|
|
1175
|
4
|
|
|
|
|
SPAGAIN; |
1176
|
4
|
50
|
|
|
|
PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); |
1177
|
4
|
|
|
|
|
XSRETURN(1); |
1178
|
|
|
|
|
|
} |
1179
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
|
1181
|
8
|
|
|
|
|
XS(XS_re_regnames) |
1182
|
8
|
50
|
|
|
|
{ |
1183
|
|
|
|
|
|
dVAR; |
1184
|
8
|
|
|
|
|
dXSARGS; |
1185
|
|
|
|
|
|
REGEXP * rx; |
1186
|
|
|
|
|
|
U32 flags; |
1187
|
|
|
|
|
|
SV *ret; |
1188
|
|
|
|
|
|
AV *av; |
1189
|
|
|
|
|
|
SSize_t length; |
1190
|
|
|
|
|
|
SSize_t i; |
1191
|
|
|
|
|
|
SV **entry; |
1192
|
|
|
|
|
|
|
1193
|
8
|
50
|
|
|
|
if (items > 1) |
1194
|
0
|
|
|
|
|
croak_xs_usage(cv, "[all]"); |
1195
|
|
|
|
|
|
|
1196
|
8
|
50
|
|
|
|
rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; |
1197
|
|
|
|
|
|
|
1198
|
8
|
50
|
|
|
|
if (!rx) |
1199
|
0
|
|
|
|
|
XSRETURN_UNDEF; |
1200
|
|
|
|
|
|
|
1201
|
8
|
100
|
|
|
|
if (items == 1 && SvTRUE(ST(0))) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
1202
|
|
|
|
|
|
flags = RXapif_ALL; |
1203
|
|
|
|
|
|
} else { |
1204
|
|
|
|
|
|
flags = RXapif_ONE; |
1205
|
|
|
|
|
|
} |
1206
|
|
|
|
|
|
|
1207
|
8
|
|
|
|
|
SP -= items; |
1208
|
8
|
|
|
|
|
PUTBACK; |
1209
|
|
|
|
|
|
|
1210
|
8
|
|
|
|
|
ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES)); |
1211
|
|
|
|
|
|
|
1212
|
8
|
|
|
|
|
SPAGAIN; |
1213
|
|
|
|
|
|
|
1214
|
8
|
50
|
|
|
|
if (!ret) |
1215
|
0
|
|
|
|
|
XSRETURN_UNDEF; |
1216
|
|
|
|
|
|
|
1217
|
8
|
|
|
|
|
av = MUTABLE_AV(SvRV(ret)); |
1218
|
8
|
|
|
|
|
length = av_len(av); |
1219
|
|
|
|
|
|
|
1220
|
8
|
|
|
|
|
EXTEND(SP, length+1); /* better extend stack just once */ |
1221
|
22
|
100
|
|
|
|
for (i = 0; i <= length; i++) { |
1222
|
18
|
|
|
|
|
entry = av_fetch(av, i, FALSE); |
1223
|
|
|
|
|
|
|
1224
|
18
|
50
|
|
|
|
if (!entry) |
1225
|
0
|
|
|
|
|
Perl_croak(aTHX_ "NULL array element in re::regnames()"); |
1226
|
|
|
|
|
|
|
1227
|
18
|
|
|
|
|
mPUSHs(SvREFCNT_inc_simple_NN(*entry)); |
1228
|
|
|
|
|
|
} |
1229
|
|
|
|
|
|
|
1230
|
8
|
|
|
|
|
SvREFCNT_dec(ret); |
1231
|
|
|
|
|
|
|
1232
|
8
|
|
|
|
|
PUTBACK; |
1233
|
8
|
|
|
|
|
return; |
1234
|
|
|
|
|
|
} |
1235
|
|
|
|
|
|
|
1236
|
26
|
|
|
|
|
XS(XS_re_regexp_pattern) |
1237
|
26
|
50
|
|
|
|
{ |
1238
|
|
|
|
|
|
dVAR; |
1239
|
26
|
|
|
|
|
dXSARGS; |
1240
|
|
|
|
|
|
REGEXP *re; |
1241
|
|
|
|
|
|
|
1242
|
13
|
|
|
|
|
EXTEND(SP, 2); |
1243
|
26
|
|
|
|
|
SP -= items; |
1244
|
26
|
50
|
|
|
|
if (items != 1) |
1245
|
0
|
|
|
|
|
croak_xs_usage(cv, "sv"); |
1246
|
|
|
|
|
|
|
1247
|
|
|
|
|
|
/* |
1248
|
|
|
|
|
|
Checks if a reference is a regex or not. If the parameter is |
1249
|
|
|
|
|
|
not a ref, or is not the result of a qr// then returns false |
1250
|
|
|
|
|
|
in scalar context and an empty list in list context. |
1251
|
|
|
|
|
|
Otherwise in list context it returns the pattern and the |
1252
|
|
|
|
|
|
modifiers, in scalar context it returns the pattern just as it |
1253
|
|
|
|
|
|
would if the qr// was stringified normally, regardless as |
1254
|
|
|
|
|
|
to the class of the variable and any stringification overloads |
1255
|
|
|
|
|
|
on the object. |
1256
|
|
|
|
|
|
*/ |
1257
|
|
|
|
|
|
|
1258
|
26
|
100
|
|
|
|
if ((re = SvRX(ST(0)))) /* assign deliberate */ |
1259
|
|
|
|
|
|
{ |
1260
|
|
|
|
|
|
/* Houston, we have a regex! */ |
1261
|
|
|
|
|
|
SV *pattern; |
1262
|
|
|
|
|
|
|
1263
|
24
|
50
|
|
|
|
if ( GIMME_V == G_ARRAY ) { |
|
|
100
|
|
|
|
|
1264
|
|
|
|
|
|
STRLEN left = 0; |
1265
|
|
|
|
|
|
char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH]; |
1266
|
|
|
|
|
|
const char *fptr; |
1267
|
|
|
|
|
|
char ch; |
1268
|
|
|
|
|
|
U16 match_flags; |
1269
|
|
|
|
|
|
|
1270
|
|
|
|
|
|
/* |
1271
|
|
|
|
|
|
we are in list context so stringify |
1272
|
|
|
|
|
|
the modifiers that apply. We ignore "negative |
1273
|
|
|
|
|
|
modifiers" in this scenario, and the default character set |
1274
|
|
|
|
|
|
*/ |
1275
|
|
|
|
|
|
|
1276
|
27
|
100
|
|
|
|
if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) { |
1277
|
|
|
|
|
|
STRLEN len; |
1278
|
16
|
|
|
|
|
const char* const name = get_regex_charset_name(RX_EXTFLAGS(re), |
1279
|
|
|
|
|
|
&len); |
1280
|
16
|
|
|
|
|
Copy(name, reflags + left, len, char); |
1281
|
|
|
|
|
|
left += len; |
1282
|
|
|
|
|
|
} |
1283
|
|
|
|
|
|
fptr = INT_PAT_MODS; |
1284
|
18
|
|
|
|
|
match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME) |
1285
|
|
|
|
|
|
>> RXf_PMf_STD_PMMOD_SHIFT); |
1286
|
|
|
|
|
|
|
1287
|
117
|
100
|
|
|
|
while((ch = *fptr++)) { |
1288
|
90
|
100
|
|
|
|
if(match_flags & 1) { |
1289
|
16
|
|
|
|
|
reflags[left++] = ch; |
1290
|
|
|
|
|
|
} |
1291
|
90
|
|
|
|
|
match_flags >>= 1; |
1292
|
|
|
|
|
|
} |
1293
|
|
|
|
|
|
|
1294
|
45
|
|
|
|
|
pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re), |
1295
|
|
|
|
|
|
(RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP); |
1296
|
|
|
|
|
|
|
1297
|
|
|
|
|
|
/* return the pattern and the modifiers */ |
1298
|
18
|
|
|
|
|
PUSHs(pattern); |
1299
|
18
|
|
|
|
|
PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP)); |
1300
|
18
|
|
|
|
|
XSRETURN(2); |
1301
|
|
|
|
|
|
} else { |
1302
|
|
|
|
|
|
/* Scalar, so use the string that Perl would return */ |
1303
|
|
|
|
|
|
/* return the pattern in (?msix:..) format */ |
1304
|
|
|
|
|
|
#if PERL_VERSION >= 11 |
1305
|
6
|
|
|
|
|
pattern = sv_2mortal(newSVsv(MUTABLE_SV(re))); |
1306
|
|
|
|
|
|
#else |
1307
|
|
|
|
|
|
pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re), |
1308
|
|
|
|
|
|
(RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP); |
1309
|
|
|
|
|
|
#endif |
1310
|
6
|
|
|
|
|
PUSHs(pattern); |
1311
|
6
|
|
|
|
|
XSRETURN(1); |
1312
|
|
|
|
|
|
} |
1313
|
|
|
|
|
|
} else { |
1314
|
|
|
|
|
|
/* It ain't a regexp folks */ |
1315
|
2
|
50
|
|
|
|
if ( GIMME_V == G_ARRAY ) { |
|
|
50
|
|
|
|
|
1316
|
|
|
|
|
|
/* return the empty list */ |
1317
|
0
|
|
|
|
|
XSRETURN_UNDEF; |
1318
|
|
|
|
|
|
} else { |
1319
|
|
|
|
|
|
/* Because of the (?:..) wrapping involved in a |
1320
|
|
|
|
|
|
stringified pattern it is impossible to get a |
1321
|
|
|
|
|
|
result for a real regexp that would evaluate to |
1322
|
|
|
|
|
|
false. Therefore we can return PL_sv_no to signify |
1323
|
|
|
|
|
|
that the object is not a regex, this means that one |
1324
|
|
|
|
|
|
can say |
1325
|
|
|
|
|
|
|
1326
|
|
|
|
|
|
if (regex($might_be_a_regex) eq '(?:foo)') { } |
1327
|
|
|
|
|
|
|
1328
|
|
|
|
|
|
and not worry about undefined values. |
1329
|
|
|
|
|
|
*/ |
1330
|
14
|
|
|
|
|
XSRETURN_NO; |
1331
|
|
|
|
|
|
} |
1332
|
|
|
|
|
|
} |
1333
|
|
|
|
|
|
/* NOT-REACHED */ |
1334
|
|
|
|
|
|
} |
1335
|
|
|
|
|
|
|
1336
|
|
|
|
|
|
struct xsub_details { |
1337
|
|
|
|
|
|
const char *name; |
1338
|
|
|
|
|
|
XSUBADDR_t xsub; |
1339
|
|
|
|
|
|
const char *proto; |
1340
|
|
|
|
|
|
}; |
1341
|
|
|
|
|
|
|
1342
|
|
|
|
|
|
const struct xsub_details details[] = { |
1343
|
|
|
|
|
|
{"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL}, |
1344
|
|
|
|
|
|
{"UNIVERSAL::can", XS_UNIVERSAL_can, NULL}, |
1345
|
|
|
|
|
|
{"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL}, |
1346
|
|
|
|
|
|
{"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL}, |
1347
|
|
|
|
|
|
{"version::()", XS_version_noop, NULL}, |
1348
|
|
|
|
|
|
{"version::new", XS_version_new, NULL}, |
1349
|
|
|
|
|
|
{"version::parse", XS_version_new, NULL}, |
1350
|
|
|
|
|
|
{"version::(\"\"", XS_version_stringify, NULL}, |
1351
|
|
|
|
|
|
{"version::stringify", XS_version_stringify, NULL}, |
1352
|
|
|
|
|
|
{"version::(0+", XS_version_numify, NULL}, |
1353
|
|
|
|
|
|
{"version::numify", XS_version_numify, NULL}, |
1354
|
|
|
|
|
|
{"version::normal", XS_version_normal, NULL}, |
1355
|
|
|
|
|
|
{"version::(cmp", XS_version_vcmp, NULL}, |
1356
|
|
|
|
|
|
{"version::(<=>", XS_version_vcmp, NULL}, |
1357
|
|
|
|
|
|
{"version::vcmp", XS_version_vcmp, NULL}, |
1358
|
|
|
|
|
|
{"version::(bool", XS_version_boolean, NULL}, |
1359
|
|
|
|
|
|
{"version::boolean", XS_version_boolean, NULL}, |
1360
|
|
|
|
|
|
{"version::(+", XS_version_noop, NULL}, |
1361
|
|
|
|
|
|
{"version::(-", XS_version_noop, NULL}, |
1362
|
|
|
|
|
|
{"version::(*", XS_version_noop, NULL}, |
1363
|
|
|
|
|
|
{"version::(/", XS_version_noop, NULL}, |
1364
|
|
|
|
|
|
{"version::(+=", XS_version_noop, NULL}, |
1365
|
|
|
|
|
|
{"version::(-=", XS_version_noop, NULL}, |
1366
|
|
|
|
|
|
{"version::(*=", XS_version_noop, NULL}, |
1367
|
|
|
|
|
|
{"version::(/=", XS_version_noop, NULL}, |
1368
|
|
|
|
|
|
{"version::(abs", XS_version_noop, NULL}, |
1369
|
|
|
|
|
|
{"version::(nomethod", XS_version_noop, NULL}, |
1370
|
|
|
|
|
|
{"version::noop", XS_version_noop, NULL}, |
1371
|
|
|
|
|
|
{"version::is_alpha", XS_version_is_alpha, NULL}, |
1372
|
|
|
|
|
|
{"version::qv", XS_version_qv, NULL}, |
1373
|
|
|
|
|
|
{"version::declare", XS_version_qv, NULL}, |
1374
|
|
|
|
|
|
{"version::is_qv", XS_version_is_qv, NULL}, |
1375
|
|
|
|
|
|
{"utf8::is_utf8", XS_utf8_is_utf8, NULL}, |
1376
|
|
|
|
|
|
{"utf8::valid", XS_utf8_valid, NULL}, |
1377
|
|
|
|
|
|
{"utf8::encode", XS_utf8_encode, NULL}, |
1378
|
|
|
|
|
|
{"utf8::decode", XS_utf8_decode, NULL}, |
1379
|
|
|
|
|
|
{"utf8::upgrade", XS_utf8_upgrade, NULL}, |
1380
|
|
|
|
|
|
{"utf8::downgrade", XS_utf8_downgrade, NULL}, |
1381
|
|
|
|
|
|
{"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL}, |
1382
|
|
|
|
|
|
{"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL}, |
1383
|
|
|
|
|
|
{"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"}, |
1384
|
|
|
|
|
|
{"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"}, |
1385
|
|
|
|
|
|
{"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"}, |
1386
|
|
|
|
|
|
{"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"}, |
1387
|
|
|
|
|
|
{"re::is_regexp", XS_re_is_regexp, "$"}, |
1388
|
|
|
|
|
|
{"re::regname", XS_re_regname, ";$$"}, |
1389
|
|
|
|
|
|
{"re::regnames", XS_re_regnames, ";$"}, |
1390
|
|
|
|
|
|
{"re::regnames_count", XS_re_regnames_count, ""}, |
1391
|
|
|
|
|
|
{"re::regexp_pattern", XS_re_regexp_pattern, "$"}, |
1392
|
|
|
|
|
|
}; |
1393
|
|
|
|
|
|
|
1394
|
|
|
|
|
|
void |
1395
|
24228
|
|
|
|
|
Perl_boot_core_UNIVERSAL(pTHX) |
1396
|
|
|
|
|
|
{ |
1397
|
|
|
|
|
|
dVAR; |
1398
|
|
|
|
|
|
static const char file[] = __FILE__; |
1399
|
|
|
|
|
|
const struct xsub_details *xsub = details; |
1400
|
|
|
|
|
|
const struct xsub_details *end |
1401
|
|
|
|
|
|
= details + sizeof(details) / sizeof(details[0]); |
1402
|
|
|
|
|
|
|
1403
|
|
|
|
|
|
do { |
1404
|
1187172
|
|
|
|
|
newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0); |
1405
|
1187172
|
100
|
|
|
|
} while (++xsub < end); |
1406
|
|
|
|
|
|
|
1407
|
|
|
|
|
|
/* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */ |
1408
|
|
|
|
|
|
{ |
1409
|
24228
|
|
|
|
|
CV * const cv = |
1410
|
24228
|
|
|
|
|
newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL); |
1411
|
24228
|
|
|
|
|
Safefree(CvFILE(cv)); |
1412
|
24228
|
|
|
|
|
CvFILE(cv) = (char *)file; |
1413
|
24228
|
|
|
|
|
CvDYNFILE_off(cv); |
1414
|
|
|
|
|
|
} |
1415
|
24323
|
|
|
|
|
} |
1416
|
|
|
|
|
|
|
1417
|
|
|
|
|
|
/* |
1418
|
|
|
|
|
|
* Local variables: |
1419
|
|
|
|
|
|
* c-indentation-style: bsd |
1420
|
|
|
|
|
|
* c-basic-offset: 4 |
1421
|
|
|
|
|
|
* indent-tabs-mode: nil |
1422
|
|
|
|
|
|
* End: |
1423
|
|
|
|
|
|
* |
1424
|
|
|
|
|
|
* ex: set ts=8 sts=4 sw=4 et: |
1425
|
|
|
|
|
|
*/ |