6 /* *********** ppport stuff */
8 #ifndef PERL_UNUSED_VAR
9 # define PERL_UNUSED_VAR(x) ((void)x)
12 #if defined(PERL_GCC_PEDANTIC)
13 # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
14 # define PERL_GCC_BRACE_GROUPS_FORBIDDEN
18 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
19 # ifndef PERL_USE_GCC_BRACE_GROUPS
20 # define PERL_USE_GCC_BRACE_GROUPS
25 # ifdef PERL_USE_GCC_BRACE_GROUPS
26 # define SvREFCNT_inc(sv) \
28 SV * const _sv = (SV*)(sv); \
34 # define SvREFCNT_inc(sv) \
35 ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL)
40 # define dAX I32 ax = MARK - PL_stack_base + 1
48 # define packWARN(a) (a)
51 /* *********** end ppport.h stuff */
53 /* Most of this code is backported from the bleadperl patch's
54 mro.c, and then modified to work with Class::C3's
59 __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level)
65 const char* stashname;
67 I32 made_mortal_cache = 0;
71 stashname = HvNAME(stash);
72 stashname_len = strlen(stashname);
75 "Can't linearize anonymous symbol table");
78 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
82 cache = (HV*)sv_2mortal((SV*)newHV());
83 made_mortal_cache = 1;
86 SV** cache_entry = hv_fetch(cache, stashname, stashname_len, 0);
88 return (AV*)SvREFCNT_inc(*cache_entry);
91 /* not in cache, make a new one */
93 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
94 isa = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
95 if(isa && AvFILLp(isa) >= 0) {
98 HV* const tails = (HV*)sv_2mortal((SV*)newHV());
99 AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
102 /* This builds @seqs, which is an array of arrays.
103 The members of @seqs are the MROs of
104 the members of @ISA, followed by @ISA itself.
106 I32 items = AvFILLp(isa) + 1;
107 SV** isa_ptr = AvARRAY(isa);
109 SV* const isa_item = *isa_ptr++;
110 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
111 if(!isa_item_stash) {
112 /* if no stash, make a temporary fake MRO
113 containing just itself */
114 AV* const isa_lin = newAV();
115 av_push(isa_lin, newSVsv(isa_item));
116 av_push(seqs, (SV*)isa_lin);
120 AV* const isa_lin = __mro_linear_isa_c3(aTHX_ isa_item_stash, cache, level + 1);
121 av_push(seqs, (SV*)isa_lin);
124 av_push(seqs, SvREFCNT_inc((SV*)isa));
126 /* This builds "heads", which as an array of integer array
127 indices, one per seq, which point at the virtual "head"
128 of the seq (initially zero) */
129 Newz(0xdead, heads, AvFILLp(seqs)+1, I32);
131 /* This builds %tails, which has one key for every class
132 mentioned in the tail of any sequence in @seqs (tail meaning
133 everything after the first class, the "head"). The value
134 is how many times this key appears in the tails of @seqs.
136 seqs_ptr = AvARRAY(seqs);
137 seqs_items = AvFILLp(seqs) + 1;
138 while(seqs_items--) {
139 AV* const seq = (AV*)*seqs_ptr++;
140 I32 seq_items = AvFILLp(seq);
142 SV** seq_ptr = AvARRAY(seq) + 1;
144 SV* const seqitem = *seq_ptr++;
145 HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
147 hv_store_ent(tails, seqitem, newSViv(1), 0);
150 SV* const val = HeVAL(he);
157 /* Initialize retval to build the return value in */
159 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
161 /* This loop won't terminate until we either finish building
162 the MRO, or get an exception. */
168 /* "foreach $seq (@seqs)" */
169 SV** const avptr = AvARRAY(seqs);
170 for(s = 0; s <= AvFILLp(seqs); s++) {
172 AV * const seq = (AV*)(avptr[s]);
174 if(!seq) continue; /* skip empty seqs */
175 svp = av_fetch(seq, heads[s], 0);
176 seqhead = *svp; /* seqhead = head of this seq */
180 /* if we haven't found a winner for this round yet,
181 and this seqhead is not in tails (or the count
182 for it in tails has dropped to zero), then this
183 seqhead is our new winner, and is added to the
184 final MRO immediately */
186 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
187 && (val = HeVAL(tail_entry))
190 winner = newSVsv(cand);
191 av_push(retval, winner);
192 /* note however that even when we find a winner,
193 we continue looping over @seqs to do housekeeping */
195 if(!sv_cmp(seqhead, winner)) {
196 /* Once we have a winner (including the iteration
197 where we first found him), inc the head ptr
198 for any seq which had the winner as a head,
199 NULL out any seq which is now empty,
200 and adjust tails for consistency */
202 const int new_head = ++heads[s];
203 if(new_head > AvFILLp(seq)) {
204 SvREFCNT_dec(avptr[s]);
210 /* Because we know this new seqhead used to be
211 a tail, we can assume it is in tails and has
212 a positive value, which we need to dec */
213 svp = av_fetch(seq, new_head, 0);
215 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
216 val = HeVAL(tail_entry);
222 /* if we found no candidates, we are done building the MRO.
223 !cand means no seqs have any entries left to check */
229 /* If we had candidates, but nobody won, then the @ISA
230 hierarchy is not C3-incompatible */
232 /* we have to do some cleanup before we croak */
234 SvREFCNT_dec(retval);
237 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
238 "merging failed on parent '%s'", stashname, SvPV_nolen(cand));
242 else { /* @ISA was undefined or empty */
243 /* build a retval containing only ourselves */
245 av_push(retval, newSVpvn(stashname, stashname_len));
248 /* we don't want anyone modifying the cache entry but us,
249 and we do so by replacing it completely */
250 SvREADONLY_on(retval);
252 if(!made_mortal_cache) {
253 SvREFCNT_inc(retval);
254 hv_store(cache, stashname, stashname_len, (SV*)retval, 0);
261 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
263 for (i = startingblock; i >= 0; i--) {
264 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
270 __nextcan(pTHX_ SV* self, I32 throw_nomethod)
273 register const PERL_CONTEXT *ccstack = cxstack;
274 const PERL_SI *top_si = PL_curstackinfo;
278 const char *fq_subname;
280 STRLEN fq_subname_len;
281 STRLEN stashname_len;
288 GV* candidate = NULL;
296 if(sv_isobject(self))
297 selfstash = SvSTASH(SvRV(self));
299 selfstash = gv_stashsv(self, 0);
303 hvname = HvNAME(selfstash);
305 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
307 cxix = __dopoptosub_at(cxstack, cxstack_ix);
309 /* This block finds the contextually-enclosing fully-qualified subname,
310 much like looking at (caller($i))[3] until you find a real sub that
313 /* we may be in a higher stacklevel, so dig down deeper */
315 if(top_si->si_type == PERLSI_MAIN)
316 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
317 top_si = top_si->si_prev;
318 ccstack = top_si->si_cxstack;
319 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
322 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
323 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
324 cxix = __dopoptosub_at(ccstack, cxix - 1);
329 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
330 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
331 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
338 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
341 cxix = __dopoptosub_at(ccstack, cxix - 1);
345 /* we found a real sub here */
346 sv = sv_2mortal(newSV(0));
348 gv_efullname3(sv, cvgv, NULL);
350 fq_subname = SvPVX(sv);
351 fq_subname_len = SvCUR(sv);
353 subname = strrchr(fq_subname, ':');
355 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
358 subname_len = fq_subname_len - (subname - fq_subname);
359 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
360 cxix = __dopoptosub_at(ccstack, cxix - 1);
366 /* If we made it to here, we found our context */
368 /* cachekey = "objpkg|context::method::name" */
369 cachekey = sv_2mortal(newSVpv(hvname, 0));
370 sv_catpvn(cachekey, "|", 1);
371 sv_catsv(cachekey, sv);
373 nmcache = get_hv("next::METHOD_CACHE", 1);
374 if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
375 SV* val = HeVAL(cache_entry);
376 if(val == &PL_sv_undef) {
378 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
381 return SvREFCNT_inc(val);
384 /* beyond here is just for cache misses, so perf isn't as critical */
386 stashname_len = subname - fq_subname - 2;
387 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
389 linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
391 linear_svp = AvARRAY(linear_av);
392 items = AvFILLp(linear_av) + 1;
395 SV* const linear_sv = *linear_svp++;
397 if(sv_eq(linear_sv, stashname))
402 SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
403 HV* cc3_mro = get_hv("Class::C3::MRO", 0);
406 SV* const linear_sv = *linear_svp++;
410 HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
411 if(he_cc3_mro_class) {
412 SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
413 if(SvROK(cc3_mro_class_sv)) {
414 HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
415 SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
416 if(svp_cc3_mro_class_methods) {
417 SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
418 if(SvROK(cc3_mro_class_methods_sv)) {
419 HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
420 if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
428 cstash = gv_stashsv(linear_sv, FALSE);
431 if (ckWARN(WARN_MISC))
432 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
433 (void*)linear_sv, hvname);
439 gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
445 if (SvTYPE(candidate) != SVt_PVGV)
446 gv_init(candidate, cstash, subname, subname_len, TRUE);
447 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
448 SvREFCNT_dec(linear_av);
449 SvREFCNT_inc((SV*)cand_cv);
450 hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0);
456 SvREFCNT_dec(linear_av);
457 hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0);
459 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
463 XS(XS_Class_C3_XS_calculateMRO);
464 XS(XS_Class_C3_XS_calculateMRO)
476 if(items < 1 || items > 2)
477 croak("Usage: calculateMRO(classname[, cache])");
480 if(items == 2) cache = (HV*)SvRV(ST(1));
482 class_stash = gv_stashsv(classname, 0);
484 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
486 res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
488 res_items = ret_items = AvFILLp(res) + 1;
489 res_ptr = AvARRAY(res);
494 SV* res_item = *res_ptr++;
495 XPUSHs(sv_2mortal(newSVsv(res_item)));
504 XS(XS_Class_C3_XS_plsubgen);
505 XS(XS_Class_C3_XS_plsubgen)
510 XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
515 XS(XS_Class_C3_XS_calc_mdt);
516 XS(XS_Class_C3_XS_calc_mdt)
524 HV* our_c3mro; /* $Class::C3::MRO{classname} */
534 if(items < 1 || items > 2)
535 croak("Usage: calculate_method_dispatch_table(classname[, cache])");
538 class_stash = gv_stashsv(classname, 0);
540 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
542 if(items == 2) cache = (HV*)SvRV(ST(1));
544 class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
547 hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0);
549 hv = get_hv("Class::C3::MRO", 1);
550 hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0);
554 /* skip first entry */
555 mroitems = AvFILLp(class_mro);
556 svp = AvARRAY(class_mro) + 1;
558 SV* mro_class = *svp++;
559 HV* mro_stash = gv_stashsv(mro_class, 0);
561 if(!mro_stash) continue;
564 SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
565 if(ovfp) has_ovf = *ovfp;
568 hv_iterinit(mro_stash);
569 while(he = hv_iternext(mro_stash)) {
577 mskey = hv_iterkeysv(he);
578 if(hv_exists_ent(methods, mskey, 0)) continue;
580 msval = hv_iterval(mro_stash, he);
581 if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
584 if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
585 SV* val = HeVAL(ourent);
586 if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
591 orig = newSVsv(mro_class);
592 sv_catpvn(orig, "::", 2);
593 sv_catsv(orig, mskey);
594 hv_store(meth_hash, "orig", 4, orig, 0);
595 hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0);
596 hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0);
600 hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0);
601 if(has_ovf) hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0);
611 SV* methcv = __nextcan(aTHX_ self, 0);
613 PERL_UNUSED_VAR(items);
615 if(methcv == &PL_sv_undef) {
616 ST(0) = &PL_sv_undef;
619 ST(0) = sv_2mortal(newRV_inc(methcv));
631 SV* methcv = __nextcan(aTHX_ self, 1);
634 call_sv(methcv, GIMME_V);
637 XS(XS_maybe_next_method);
638 XS(XS_maybe_next_method)
643 SV* methcv = __nextcan(aTHX_ self, 0);
645 if(methcv == &PL_sv_undef) {
646 ST(0) = &PL_sv_undef;
651 call_sv(methcv, GIMME_V);
654 MODULE = Class::C3::XS PACKAGE = Class::C3::XS
657 newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
658 newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
659 newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
660 newXS("next::can", XS_next_can, __FILE__);
661 newXS("next::method", XS_next_method, __FILE__);
662 newXS("maybe::next::method", XS_maybe_next_method, __FILE__);