6 /* Most of this code is backported from the bleadperl patch's
7 mro.c, and then modified to work with Class::C3's
12 __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level)
18 const char* stashname;
20 I32 made_mortal_cache = 0;
25 stashname = HvNAME(stash);
26 stashname_len = strlen(stashname);
29 "Can't linearize anonymous symbol table");
32 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
36 cache = (HV*)sv_2mortal((SV*)newHV());
37 made_mortal_cache = 1;
40 SV** cache_entry = hv_fetch(cache, stashname, stashname_len, 0);
42 return (AV*)SvREFCNT_inc(*cache_entry);
45 /* not in cache, make a new one */
47 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
48 isa = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
49 if(isa && AvFILLp(isa) >= 0) {
52 HV* const tails = (HV*)sv_2mortal((SV*)newHV());
53 AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
56 /* This builds @seqs, which is an array of arrays.
57 The members of @seqs are the MROs of
58 the members of @ISA, followed by @ISA itself.
60 I32 items = AvFILLp(isa) + 1;
61 SV** isa_ptr = AvARRAY(isa);
63 SV* const isa_item = *isa_ptr++;
64 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
66 /* if no stash, make a temporary fake MRO
67 containing just itself */
68 AV* const isa_lin = newAV();
69 av_push(isa_lin, newSVsv(isa_item));
70 av_push(seqs, (SV*)isa_lin);
74 AV* const isa_lin = __mro_linear_isa_c3(aTHX_ isa_item_stash, cache, level + 1);
75 av_push(seqs, (SV*)isa_lin);
78 av_push(seqs, SvREFCNT_inc((SV*)isa));
80 /* This builds "heads", which as an array of integer array
81 indices, one per seq, which point at the virtual "head"
82 of the seq (initially zero) */
83 Newz(0xdead, heads, AvFILLp(seqs)+1, I32);
85 /* This builds %tails, which has one key for every class
86 mentioned in the tail of any sequence in @seqs (tail meaning
87 everything after the first class, the "head"). The value
88 is how many times this key appears in the tails of @seqs.
90 seqs_ptr = AvARRAY(seqs);
91 seqs_items = AvFILLp(seqs) + 1;
93 AV* const seq = (AV*)*seqs_ptr++;
94 I32 seq_items = AvFILLp(seq);
96 SV** seq_ptr = AvARRAY(seq) + 1;
98 SV* const seqitem = *seq_ptr++;
99 HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
101 hv_store_ent(tails, seqitem, newSViv(1), 0);
104 SV* const val = HeVAL(he);
111 /* Initialize retval to build the return value in */
113 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
115 /* This loop won't terminate until we either finish building
116 the MRO, or get an exception. */
122 /* "foreach $seq (@seqs)" */
123 SV** const avptr = AvARRAY(seqs);
124 for(s = 0; s <= AvFILLp(seqs); s++) {
126 AV * const seq = (AV*)(avptr[s]);
128 if(!seq) continue; /* skip empty seqs */
129 svp = av_fetch(seq, heads[s], 0);
130 seqhead = *svp; /* seqhead = head of this seq */
134 /* if we haven't found a winner for this round yet,
135 and this seqhead is not in tails (or the count
136 for it in tails has dropped to zero), then this
137 seqhead is our new winner, and is added to the
138 final MRO immediately */
140 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
141 && (val = HeVAL(tail_entry))
144 winner = newSVsv(cand);
145 av_push(retval, winner);
146 /* note however that even when we find a winner,
147 we continue looping over @seqs to do housekeeping */
149 if(!sv_cmp(seqhead, winner)) {
150 /* Once we have a winner (including the iteration
151 where we first found him), inc the head ptr
152 for any seq which had the winner as a head,
153 NULL out any seq which is now empty,
154 and adjust tails for consistency */
156 const int new_head = ++heads[s];
157 if(new_head > AvFILLp(seq)) {
158 SvREFCNT_dec(avptr[s]);
164 /* Because we know this new seqhead used to be
165 a tail, we can assume it is in tails and has
166 a positive value, which we need to dec */
167 svp = av_fetch(seq, new_head, 0);
169 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
170 val = HeVAL(tail_entry);
176 /* if we found no candidates, we are done building the MRO.
177 !cand means no seqs have any entries left to check */
183 /* If we had candidates, but nobody won, then the @ISA
184 hierarchy is not C3-incompatible */
186 /* we have to do some cleanup before we croak */
188 SvREFCNT_dec(retval);
191 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
192 "merging failed on parent '%s'", stashname, SvPV_nolen(cand));
196 else { /* @ISA was undefined or empty */
197 /* build a retval containing only ourselves */
199 av_push(retval, newSVpvn(stashname, stashname_len));
202 /* we don't want anyone modifying the cache entry but us,
203 and we do so by replacing it completely */
204 SvREADONLY_on(retval);
206 if(!made_mortal_cache) {
207 SvREFCNT_inc(retval);
208 hv_store(cache, stashname, stashname_len, (SV*)retval, 0);
215 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
217 for (i = startingblock; i >= 0; i--) {
218 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
224 __nextcan(pTHX_ SV* self, I32 throw_nomethod)
227 register const PERL_CONTEXT *ccstack = cxstack;
228 const PERL_SI *top_si = PL_curstackinfo;
232 const char *fq_subname;
234 STRLEN fq_subname_len;
235 STRLEN stashname_len;
242 GV* candidate = NULL;
250 if(sv_isobject(self))
251 selfstash = SvSTASH(SvRV(self));
253 selfstash = gv_stashsv(self, 0);
257 hvname = HvNAME(selfstash);
259 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
261 cxix = __dopoptosub_at(cxstack, cxstack_ix);
263 /* This block finds the contextually-enclosing fully-qualified subname,
264 much like looking at (caller($i))[3] until you find a real sub that
267 /* we may be in a higher stacklevel, so dig down deeper */
269 if(top_si->si_type == PERLSI_MAIN)
270 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
271 top_si = top_si->si_prev;
272 ccstack = top_si->si_cxstack;
273 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
276 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
277 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
278 cxix = __dopoptosub_at(ccstack, cxix - 1);
283 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
284 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
285 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
292 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
295 cxix = __dopoptosub_at(ccstack, cxix - 1);
299 /* we found a real sub here */
300 sv = sv_2mortal(newSV(0));
302 gv_efullname3(sv, cvgv, NULL);
304 fq_subname = SvPVX(sv);
305 fq_subname_len = SvCUR(sv);
307 subname = strrchr(fq_subname, ':');
309 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
312 subname_len = fq_subname_len - (subname - fq_subname);
313 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
314 cxix = __dopoptosub_at(ccstack, cxix - 1);
320 /* If we made it to here, we found our context */
322 /* cachekey = "objpkg|context::method::name" */
323 cachekey = sv_2mortal(newSVpv(hvname, 0));
324 sv_catpvn(cachekey, "|", 1);
325 sv_catsv(cachekey, sv);
327 nmcache = get_hv("next::METHOD_CACHE", 1);
328 if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
329 SV* val = HeVAL(cache_entry);
330 if(val == &PL_sv_undef) {
332 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
335 return SvREFCNT_inc(val);
338 /* beyond here is just for cache misses, so perf isn't as critical */
340 stashname_len = subname - fq_subname - 2;
341 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
343 linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
345 linear_svp = AvARRAY(linear_av);
346 items = AvFILLp(linear_av) + 1;
349 SV* const linear_sv = *linear_svp++;
351 if(sv_eq(linear_sv, stashname))
356 SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
357 HV* cc3_mro = get_hv("Class::C3::MRO", 0);
360 SV* const linear_sv = *linear_svp++;
364 HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
365 if(he_cc3_mro_class) {
366 SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
367 if(SvROK(cc3_mro_class_sv)) {
368 HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
369 SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
370 if(svp_cc3_mro_class_methods) {
371 SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
372 if(SvROK(cc3_mro_class_methods_sv)) {
373 HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
374 if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
382 cstash = gv_stashsv(linear_sv, FALSE);
385 if (ckWARN(WARN_MISC))
386 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
387 (void*)linear_sv, hvname);
393 gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
399 if (SvTYPE(candidate) != SVt_PVGV)
400 gv_init(candidate, cstash, subname, subname_len, TRUE);
401 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
402 SvREFCNT_dec(linear_av);
403 SvREFCNT_inc((SV*)cand_cv);
404 hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0);
410 SvREFCNT_dec(linear_av);
411 hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0);
413 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
417 XS(XS_Class_C3_XS_calculateMRO);
418 XS(XS_Class_C3_XS_calculateMRO)
434 if(items < 1 || items > 2)
435 croak("Usage: calculateMRO(classname[, cache])");
438 if(items == 2) cache = (HV*)SvRV(ST(1));
440 class_stash = gv_stashsv(classname, 0);
442 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
444 res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
446 res_items = ret_items = AvFILLp(res) + 1;
447 res_ptr = AvARRAY(res);
452 SV* res_item = *res_ptr++;
453 XPUSHs(sv_2mortal(newSVsv(res_item)));
462 XS(XS_Class_C3_XS_plsubgen);
463 XS(XS_Class_C3_XS_plsubgen)
472 XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
477 XS(XS_Class_C3_XS_calc_mdt);
478 XS(XS_Class_C3_XS_calc_mdt)
490 HV* our_c3mro; /* $Class::C3::MRO{classname} */
500 if(items < 1 || items > 2)
501 croak("Usage: calculate_method_dispatch_table(classname[, cache])");
504 class_stash = gv_stashsv(classname, 0);
506 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
508 if(items == 2) cache = (HV*)SvRV(ST(1));
510 class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
513 hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0);
515 hv = get_hv("Class::C3::MRO", 1);
516 hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0);
520 /* skip first entry */
521 mroitems = AvFILLp(class_mro);
522 svp = AvARRAY(class_mro) + 1;
524 SV* mro_class = *svp++;
525 HV* mro_stash = gv_stashsv(mro_class, 0);
527 if(!mro_stash) continue;
530 SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
531 if(ovfp) has_ovf = *ovfp;
534 hv_iterinit(mro_stash);
535 while(he = hv_iternext(mro_stash)) {
543 mskey = hv_iterkeysv(he);
544 if(hv_exists_ent(methods, mskey, 0)) continue;
546 msval = hv_iterval(mro_stash, he);
547 if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
550 if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
551 SV* val = HeVAL(ourent);
552 if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
557 orig = newSVsv(mro_class);
558 sv_catpvn(orig, "::", 2);
559 sv_catsv(orig, mskey);
560 hv_store(meth_hash, "orig", 4, orig, 0);
561 hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0);
562 hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0);
566 hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0);
567 if(has_ovf) hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0);
581 SV* methcv = __nextcan(aTHX_ self, 0);
583 PERL_UNUSED_VAR(items);
585 if(methcv == &PL_sv_undef) {
586 ST(0) = &PL_sv_undef;
589 ST(0) = sv_2mortal(newRV_inc(methcv));
601 SV* methcv = __nextcan(aTHX_ self, 1);
604 call_sv(methcv, GIMME_V);
607 XS(XS_maybe_next_method);
608 XS(XS_maybe_next_method)
613 SV* methcv = __nextcan(aTHX_ self, 0);
615 if(methcv == &PL_sv_undef) {
616 ST(0) = &PL_sv_undef;
621 call_sv(methcv, GIMME_V);
624 MODULE = Class::C3::XS PACKAGE = Class::C3::XS
627 newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
628 newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
629 newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
630 newXS("next::can", XS_next_can, __FILE__);
631 newXS("next::method", XS_next_method, __FILE__);
632 newXS("maybe::next::method", XS_maybe_next_method, __FILE__);