This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In struct mro_meta, rename mro_linear_dfs to mro_linear_all, and change it from
[perl5.git] / ext / mro / mro.xs
CommitLineData
b2685f0c
NC
1#include "EXTERN.h"
2#include "perl.h"
3#include "XSUB.h"
4
5static AV*
6S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level);
7
8static const struct mro_alg c3_alg =
9 {S_mro_get_linear_isa_c3, "c3", 2, 0, 0};
10
11/*
12=for apidoc mro_get_linear_isa_c3
13
14Returns the C3 linearization of @ISA
15the given stash. The return value is a read-only AV*.
16C<level> should be 0 (it is used internally in this
17function's recursion).
18
19You are responsible for C<SvREFCNT_inc()> on the
20return value if you plan to store it anywhere
21semi-permanently (otherwise it might be deleted
22out from under you the next time the cache is
23invalidated).
24
25=cut
26*/
27
28static AV*
29S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
30{
31 AV* retval;
32 GV** gvp;
33 GV* gv;
34 AV* isa;
35 const HEK* stashhek;
36 struct mro_meta* meta;
37
38 assert(HvAUX(stash));
39
40 stashhek = HvNAME_HEK(stash);
41 if (!stashhek)
42 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
43
44 if (level > 100)
45 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
46 HEK_KEY(stashhek));
47
48 meta = HvMROMETA(stash);
49
50 /* return cache if valid */
51 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &c3_alg)))) {
52 return retval;
53 }
54
55 /* not in cache, make a new one */
56
57 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
58 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
59
60 /* For a better idea how the rest of this works, see the much clearer
61 pure perl version in Algorithm::C3 0.01:
62 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
63 (later versions go about it differently than this code for speed reasons)
64 */
65
66 if(isa && AvFILLp(isa) >= 0) {
67 SV** seqs_ptr;
68 I32 seqs_items;
69 HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
70 AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
71 I32* heads;
72
73 /* This builds @seqs, which is an array of arrays.
74 The members of @seqs are the MROs of
75 the members of @ISA, followed by @ISA itself.
76 */
77 I32 items = AvFILLp(isa) + 1;
78 SV** isa_ptr = AvARRAY(isa);
79 while(items--) {
80 SV* const isa_item = *isa_ptr++;
81 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
82 if(!isa_item_stash) {
83 /* if no stash, make a temporary fake MRO
84 containing just itself */
85 AV* const isa_lin = newAV();
86 av_push(isa_lin, newSVsv(isa_item));
87 av_push(seqs, MUTABLE_SV(isa_lin));
88 }
89 else {
90 /* recursion */
91 AV* const isa_lin
92 = S_mro_get_linear_isa_c3(aTHX_ isa_item_stash, level + 1);
93 av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin)));
94 }
95 }
96 av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa)));
97
98 /* This builds "heads", which as an array of integer array
99 indices, one per seq, which point at the virtual "head"
100 of the seq (initially zero) */
101 Newxz(heads, AvFILLp(seqs)+1, I32);
102
103 /* This builds %tails, which has one key for every class
104 mentioned in the tail of any sequence in @seqs (tail meaning
105 everything after the first class, the "head"). The value
106 is how many times this key appears in the tails of @seqs.
107 */
108 seqs_ptr = AvARRAY(seqs);
109 seqs_items = AvFILLp(seqs) + 1;
110 while(seqs_items--) {
111 AV *const seq = MUTABLE_AV(*seqs_ptr++);
112 I32 seq_items = AvFILLp(seq);
113 if(seq_items > 0) {
114 SV** seq_ptr = AvARRAY(seq) + 1;
115 while(seq_items--) {
116 SV* const seqitem = *seq_ptr++;
117 /* LVALUE fetch will create a new undefined SV if necessary
118 */
119 HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
120 if(he) {
121 SV* const val = HeVAL(he);
122 /* This will increment undef to 1, which is what we
123 want for a newly created entry. */
124 sv_inc(val);
125 }
126 }
127 }
128 }
129
130 /* Initialize retval to build the return value in */
131 retval = newAV();
132 av_push(retval, newSVhek(stashhek)); /* us first */
133
134 /* This loop won't terminate until we either finish building
135 the MRO, or get an exception. */
136 while(1) {
137 SV* cand = NULL;
138 SV* winner = NULL;
139 int s;
140
141 /* "foreach $seq (@seqs)" */
142 SV** const avptr = AvARRAY(seqs);
143 for(s = 0; s <= AvFILLp(seqs); s++) {
144 SV** svp;
145 AV * const seq = MUTABLE_AV(avptr[s]);
146 SV* seqhead;
147 if(!seq) continue; /* skip empty seqs */
148 svp = av_fetch(seq, heads[s], 0);
149 seqhead = *svp; /* seqhead = head of this seq */
150 if(!winner) {
151 HE* tail_entry;
152 SV* val;
153 /* if we haven't found a winner for this round yet,
154 and this seqhead is not in tails (or the count
155 for it in tails has dropped to zero), then this
156 seqhead is our new winner, and is added to the
157 final MRO immediately */
158 cand = seqhead;
159 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
160 && (val = HeVAL(tail_entry))
161 && (SvIVX(val) > 0))
162 continue;
163 winner = newSVsv(cand);
164 av_push(retval, winner);
165 /* note however that even when we find a winner,
166 we continue looping over @seqs to do housekeeping */
167 }
168 if(!sv_cmp(seqhead, winner)) {
169 /* Once we have a winner (including the iteration
170 where we first found him), inc the head ptr
171 for any seq which had the winner as a head,
172 NULL out any seq which is now empty,
173 and adjust tails for consistency */
174
175 const int new_head = ++heads[s];
176 if(new_head > AvFILLp(seq)) {
177 SvREFCNT_dec(avptr[s]);
178 avptr[s] = NULL;
179 }
180 else {
181 HE* tail_entry;
182 SV* val;
183 /* Because we know this new seqhead used to be
184 a tail, we can assume it is in tails and has
185 a positive value, which we need to dec */
186 svp = av_fetch(seq, new_head, 0);
187 seqhead = *svp;
188 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
189 val = HeVAL(tail_entry);
190 sv_dec(val);
191 }
192 }
193 }
194
195 /* if we found no candidates, we are done building the MRO.
196 !cand means no seqs have any entries left to check */
197 if(!cand) {
198 Safefree(heads);
199 break;
200 }
201
202 /* If we had candidates, but nobody won, then the @ISA
203 hierarchy is not C3-incompatible */
204 if(!winner) {
205 /* we have to do some cleanup before we croak */
206
207 SvREFCNT_dec(retval);
208 Safefree(heads);
209
210 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
211 "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand));
212 }
213 }
214 }
215 else { /* @ISA was undefined or empty */
216 /* build a retval containing only ourselves */
217 retval = newAV();
218 av_push(retval, newSVhek(stashhek));
219 }
220
221 /* we don't want anyone modifying the cache entry but us,
222 and we do so by replacing it completely */
223 SvREADONLY_on(retval);
224
225 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg,
226 MUTABLE_SV(retval)));
227 return retval;
228}
229
230
231/* These two are static helpers for next::method and friends,
232 and re-implement a bunch of the code from pp_caller() in
233 a more efficient manner for this particular usage.
234*/
235
236static I32
237__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
238 I32 i;
239 for (i = startingblock; i >= 0; i--) {
240 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
241 }
242 return i;
243}
244
245MODULE = mro PACKAGE = mro PREFIX = mro
246
247void
248mro_nextcan(...)
249 PREINIT:
250 SV* self = ST(0);
251 const I32 throw_nomethod = SvIVX(ST(1));
252 register I32 cxix = cxstack_ix;
253 register const PERL_CONTEXT *ccstack = cxstack;
254 const PERL_SI *top_si = PL_curstackinfo;
255 HV* selfstash;
256 SV *stashname;
257 const char *fq_subname;
258 const char *subname;
259 STRLEN stashname_len;
260 STRLEN subname_len;
261 SV* sv;
262 GV** gvp;
263 AV* linear_av;
264 SV** linear_svp;
265 const char *hvname;
266 I32 entries;
267 struct mro_meta* selfmeta;
268 HV* nmcache;
269 I32 i;
270 PPCODE:
271 PERL_UNUSED_ARG(cv);
272
273 if(sv_isobject(self))
274 selfstash = SvSTASH(SvRV(self));
275 else
276 selfstash = gv_stashsv(self, GV_ADD);
277
278 assert(selfstash);
279
280 hvname = HvNAME_get(selfstash);
281 if (!hvname)
282 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
283
284 /* This block finds the contextually-enclosing fully-qualified subname,
285 much like looking at (caller($i))[3] until you find a real sub that
286 isn't ANON, etc (also skips over pureperl next::method, etc) */
287 for(i = 0; i < 2; i++) {
288 cxix = __dopoptosub_at(ccstack, cxix);
289 for (;;) {
290 GV* cvgv;
291 STRLEN fq_subname_len;
292
293 /* we may be in a higher stacklevel, so dig down deeper */
294 while (cxix < 0) {
295 if(top_si->si_type == PERLSI_MAIN)
296 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
297 top_si = top_si->si_prev;
298 ccstack = top_si->si_cxstack;
299 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
300 }
301
302 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
303 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
304 cxix = __dopoptosub_at(ccstack, cxix - 1);
305 continue;
306 }
307
308 {
309 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
310 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
311 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
312 cxix = dbcxix;
313 continue;
314 }
315 }
316 }
317
318 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
319
320 if(!isGV(cvgv)) {
321 cxix = __dopoptosub_at(ccstack, cxix - 1);
322 continue;
323 }
324
325 /* we found a real sub here */
326 sv = sv_2mortal(newSV(0));
327
328 gv_efullname3(sv, cvgv, NULL);
329
330 fq_subname = SvPVX(sv);
331 fq_subname_len = SvCUR(sv);
332
333 subname = strrchr(fq_subname, ':');
334 if(!subname)
335 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
336
337 subname++;
338 subname_len = fq_subname_len - (subname - fq_subname);
339 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
340 cxix = __dopoptosub_at(ccstack, cxix - 1);
341 continue;
342 }
343 break;
344 }
345 cxix--;
346 }
347
348 /* If we made it to here, we found our context */
349
350 /* Initialize the next::method cache for this stash
351 if necessary */
352 selfmeta = HvMROMETA(selfstash);
353 if(!(nmcache = selfmeta->mro_nextmethod)) {
354 nmcache = selfmeta->mro_nextmethod = newHV();
355 }
356 else { /* Use the cached coderef if it exists */
357 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
358 if (cache_entry) {
359 SV* const val = HeVAL(cache_entry);
360 if(val == &PL_sv_undef) {
361 if(throw_nomethod)
362 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
363 XSRETURN_EMPTY;
364 }
365 mXPUSHs(newRV_inc(val));
366 XSRETURN(1);
367 }
368 }
369
370 /* beyond here is just for cache misses, so perf isn't as critical */
371
372 stashname_len = subname - fq_subname - 2;
373 stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
374
375 /* has ourselves at the top of the list */
376 linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0);
377
378 linear_svp = AvARRAY(linear_av);
379 entries = AvFILLp(linear_av) + 1;
380
381 /* Walk down our MRO, skipping everything up
382 to the contextually enclosing class */
383 while (entries--) {
384 SV * const linear_sv = *linear_svp++;
385 assert(linear_sv);
386 if(sv_eq(linear_sv, stashname))
387 break;
388 }
389
390 /* Now search the remainder of the MRO for the
391 same method name as the contextually enclosing
392 method */
393 if(entries > 0) {
394 while (entries--) {
395 SV * const linear_sv = *linear_svp++;
396 HV* curstash;
397 GV* candidate;
398 CV* cand_cv;
399
400 assert(linear_sv);
401 curstash = gv_stashsv(linear_sv, FALSE);
402
403 if (!curstash) {
404 if (ckWARN(WARN_SYNTAX))
405 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
406 (void*)linear_sv, hvname);
407 continue;
408 }
409
410 assert(curstash);
411
412 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
413 if (!gvp) continue;
414
415 candidate = *gvp;
416 assert(candidate);
417
418 if (SvTYPE(candidate) != SVt_PVGV)
419 gv_init(candidate, curstash, subname, subname_len, TRUE);
420
421 /* Notably, we only look for real entries, not method cache
422 entries, because in C3 the method cache of a parent is not
423 valid for the child */
424 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
425 SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv));
426 (void)hv_store_ent(nmcache, newSVsv(sv), MUTABLE_SV(cand_cv), 0);
427 mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv)));
428 XSRETURN(1);
429 }
430 }
431 }
432
433 (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
434 if(throw_nomethod)
435 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
436 XSRETURN_EMPTY;
437
438BOOT:
439 Perl_mro_register(aTHX_ &c3_alg);