line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
#define PERL_NO_GET_CONTEXT |
2
|
|
|
|
|
|
|
3
|
|
|
|
|
|
#include "EXTERN.h" |
4
|
|
|
|
|
|
#include "perl.h" |
5
|
|
|
|
|
|
#include "XSUB.h" |
6
|
|
|
|
|
|
|
7
|
|
|
|
|
|
static AV* |
8
|
|
|
|
|
|
S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level); |
9
|
|
|
|
|
|
|
10
|
|
|
|
|
|
static const struct mro_alg c3_alg = |
11
|
|
|
|
|
|
{S_mro_get_linear_isa_c3, "c3", 2, 0, 0}; |
12
|
|
|
|
|
|
|
13
|
|
|
|
|
|
/* |
14
|
|
|
|
|
|
=for apidoc mro_get_linear_isa_c3 |
15
|
|
|
|
|
|
|
16
|
|
|
|
|
|
Returns the C3 linearization of @ISA |
17
|
|
|
|
|
|
the given stash. The return value is a read-only AV*. |
18
|
|
|
|
|
|
C should be 0 (it is used internally in this |
19
|
|
|
|
|
|
function's recursion). |
20
|
|
|
|
|
|
|
21
|
8624
|
|
|
|
|
You are responsible for C on the |
22
|
|
|
|
|
|
return value if you plan to store it anywhere |
23
|
|
|
|
|
|
semi-permanently (otherwise it might be deleted |
24
|
|
|
|
|
|
out from under you the next time the cache is |
25
|
|
|
|
|
|
invalidated). |
26
|
|
|
|
|
|
|
27
|
|
|
|
|
|
=cut |
28
|
|
|
|
|
|
*/ |
29
|
|
|
|
|
|
|
30
|
|
|
|
|
|
static AV* |
31
|
|
|
|
|
|
S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) |
32
|
8624
|
|
|
|
|
{ |
33
|
8624
|
|
|
|
|
AV* retval; |
34
|
8624
|
|
|
|
|
GV** gvp; |
35
|
0
|
|
|
|
|
GV* gv; |
36
|
|
|
|
|
|
AV* isa; |
37
|
8624
|
|
|
|
|
const HEK* stashhek; |
38
|
32
|
|
|
|
|
struct mro_meta* meta; |
39
|
32
|
|
|
|
|
|
40
|
|
|
|
|
|
assert(HvAUX(stash)); |
41
|
8592
|
|
|
|
|
|
42
|
|
|
|
|
|
stashhek = HvENAME_HEK(stash); |
43
|
|
|
|
|
|
if (!stashhek) stashhek = HvNAME_HEK(stash); |
44
|
8592
|
|
|
|
|
if (!stashhek) |
45
|
|
|
|
|
|
Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); |
46
|
|
|
|
|
|
|
47
|
|
|
|
|
|
if (level > 100) |
48
|
|
|
|
|
|
Perl_croak(aTHX_ "Recursive inheritance detected in package '%"SVf"'", |
49
|
|
|
|
|
|
SVfARG(sv_2mortal(newSVhek(stashhek)))); |
50
|
4542
|
|
|
|
|
|
51
|
4542
|
|
|
|
|
meta = HvMROMETA(stash); |
52
|
|
|
|
|
|
|
53
|
|
|
|
|
|
/* return cache if valid */ |
54
|
|
|
|
|
|
if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &c3_alg)))) { |
55
|
|
|
|
|
|
return retval; |
56
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
58
|
|
|
|
|
|
/* not in cache, make a new one */ |
59
|
5002
|
|
|
|
|
|
60
|
|
|
|
|
|
gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); |
61
|
|
|
|
|
|
isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL; |
62
|
|
|
|
|
|
|
63
|
4126
|
|
|
|
|
/* For a better idea how the rest of this works, see the much clearer |
64
|
|
|
|
|
|
pure perl version in Algorithm::C3 0.01: |
65
|
|
|
|
|
|
http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm |
66
|
|
|
|
|
|
(later versions go about it differently than this code for speed reasons) |
67
|
|
|
|
|
|
*/ |
68
|
|
|
|
|
|
|
69
|
|
|
|
|
|
if(isa && AvFILLp(isa) >= 0) { |
70
|
4126
|
|
|
|
|
SV** seqs_ptr; |
71
|
4126
|
|
|
|
|
I32 seqs_items; |
72
|
10642
|
|
|
|
|
HV *tails; |
73
|
6052
|
|
|
|
|
AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV()))); |
74
|
6052
|
|
|
|
|
I32* heads; |
75
|
6052
|
|
|
|
|
|
76
|
|
|
|
|
|
/* This builds @seqs, which is an array of arrays. |
77
|
|
|
|
|
|
The members of @seqs are the MROs of |
78
|
8
|
|
|
|
|
the members of @ISA, followed by @ISA itself. |
79
|
8
|
|
|
|
|
*/ |
80
|
8
|
|
|
|
|
SSize_t items = AvFILLp(isa) + 1; |
81
|
|
|
|
|
|
SV** isa_ptr = AvARRAY(isa); |
82
|
|
|
|
|
|
while(items--) { |
83
|
|
|
|
|
|
SV* const isa_item = *isa_ptr++; |
84
|
6044
|
|
|
|
|
HV* const isa_item_stash = gv_stashsv(isa_item, 0); |
85
|
6044
|
|
|
|
|
if(!isa_item_stash) { |
86
|
|
|
|
|
|
/* if no stash, make a temporary fake MRO |
87
|
2812
|
|
|
|
|
containing just itself */ |
88
|
|
|
|
|
|
AV* const isa_lin = newAV(); |
89
|
|
|
|
|
|
av_push(isa_lin, newSVsv(isa_item)); |
90
|
|
|
|
|
|
av_push(seqs, MUTABLE_SV(isa_lin)); |
91
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
else { |
93
|
430
|
|
|
|
|
/* recursion */ |
94
|
430
|
|
|
|
|
AV* const isa_lin |
95
|
|
|
|
|
|
= S_mro_get_linear_isa_c3(aTHX_ isa_item_stash, level + 1); |
96
|
|
|
|
|
|
|
97
|
|
|
|
|
|
if(items == 0 && AvFILLp(seqs) == -1) { |
98
|
|
|
|
|
|
/* Only one parent class. For this case, the C3 |
99
|
|
|
|
|
|
linearisation is this class followed by the parent's |
100
|
|
|
|
|
|
linearisation, so don't bother with the expensive |
101
|
430
|
|
|
|
|
calculation. */ |
102
|
430
|
|
|
|
|
SV **svp; |
103
|
430
|
|
|
|
|
I32 subrv_items = AvFILLp(isa_lin) + 1; |
104
|
|
|
|
|
|
SV *const *subrv_p = AvARRAY(isa_lin); |
105
|
|
|
|
|
|
|
106
|
|
|
|
|
|
/* Hijack the allocated but unused array seqs to be the |
107
|
|
|
|
|
|
return value. It's currently mortalised. */ |
108
|
430
|
|
|
|
|
|
109
|
|
|
|
|
|
retval = seqs; |
110
|
2250
|
|
|
|
|
|
111
|
|
|
|
|
|
av_extend(retval, subrv_items); |
112
|
|
|
|
|
|
AvFILLp(retval) = subrv_items; |
113
|
|
|
|
|
|
svp = AvARRAY(retval); |
114
|
|
|
|
|
|
|
115
|
|
|
|
|
|
/* First entry is this class. We happen to make a shared |
116
|
1390
|
|
|
|
|
hash key scalar because it's the cheapest and fastest |
117
|
1390
|
|
|
|
|
way to do it. */ |
118
|
|
|
|
|
|
*svp++ = newSVhek(stashhek); |
119
|
|
|
|
|
|
|
120
|
|
|
|
|
|
while(subrv_items--) { |
121
|
|
|
|
|
|
/* These values are unlikely to be shared hash key |
122
|
|
|
|
|
|
scalars, so no point in adding code to optimising |
123
|
|
|
|
|
|
for a case that is unlikely to be true. |
124
|
2382
|
|
|
|
|
(Or prove me wrong and do it.) */ |
125
|
|
|
|
|
|
|
126
|
|
|
|
|
|
SV *const val = *subrv_p++; |
127
|
464
|
|
|
|
|
*svp++ = newSVsv(val); |
128
|
464
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
130
|
|
|
|
|
|
SvREFCNT_inc(retval); |
131
|
|
|
|
|
|
|
132
|
|
|
|
|
|
goto done; |
133
|
928
|
|
|
|
|
} |
134
|
|
|
|
|
|
av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin))); |
135
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa))); |
138
|
|
|
|
|
|
tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); |
139
|
|
|
|
|
|
|
140
|
464
|
|
|
|
|
/* This builds "heads", which as an array of integer array |
141
|
464
|
|
|
|
|
indices, one per seq, which point at the virtual "head" |
142
|
3116
|
|
|
|
|
of the seq (initially zero) */ |
143
|
2188
|
|
|
|
|
Newxz(heads, AvFILLp(seqs)+1, I32); |
144
|
2188
|
|
|
|
|
|
145
|
2188
|
|
|
|
|
/* This builds %tails, which has one key for every class |
146
|
1412
|
|
|
|
|
mentioned in the tail of any sequence in @seqs (tail meaning |
147
|
8100
|
|
|
|
|
everything after the first class, the "head"). The value |
148
|
5276
|
|
|
|
|
is how many times this key appears in the tails of @seqs. |
149
|
|
|
|
|
|
*/ |
150
|
|
|
|
|
|
seqs_ptr = AvARRAY(seqs); |
151
|
5276
|
|
|
|
|
seqs_items = AvFILLp(seqs) + 1; |
152
|
5276
|
|
|
|
|
while(seqs_items--) { |
153
|
5276
|
|
|
|
|
AV *const seq = MUTABLE_AV(*seqs_ptr++); |
154
|
|
|
|
|
|
I32 seq_items = AvFILLp(seq); |
155
|
|
|
|
|
|
if(seq_items > 0) { |
156
|
|
|
|
|
|
SV** seq_ptr = AvARRAY(seq) + 1; |
157
|
|
|
|
|
|
while(seq_items--) { |
158
|
5276
|
|
|
|
|
SV* const seqitem = *seq_ptr++; |
159
|
1904
|
|
|
|
|
/* LVALUE fetch will create a new undefined SV if necessary |
160
|
|
|
|
|
|
*/ |
161
|
3372
|
|
|
|
|
HE* const he = hv_fetch_ent(tails, seqitem, 1, 0); |
162
|
|
|
|
|
|
if(he) { |
163
|
|
|
|
|
|
SV* const val = HeVAL(he); |
164
|
|
|
|
|
|
/* For 5.8.0 and later, sv_inc() with increment undef to |
165
|
|
|
|
|
|
an IV of 1, which is what we want for a newly created |
166
|
|
|
|
|
|
entry. However, for 5.6.x it will become an NV of |
167
|
|
|
|
|
|
1.0, which confuses the SvIVX() checks above. */ |
168
|
|
|
|
|
|
if(SvIOK(val)) { |
169
|
464
|
|
|
|
|
SvIV_set(val, SvIVX(val) + 1); |
170
|
464
|
|
|
|
|
} else { |
171
|
|
|
|
|
|
sv_setiv(val, 1); |
172
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
178
|
|
|
|
|
|
/* Initialize retval to build the return value in */ |
179
|
|
|
|
|
|
retval = newAV(); |
180
|
4292
|
|
|
|
|
av_push(retval, newSVhek(stashhek)); /* us first */ |
181
|
30180
|
|
|
|
|
|
182
|
|
|
|
|
|
/* This loop won't terminate until we either finish building |
183
|
25888
|
|
|
|
|
the MRO, or get an exception. */ |
184
|
|
|
|
|
|
while(1) { |
185
|
25888
|
|
|
|
|
SV* cand = NULL; |
186
|
18744
|
|
|
|
|
SV* winner = NULL; |
187
|
18744
|
|
|
|
|
int s; |
188
|
18744
|
|
|
|
|
|
189
|
|
|
|
|
|
/* "foreach $seq (@seqs)" */ |
190
|
|
|
|
|
|
SV** const avptr = AvARRAY(seqs); |
191
|
|
|
|
|
|
for(s = 0; s <= AvFILLp(seqs); s++) { |
192
|
|
|
|
|
|
SV** svp; |
193
|
|
|
|
|
|
AV * const seq = MUTABLE_AV(avptr[s]); |
194
|
|
|
|
|
|
SV* seqhead; |
195
|
|
|
|
|
|
if(!seq) continue; /* skip empty seqs */ |
196
|
|
|
|
|
|
svp = av_fetch(seq, heads[s], 0); |
197
|
5992
|
|
|
|
|
seqhead = *svp; /* seqhead = head of this seq */ |
198
|
5528
|
|
|
|
|
if(!winner) { |
199
|
5528
|
|
|
|
|
HE* tail_entry; |
200
|
2164
|
|
|
|
|
SV* val; |
201
|
3828
|
|
|
|
|
/* if we haven't found a winner for this round yet, |
202
|
3828
|
|
|
|
|
and this seqhead is not in tails (or the count |
203
|
|
|
|
|
|
for it in tails has dropped to zero), then this |
204
|
|
|
|
|
|
seqhead is our new winner, and is added to the |
205
|
|
|
|
|
|
final MRO immediately */ |
206
|
16580
|
|
|
|
|
cand = seqhead; |
207
|
|
|
|
|
|
if((tail_entry = hv_fetch_ent(tails, cand, 0, 0)) |
208
|
|
|
|
|
|
&& (val = HeVAL(tail_entry)) |
209
|
|
|
|
|
|
&& (SvIVX(val) > 0)) |
210
|
|
|
|
|
|
continue; |
211
|
|
|
|
|
|
winner = newSVsv(cand); |
212
|
|
|
|
|
|
av_push(retval, winner); |
213
|
7448
|
|
|
|
|
/* note however that even when we find a winner, |
214
|
7448
|
|
|
|
|
we continue looping over @seqs to do housekeeping */ |
215
|
2180
|
|
|
|
|
} |
216
|
2180
|
|
|
|
|
if(!sv_cmp(seqhead, winner)) { |
217
|
|
|
|
|
|
/* Once we have a winner (including the iteration |
218
|
|
|
|
|
|
where we first found him), inc the head ptr |
219
|
|
|
|
|
|
for any seq which had the winner as a head, |
220
|
|
|
|
|
|
NULL out any seq which is now empty, |
221
|
|
|
|
|
|
and adjust tails for consistency */ |
222
|
|
|
|
|
|
|
223
|
|
|
|
|
|
const int new_head = ++heads[s]; |
224
|
5268
|
|
|
|
|
if(new_head > AvFILLp(seq)) { |
225
|
5268
|
|
|
|
|
SvREFCNT_dec(avptr[s]); |
226
|
5268
|
|
|
|
|
avptr[s] = NULL; |
227
|
5268
|
|
|
|
|
} |
228
|
5268
|
|
|
|
|
else { |
229
|
|
|
|
|
|
HE* tail_entry; |
230
|
|
|
|
|
|
SV* val; |
231
|
|
|
|
|
|
/* Because we know this new seqhead used to be |
232
|
|
|
|
|
|
a tail, we can assume it is in tails and has |
233
|
|
|
|
|
|
a positive value, which we need to dec */ |
234
|
|
|
|
|
|
svp = av_fetch(seq, new_head, 0); |
235
|
4292
|
|
|
|
|
seqhead = *svp; |
236
|
460
|
|
|
|
|
tail_entry = hv_fetch_ent(tails, seqhead, 0, 0); |
237
|
|
|
|
|
|
val = HeVAL(tail_entry); |
238
|
|
|
|
|
|
sv_dec(val); |
239
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
} |
242
|
3832
|
|
|
|
|
|
243
|
|
|
|
|
|
/* if we found no candidates, we are done building the MRO. |
244
|
|
|
|
|
|
!cand means no seqs have any entries left to check */ |
245
|
|
|
|
|
|
if(!cand) { |
246
|
4
|
|
|
|
|
Safefree(heads); |
247
|
|
|
|
|
|
break; |
248
|
|
|
|
|
|
} |
249
|
4
|
|
|
|
|
|
250
|
16
|
|
|
|
|
/* If we had candidates, but nobody won, then the @ISA |
251
|
12
|
|
|
|
|
hierarchy is not C3-incompatible */ |
252
|
12
|
|
|
|
|
if(!winner) { |
253
|
|
|
|
|
|
SV *errmsg; |
254
|
4
|
|
|
|
|
I32 i; |
255
|
|
|
|
|
|
|
256
|
|
|
|
|
|
errmsg = newSVpvf( |
257
|
|
|
|
|
|
"Inconsistent hierarchy during C3 merge of class '%"SVf"':\n\t" |
258
|
4
|
|
|
|
|
"current merge results [\n", |
259
|
4
|
|
|
|
|
SVfARG(sv_2mortal(newSVhek(stashhek)))); |
260
|
|
|
|
|
|
for (i = 0; i <= av_len(retval); i++) { |
261
|
4
|
|
|
|
|
SV **elem = av_fetch(retval, i, 0); |
262
|
|
|
|
|
|
sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem)); |
263
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand)); |
265
|
|
|
|
|
|
|
266
|
|
|
|
|
|
/* we have to do some cleanup before we croak */ |
267
|
416
|
|
|
|
|
|
268
|
416
|
|
|
|
|
SvREFCNT_dec(retval); |
269
|
|
|
|
|
|
Safefree(heads); |
270
|
|
|
|
|
|
|
271
|
|
|
|
|
|
Perl_croak(aTHX_ "%"SVf, SVfARG(errmsg)); |
272
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
} |
274
|
1306
|
|
|
|
|
} |
275
|
|
|
|
|
|
else { /* @ISA was undefined or empty */ |
276
|
1306
|
|
|
|
|
/* build a retval containing only ourselves */ |
277
|
|
|
|
|
|
retval = newAV(); |
278
|
|
|
|
|
|
av_push(retval, newSVhek(stashhek)); |
279
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
281
|
|
|
|
|
|
done: |
282
|
|
|
|
|
|
/* we don't want anyone modifying the cache entry but us, |
283
|
|
|
|
|
|
and we do so by replacing it completely */ |
284
|
|
|
|
|
|
SvREADONLY_on(retval); |
285
|
|
|
|
|
|
|
286
|
|
|
|
|
|
return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg, |
287
|
|
|
|
|
|
MUTABLE_SV(retval))); |
288
|
|
|
|
|
|
} |
289
|
144
|
|
|
|
|
|
290
|
536
|
|
|
|
|
|
291
|
|
|
|
|
|
/* These two are static helpers for next::method and friends, |
292
|
|
|
|
|
|
and re-implement a bunch of the code from pp_caller() in |
293
|
|
|
|
|
|
a more efficient manner for this particular usage. |
294
|
|
|
|
|
|
*/ |
295
|
|
|
|
|
|
|
296
|
|
|
|
|
|
static I32 |
297
|
|
|
|
|
|
__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) { |
298
|
|
|
|
|
|
I32 i; |
299
|
|
|
|
|
|
for (i = startingblock; i >= 0; i--) { |
300
|
|
|
|
|
|
if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i; |
301
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
return i; |
303
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
305
|
|
|
|
|
|
MODULE = mro PACKAGE = mro PREFIX = mro_ |
306
|
|
|
|
|
|
|
307
|
|
|
|
|
|
void |
308
|
|
|
|
|
|
mro_get_linear_isa(...) |
309
|
|
|
|
|
|
PROTOTYPE: $;$ |
310
|
|
|
|
|
|
PREINIT: |
311
|
|
|
|
|
|
AV* RETVAL; |
312
|
|
|
|
|
|
HV* class_stash; |
313
|
|
|
|
|
|
SV* classname; |
314
|
|
|
|
|
|
PPCODE: |
315
|
2450
|
|
|
|
|
if(items < 1 || items > 2) |
316
|
0
|
|
|
|
|
croak_xs_usage(cv, "classname [, type ]"); |
317
|
|
|
|
|
|
|
318
|
2450
|
|
|
|
|
classname = ST(0); |
319
|
2450
|
|
|
|
|
class_stash = gv_stashsv(classname, 0); |
320
|
|
|
|
|
|
|
321
|
2450
|
|
|
|
|
if(!class_stash) { |
322
|
|
|
|
|
|
/* No stash exists yet, give them just the classname */ |
323
|
4
|
|
|
|
|
AV* isalin = newAV(); |
324
|
4
|
|
|
|
|
av_push(isalin, newSVsv(classname)); |
325
|
4
|
|
|
|
|
ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin))); |
326
|
4
|
|
|
|
|
XSRETURN(1); |
327
|
|
|
|
|
|
} |
328
|
2446
|
|
|
|
|
else if(items > 1) { |
329
|
28
|
|
|
|
|
const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1)); |
330
|
28
|
|
|
|
|
if (!algo) |
331
|
8
|
|
|
|
|
Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1)); |
332
|
20
|
|
|
|
|
RETVAL = algo->resolve(aTHX_ class_stash, 0); |
333
|
|
|
|
|
|
} |
334
|
|
|
|
|
|
else { |
335
|
2418
|
|
|
|
|
RETVAL = mro_get_linear_isa(class_stash); |
336
|
|
|
|
|
|
} |
337
|
2434
|
|
|
|
|
ST(0) = newRV_inc(MUTABLE_SV(RETVAL)); |
338
|
2434
|
|
|
|
|
sv_2mortal(ST(0)); |
339
|
2434
|
|
|
|
|
XSRETURN(1); |
340
|
|
|
|
|
|
|
341
|
|
|
|
|
|
void |
342
|
|
|
|
|
|
mro_set_mro(...) |
343
|
|
|
|
|
|
PROTOTYPE: $$ |
344
|
|
|
|
|
|
PREINIT: |
345
|
|
|
|
|
|
SV* classname; |
346
|
|
|
|
|
|
HV* class_stash; |
347
|
|
|
|
|
|
struct mro_meta* meta; |
348
|
|
|
|
|
|
PPCODE: |
349
|
696
|
|
|
|
|
if (items != 2) |
350
|
0
|
|
|
|
|
croak_xs_usage(cv, "classname, type"); |
351
|
|
|
|
|
|
|
352
|
696
|
|
|
|
|
classname = ST(0); |
353
|
696
|
|
|
|
|
class_stash = gv_stashsv(classname, GV_ADD); |
354
|
696
|
|
|
|
|
if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname)); |
355
|
696
|
|
|
|
|
meta = HvMROMETA(class_stash); |
356
|
|
|
|
|
|
|
357
|
696
|
|
|
|
|
Perl_mro_set_mro(aTHX_ meta, ST(1)); |
358
|
|
|
|
|
|
|
359
|
696
|
|
|
|
|
XSRETURN_EMPTY; |
360
|
|
|
|
|
|
|
361
|
|
|
|
|
|
void |
362
|
|
|
|
|
|
mro_get_mro(...) |
363
|
|
|
|
|
|
PROTOTYPE: $ |
364
|
|
|
|
|
|
PREINIT: |
365
|
|
|
|
|
|
SV* classname; |
366
|
|
|
|
|
|
HV* class_stash; |
367
|
|
|
|
|
|
PPCODE: |
368
|
12
|
|
|
|
|
if (items != 1) |
369
|
0
|
|
|
|
|
croak_xs_usage(cv, "classname"); |
370
|
|
|
|
|
|
|
371
|
12
|
|
|
|
|
classname = ST(0); |
372
|
12
|
|
|
|
|
class_stash = gv_stashsv(classname, 0); |
373
|
|
|
|
|
|
|
374
|
12
|
|
|
|
|
if (class_stash) { |
375
|
8
|
|
|
|
|
const struct mro_alg *const meta = HvMROMETA(class_stash)->mro_which; |
376
|
8
|
|
|
|
|
ST(0) = newSVpvn_flags(meta->name, meta->length, |
377
|
|
|
|
|
|
SVs_TEMP |
378
|
|
|
|
|
|
| ((meta->kflags & HVhek_UTF8) ? SVf_UTF8 : 0)); |
379
|
|
|
|
|
|
} else { |
380
|
4
|
|
|
|
|
ST(0) = newSVpvn_flags("dfs", 3, SVs_TEMP); |
381
|
|
|
|
|
|
} |
382
|
12
|
|
|
|
|
XSRETURN(1); |
383
|
|
|
|
|
|
|
384
|
|
|
|
|
|
void |
385
|
|
|
|
|
|
mro_get_isarev(...) |
386
|
|
|
|
|
|
PROTOTYPE: $ |
387
|
|
|
|
|
|
PREINIT: |
388
|
|
|
|
|
|
SV* classname; |
389
|
|
|
|
|
|
HE* he; |
390
|
|
|
|
|
|
HV* isarev; |
391
|
|
|
|
|
|
AV* ret_array; |
392
|
|
|
|
|
|
PPCODE: |
393
|
94
|
|
|
|
|
if (items != 1) |
394
|
0
|
|
|
|
|
croak_xs_usage(cv, "classname"); |
395
|
|
|
|
|
|
|
396
|
94
|
|
|
|
|
classname = ST(0); |
397
|
|
|
|
|
|
|
398
|
94
|
|
|
|
|
he = hv_fetch_ent(PL_isarev, classname, 0, 0); |
399
|
94
|
|
|
|
|
isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL; |
400
|
|
|
|
|
|
|
401
|
94
|
|
|
|
|
ret_array = newAV(); |
402
|
94
|
|
|
|
|
if(isarev) { |
403
|
|
|
|
|
|
HE* iter; |
404
|
70
|
|
|
|
|
hv_iterinit(isarev); |
405
|
266
|
|
|
|
|
while((iter = hv_iternext(isarev))) |
406
|
126
|
|
|
|
|
av_push(ret_array, newSVsv(hv_iterkeysv(iter))); |
407
|
|
|
|
|
|
} |
408
|
94
|
|
|
|
|
mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array))); |
409
|
|
|
|
|
|
|
410
|
94
|
|
|
|
|
PUTBACK; |
411
|
|
|
|
|
|
|
412
|
|
|
|
|
|
void |
413
|
|
|
|
|
|
mro_is_universal(...) |
414
|
|
|
|
|
|
PROTOTYPE: $ |
415
|
|
|
|
|
|
PREINIT: |
416
|
|
|
|
|
|
SV* classname; |
417
|
|
|
|
|
|
HV* isarev; |
418
|
|
|
|
|
|
char* classname_pv; |
419
|
|
|
|
|
|
STRLEN classname_len; |
420
|
|
|
|
|
|
HE* he; |
421
|
|
|
|
|
|
PPCODE: |
422
|
18
|
|
|
|
|
if (items != 1) |
423
|
0
|
|
|
|
|
croak_xs_usage(cv, "classname"); |
424
|
|
|
|
|
|
|
425
|
18
|
|
|
|
|
classname = ST(0); |
426
|
|
|
|
|
|
|
427
|
18
|
|
|
|
|
classname_pv = SvPV(classname,classname_len); |
428
|
|
|
|
|
|
|
429
|
18
|
|
|
|
|
he = hv_fetch_ent(PL_isarev, classname, 0, 0); |
430
|
18
|
|
|
|
|
isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL; |
431
|
|
|
|
|
|
|
432
|
18
|
|
|
|
|
if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL")) |
433
|
18
|
|
|
|
|
|| (isarev && hv_exists(isarev, "UNIVERSAL", 9))) |
434
|
4
|
|
|
|
|
XSRETURN_YES; |
435
|
|
|
|
|
|
else |
436
|
14
|
|
|
|
|
XSRETURN_NO; |
437
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
439
|
|
|
|
|
|
void |
440
|
|
|
|
|
|
mro_invalidate_all_method_caches(...) |
441
|
|
|
|
|
|
PROTOTYPE: |
442
|
|
|
|
|
|
PPCODE: |
443
|
4
|
|
|
|
|
if (items != 0) |
444
|
0
|
|
|
|
|
croak_xs_usage(cv, ""); |
445
|
|
|
|
|
|
|
446
|
4
|
|
|
|
|
PL_sub_generation++; |
447
|
|
|
|
|
|
|
448
|
4
|
|
|
|
|
XSRETURN_EMPTY; |
449
|
|
|
|
|
|
|
450
|
|
|
|
|
|
void |
451
|
|
|
|
|
|
mro_get_pkg_gen(...) |
452
|
|
|
|
|
|
PROTOTYPE: $ |
453
|
|
|
|
|
|
PREINIT: |
454
|
|
|
|
|
|
SV* classname; |
455
|
|
|
|
|
|
HV* class_stash; |
456
|
|
|
|
|
|
PPCODE: |
457
|
32
|
|
|
|
|
if(items != 1) |
458
|
0
|
|
|
|
|
croak_xs_usage(cv, "classname"); |
459
|
|
|
|
|
|
|
460
|
32
|
|
|
|
|
classname = ST(0); |
461
|
|
|
|
|
|
|
462
|
32
|
|
|
|
|
class_stash = gv_stashsv(classname, 0); |
463
|
|
|
|
|
|
|
464
|
32
|
|
|
|
|
mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0); |
465
|
|
|
|
|
|
|
466
|
32
|
|
|
|
|
PUTBACK; |
467
|
|
|
|
|
|
|
468
|
|
|
|
|
|
void |
469
|
|
|
|
|
|
mro__nextcan(...) |
470
|
|
|
|
|
|
PREINIT: |
471
|
116
|
|
|
|
|
SV* self = ST(0); |
472
|
116
|
|
|
|
|
const I32 throw_nomethod = SvIVX(ST(1)); |
473
|
116
|
|
|
|
|
I32 cxix = cxstack_ix; |
474
|
116
|
|
|
|
|
const PERL_CONTEXT *ccstack = cxstack; |
475
|
116
|
|
|
|
|
const PERL_SI *top_si = PL_curstackinfo; |
476
|
|
|
|
|
|
HV* selfstash; |
477
|
|
|
|
|
|
SV *stashname; |
478
|
|
|
|
|
|
const char *fq_subname; |
479
|
|
|
|
|
|
const char *subname; |
480
|
|
|
|
|
|
bool subname_utf8 = 0; |
481
|
|
|
|
|
|
STRLEN stashname_len; |
482
|
|
|
|
|
|
STRLEN subname_len; |
483
|
|
|
|
|
|
SV* sv; |
484
|
|
|
|
|
|
GV** gvp; |
485
|
|
|
|
|
|
AV* linear_av; |
486
|
|
|
|
|
|
SV** linear_svp; |
487
|
|
|
|
|
|
const char *hvname; |
488
|
|
|
|
|
|
I32 entries; |
489
|
|
|
|
|
|
struct mro_meta* selfmeta; |
490
|
|
|
|
|
|
HV* nmcache; |
491
|
|
|
|
|
|
I32 i; |
492
|
|
|
|
|
|
PPCODE: |
493
|
|
|
|
|
|
PERL_UNUSED_ARG(cv); |
494
|
|
|
|
|
|
|
495
|
116
|
|
|
|
|
if(sv_isobject(self)) |
496
|
4
|
|
|
|
|
selfstash = SvSTASH(SvRV(self)); |
497
|
|
|
|
|
|
else |
498
|
112
|
|
|
|
|
selfstash = gv_stashsv(self, GV_ADD); |
499
|
|
|
|
|
|
|
500
|
|
|
|
|
|
assert(selfstash); |
501
|
|
|
|
|
|
|
502
|
116
|
|
|
|
|
hvname = HvNAME_get(selfstash); |
503
|
116
|
|
|
|
|
if (!hvname) |
504
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); |
505
|
|
|
|
|
|
|
506
|
|
|
|
|
|
/* This block finds the contextually-enclosing fully-qualified subname, |
507
|
|
|
|
|
|
much like looking at (caller($i))[3] until you find a real sub that |
508
|
|
|
|
|
|
isn't ANON, etc (also skips over pureperl next::method, etc) */ |
509
|
228
|
|
|
|
|
for(i = 0; i < 2; i++) { |
510
|
|
|
|
|
|
cxix = __dopoptosub_at(ccstack, cxix); |
511
|
|
|
|
|
|
for (;;) { |
512
|
|
|
|
|
|
GV* cvgv; |
513
|
|
|
|
|
|
STRLEN fq_subname_len; |
514
|
|
|
|
|
|
|
515
|
|
|
|
|
|
/* we may be in a higher stacklevel, so dig down deeper */ |
516
|
248
|
|
|
|
|
while (cxix < 0) { |
517
|
4
|
|
|
|
|
if(top_si->si_type == PERLSI_MAIN) |
518
|
4
|
|
|
|
|
Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context"); |
519
|
0
|
|
|
|
|
top_si = top_si->si_prev; |
520
|
0
|
|
|
|
|
ccstack = top_si->si_cxstack; |
521
|
0
|
|
|
|
|
cxix = __dopoptosub_at(ccstack, top_si->si_cxix); |
522
|
|
|
|
|
|
} |
523
|
|
|
|
|
|
|
524
|
244
|
|
|
|
|
if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB |
525
|
244
|
|
|
|
|
|| (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) { |
526
|
0
|
|
|
|
|
cxix = __dopoptosub_at(ccstack, cxix - 1); |
527
|
0
|
|
|
|
|
continue; |
528
|
|
|
|
|
|
} |
529
|
|
|
|
|
|
|
530
|
|
|
|
|
|
{ |
531
|
244
|
|
|
|
|
const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1); |
532
|
244
|
|
|
|
|
if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) { |
533
|
0
|
|
|
|
|
if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) { |
534
|
|
|
|
|
|
cxix = dbcxix; |
535
|
0
|
|
|
|
|
continue; |
536
|
|
|
|
|
|
} |
537
|
|
|
|
|
|
} |
538
|
|
|
|
|
|
} |
539
|
|
|
|
|
|
|
540
|
244
|
|
|
|
|
cvgv = CvGV(ccstack[cxix].blk_sub.cv); |
541
|
|
|
|
|
|
|
542
|
244
|
|
|
|
|
if(!isGV(cvgv)) { |
543
|
0
|
|
|
|
|
cxix = __dopoptosub_at(ccstack, cxix - 1); |
544
|
0
|
|
|
|
|
continue; |
545
|
|
|
|
|
|
} |
546
|
|
|
|
|
|
|
547
|
|
|
|
|
|
/* we found a real sub here */ |
548
|
244
|
|
|
|
|
sv = sv_newmortal(); |
549
|
|
|
|
|
|
|
550
|
244
|
|
|
|
|
gv_efullname3(sv, cvgv, NULL); |
551
|
|
|
|
|
|
|
552
|
244
|
|
|
|
|
if(SvPOK(sv)) { |
553
|
244
|
|
|
|
|
fq_subname = SvPVX(sv); |
554
|
244
|
|
|
|
|
fq_subname_len = SvCUR(sv); |
555
|
|
|
|
|
|
|
556
|
244
|
|
|
|
|
subname_utf8 = SvUTF8(sv) ? 1 : 0; |
557
|
244
|
|
|
|
|
subname = strrchr(fq_subname, ':'); |
558
|
|
|
|
|
|
} else { |
559
|
|
|
|
|
|
subname = NULL; |
560
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
562
|
244
|
|
|
|
|
if(!subname) |
563
|
0
|
|
|
|
|
Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method"); |
564
|
|
|
|
|
|
|
565
|
244
|
|
|
|
|
subname++; |
566
|
244
|
|
|
|
|
subname_len = fq_subname_len - (subname - fq_subname); |
567
|
244
|
|
|
|
|
if(subname_len == 8 && strEQ(subname, "__ANON__")) { |
568
|
16
|
|
|
|
|
cxix = __dopoptosub_at(ccstack, cxix - 1); |
569
|
16
|
|
|
|
|
continue; |
570
|
|
|
|
|
|
} |
571
|
|
|
|
|
|
break; |
572
|
|
|
|
|
|
} |
573
|
228
|
|
|
|
|
cxix--; |
574
|
|
|
|
|
|
} |
575
|
|
|
|
|
|
|
576
|
|
|
|
|
|
/* If we made it to here, we found our context */ |
577
|
|
|
|
|
|
|
578
|
|
|
|
|
|
/* Initialize the next::method cache for this stash |
579
|
|
|
|
|
|
if necessary */ |
580
|
112
|
|
|
|
|
selfmeta = HvMROMETA(selfstash); |
581
|
112
|
|
|
|
|
if(!(nmcache = selfmeta->mro_nextmethod)) { |
582
|
40
|
|
|
|
|
nmcache = selfmeta->mro_nextmethod = newHV(); |
583
|
|
|
|
|
|
} |
584
|
|
|
|
|
|
else { /* Use the cached coderef if it exists */ |
585
|
72
|
|
|
|
|
HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0); |
586
|
72
|
|
|
|
|
if (cache_entry) { |
587
|
12
|
|
|
|
|
SV* const val = HeVAL(cache_entry); |
588
|
12
|
|
|
|
|
if(val == &PL_sv_undef) { |
589
|
0
|
|
|
|
|
if(throw_nomethod) |
590
|
0
|
|
|
|
|
Perl_croak(aTHX_ "No next::method '%"SVf"' found for %"SVf, |
591
|
0
|
|
|
|
|
SVfARG(newSVpvn_flags(subname, subname_len, |
592
|
|
|
|
|
|
SVs_TEMP | ( subname_utf8 ? SVf_UTF8 : 0 ) )), |
593
|
0
|
|
|
|
|
SVfARG(sv_2mortal(newSVhek( HvNAME_HEK(selfstash) )))); |
594
|
0
|
|
|
|
|
XSRETURN_EMPTY; |
595
|
|
|
|
|
|
} |
596
|
12
|
|
|
|
|
mXPUSHs(newRV_inc(val)); |
597
|
12
|
|
|
|
|
XSRETURN(1); |
598
|
|
|
|
|
|
} |
599
|
|
|
|
|
|
} |
600
|
|
|
|
|
|
|
601
|
|
|
|
|
|
/* beyond here is just for cache misses, so perf isn't as critical */ |
602
|
|
|
|
|
|
|
603
|
100
|
|
|
|
|
stashname_len = subname - fq_subname - 2; |
604
|
100
|
|
|
|
|
stashname = newSVpvn_flags(fq_subname, stashname_len, |
605
|
|
|
|
|
|
SVs_TEMP | (subname_utf8 ? SVf_UTF8 : 0)); |
606
|
|
|
|
|
|
|
607
|
|
|
|
|
|
/* has ourselves at the top of the list */ |
608
|
100
|
|
|
|
|
linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0); |
609
|
|
|
|
|
|
|
610
|
100
|
|
|
|
|
linear_svp = AvARRAY(linear_av); |
611
|
100
|
|
|
|
|
entries = AvFILLp(linear_av) + 1; |
612
|
|
|
|
|
|
|
613
|
|
|
|
|
|
/* Walk down our MRO, skipping everything up |
614
|
|
|
|
|
|
to the contextually enclosing class */ |
615
|
240
|
|
|
|
|
while (entries--) { |
616
|
136
|
|
|
|
|
SV * const linear_sv = *linear_svp++; |
617
|
|
|
|
|
|
assert(linear_sv); |
618
|
136
|
|
|
|
|
if(sv_eq(linear_sv, stashname)) |
619
|
|
|
|
|
|
break; |
620
|
|
|
|
|
|
} |
621
|
|
|
|
|
|
|
622
|
|
|
|
|
|
/* Now search the remainder of the MRO for the |
623
|
|
|
|
|
|
same method name as the contextually enclosing |
624
|
|
|
|
|
|
method */ |
625
|
100
|
|
|
|
|
if(entries > 0) { |
626
|
170
|
|
|
|
|
while (entries--) { |
627
|
154
|
|
|
|
|
SV * const linear_sv = *linear_svp++; |
628
|
|
|
|
|
|
HV* curstash; |
629
|
|
|
|
|
|
GV* candidate; |
630
|
|
|
|
|
|
CV* cand_cv; |
631
|
|
|
|
|
|
|
632
|
|
|
|
|
|
assert(linear_sv); |
633
|
154
|
|
|
|
|
curstash = gv_stashsv(linear_sv, FALSE); |
634
|
|
|
|
|
|
|
635
|
154
|
|
|
|
|
if (!curstash) { |
636
|
0
|
|
|
|
|
if (ckWARN(WARN_SYNTAX)) |
637
|
0
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%"SVf"::ISA", |
638
|
|
|
|
|
|
(void*)linear_sv, |
639
|
0
|
|
|
|
|
SVfARG(sv_2mortal(newSVhek( HvNAME_HEK(selfstash) )))); |
640
|
0
|
|
|
|
|
continue; |
641
|
|
|
|
|
|
} |
642
|
|
|
|
|
|
|
643
|
|
|
|
|
|
assert(curstash); |
644
|
|
|
|
|
|
|
645
|
154
|
|
|
|
|
gvp = (GV**)hv_fetch(curstash, subname, |
646
|
|
|
|
|
|
subname_utf8 ? -(I32)subname_len : (I32)subname_len, 0); |
647
|
154
|
|
|
|
|
if (!gvp) continue; |
648
|
|
|
|
|
|
|
649
|
80
|
|
|
|
|
candidate = *gvp; |
650
|
|
|
|
|
|
assert(candidate); |
651
|
|
|
|
|
|
|
652
|
80
|
|
|
|
|
if (SvTYPE(candidate) != SVt_PVGV) |
653
|
0
|
|
|
|
|
gv_init_pvn(candidate, curstash, subname, subname_len, |
654
|
|
|
|
|
|
GV_ADDMULTI|(subname_utf8 ? SVf_UTF8 : 0)); |
655
|
|
|
|
|
|
|
656
|
|
|
|
|
|
/* Notably, we only look for real entries, not method cache |
657
|
|
|
|
|
|
entries, because in C3 the method cache of a parent is not |
658
|
|
|
|
|
|
valid for the child */ |
659
|
80
|
|
|
|
|
if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { |
660
|
80
|
|
|
|
|
SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv)); |
661
|
80
|
|
|
|
|
(void)hv_store_ent(nmcache, sv, MUTABLE_SV(cand_cv), 0); |
662
|
80
|
|
|
|
|
mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv))); |
663
|
80
|
|
|
|
|
XSRETURN(1); |
664
|
|
|
|
|
|
} |
665
|
|
|
|
|
|
} |
666
|
|
|
|
|
|
} |
667
|
|
|
|
|
|
|
668
|
20
|
|
|
|
|
(void)hv_store_ent(nmcache, sv, &PL_sv_undef, 0); |
669
|
20
|
|
|
|
|
if(throw_nomethod) |
670
|
4
|
|
|
|
|
Perl_croak(aTHX_ "No next::method '%"SVf"' found for %"SVf, |
671
|
4
|
|
|
|
|
SVfARG(newSVpvn_flags(subname, subname_len, |
672
|
|
|
|
|
|
SVs_TEMP | ( subname_utf8 ? SVf_UTF8 : 0 ) )), |
673
|
4
|
|
|
|
|
SVfARG(sv_2mortal(newSVhek( HvNAME_HEK(selfstash) )))); |
674
|
16
|
|
|
|
|
XSRETURN_EMPTY; |
675
|
|
|
|
|
|
|
676
|
|
|
|
|
|
BOOT: |
677
|
218
|
|
|
|
|
Perl_mro_register(aTHX_ &c3_alg); |