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;
72 stashname = HvNAME(stash);
73 stashname_len = strlen(stashname);
76 "Can't linearize anonymous symbol table");
79 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
83 cache = (HV*)sv_2mortal((SV*)newHV());
84 made_mortal_cache = 1;
87 SV** cache_entry = hv_fetch(cache, stashname, stashname_len, 0);
89 return (AV*)SvREFCNT_inc(*cache_entry);
92 /* not in cache, make a new one */
94 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
95 isa = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
96 if(isa && AvFILLp(isa) >= 0) {
99 HV* const tails = (HV*)sv_2mortal((SV*)newHV());
100 AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
103 /* This builds @seqs, which is an array of arrays.
104 The members of @seqs are the MROs of
105 the members of @ISA, followed by @ISA itself.
107 I32 items = AvFILLp(isa) + 1;
108 SV** isa_ptr = AvARRAY(isa);
110 SV* const isa_item = *isa_ptr++;
111 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
112 if(!isa_item_stash) {
113 /* if no stash, make a temporary fake MRO
114 containing just itself */
115 AV* const isa_lin = newAV();
116 av_push(isa_lin, newSVsv(isa_item));
117 av_push(seqs, (SV*)isa_lin);
121 AV* const isa_lin = __mro_linear_isa_c3(aTHX_ isa_item_stash, cache, level + 1);
122 av_push(seqs, (SV*)isa_lin);
125 av_push(seqs, SvREFCNT_inc((SV*)isa));
127 /* This builds "heads", which as an array of integer array
128 indices, one per seq, which point at the virtual "head"
129 of the seq (initially zero) */
130 Newz(0xdead, heads, AvFILLp(seqs)+1, I32);
132 /* This builds %tails, which has one key for every class
133 mentioned in the tail of any sequence in @seqs (tail meaning
134 everything after the first class, the "head"). The value
135 is how many times this key appears in the tails of @seqs.
137 seqs_ptr = AvARRAY(seqs);
138 seqs_items = AvFILLp(seqs) + 1;
139 while(seqs_items--) {
140 AV* const seq = (AV*)*seqs_ptr++;
141 I32 seq_items = AvFILLp(seq);
143 SV** seq_ptr = AvARRAY(seq) + 1;
145 SV* const seqitem = *seq_ptr++;
146 HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
148 hv_store_ent(tails, seqitem, newSViv(1), 0);
151 SV* const val = HeVAL(he);
158 /* Initialize retval to build the return value in */
160 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
162 /* This loop won't terminate until we either finish building
163 the MRO, or get an exception. */
169 /* "foreach $seq (@seqs)" */
170 SV** const avptr = AvARRAY(seqs);
171 for(s = 0; s <= AvFILLp(seqs); s++) {
173 AV * const seq = (AV*)(avptr[s]);
175 if(!seq) continue; /* skip empty seqs */
176 svp = av_fetch(seq, heads[s], 0);
177 seqhead = *svp; /* seqhead = head of this seq */
181 /* if we haven't found a winner for this round yet,
182 and this seqhead is not in tails (or the count
183 for it in tails has dropped to zero), then this
184 seqhead is our new winner, and is added to the
185 final MRO immediately */
187 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
188 && (val = HeVAL(tail_entry))
191 winner = newSVsv(cand);
192 av_push(retval, winner);
193 /* note however that even when we find a winner,
194 we continue looping over @seqs to do housekeeping */
196 if(!sv_cmp(seqhead, winner)) {
197 /* Once we have a winner (including the iteration
198 where we first found him), inc the head ptr
199 for any seq which had the winner as a head,
200 NULL out any seq which is now empty,
201 and adjust tails for consistency */
203 const int new_head = ++heads[s];
204 if(new_head > AvFILLp(seq)) {
205 SvREFCNT_dec(avptr[s]);
211 /* Because we know this new seqhead used to be
212 a tail, we can assume it is in tails and has
213 a positive value, which we need to dec */
214 svp = av_fetch(seq, new_head, 0);
216 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
217 val = HeVAL(tail_entry);
223 /* if we found no candidates, we are done building the MRO.
224 !cand means no seqs have any entries left to check */
230 /* If we had candidates, but nobody won, then the @ISA
231 hierarchy is not C3-incompatible */
233 /* we have to do some cleanup before we croak */
235 SvREFCNT_dec(retval);
238 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
239 "merging failed on parent '%s'", stashname, SvPV_nolen(cand));
243 else { /* @ISA was undefined or empty */
244 /* build a retval containing only ourselves */
246 av_push(retval, newSVpvn(stashname, stashname_len));
249 /* we don't want anyone modifying the cache entry but us,
250 and we do so by replacing it completely */
251 SvREADONLY_on(retval);
253 if(!made_mortal_cache) {
254 SvREFCNT_inc(retval);
255 hv_store(cache, stashname, stashname_len, (SV*)retval, 0);
262 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
264 for (i = startingblock; i >= 0; i--) {
265 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
271 __nextcan(pTHX_ SV* self, I32 throw_nomethod)
274 register const PERL_CONTEXT *ccstack = cxstack;
275 const PERL_SI *top_si = PL_curstackinfo;
279 const char *fq_subname;
281 STRLEN fq_subname_len;
282 STRLEN stashname_len;
289 GV* candidate = NULL;
297 if(sv_isobject(self))
298 selfstash = SvSTASH(SvRV(self));
300 selfstash = gv_stashsv(self, 0);
304 hvname = HvNAME(selfstash);
306 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
308 cxix = __dopoptosub_at(cxstack, cxstack_ix);
310 /* This block finds the contextually-enclosing fully-qualified subname,
311 much like looking at (caller($i))[3] until you find a real sub that
314 /* we may be in a higher stacklevel, so dig down deeper */
316 if(top_si->si_type == PERLSI_MAIN)
317 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
318 top_si = top_si->si_prev;
319 ccstack = top_si->si_cxstack;
320 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
323 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
324 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
325 cxix = __dopoptosub_at(ccstack, cxix - 1);
330 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
331 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
332 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
339 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
342 cxix = __dopoptosub_at(ccstack, cxix - 1);
346 /* we found a real sub here */
347 sv = sv_2mortal(newSV(0));
349 gv_efullname3(sv, cvgv, NULL);
351 fq_subname = SvPVX(sv);
352 fq_subname_len = SvCUR(sv);
354 subname = strrchr(fq_subname, ':');
356 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
359 subname_len = fq_subname_len - (subname - fq_subname);
360 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
361 cxix = __dopoptosub_at(ccstack, cxix - 1);
367 /* If we made it to here, we found our context */
369 /* cachekey = "objpkg|context::method::name" */
370 cachekey = sv_2mortal(newSVpv(hvname, 0));
371 sv_catpvn(cachekey, "|", 1);
372 sv_catsv(cachekey, sv);
374 nmcache = get_hv("next::METHOD_CACHE", 1);
375 if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
376 SV* val = HeVAL(cache_entry);
377 if(val == &PL_sv_undef) {
379 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
382 return SvREFCNT_inc(val);
385 /* beyond here is just for cache misses, so perf isn't as critical */
387 stashname_len = subname - fq_subname - 2;
388 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
390 linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
392 linear_svp = AvARRAY(linear_av);
393 items = AvFILLp(linear_av) + 1;
396 SV* const linear_sv = *linear_svp++;
398 if(sv_eq(linear_sv, stashname))
403 SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
404 HV* cc3_mro = get_hv("Class::C3::MRO", 0);
407 SV* const linear_sv = *linear_svp++;
411 HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
412 if(he_cc3_mro_class) {
413 SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
414 if(SvROK(cc3_mro_class_sv)) {
415 HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
416 SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
417 if(svp_cc3_mro_class_methods) {
418 SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
419 if(SvROK(cc3_mro_class_methods_sv)) {
420 HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
421 if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
429 cstash = gv_stashsv(linear_sv, FALSE);
432 if (ckWARN(WARN_MISC))
433 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
434 (void*)linear_sv, hvname);
440 gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
446 if (SvTYPE(candidate) != SVt_PVGV)
447 gv_init(candidate, cstash, subname, subname_len, TRUE);
448 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
449 SvREFCNT_dec(linear_av);
450 SvREFCNT_inc((SV*)cand_cv);
451 hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0);
457 SvREFCNT_dec(linear_av);
458 hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0);
460 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
464 XS(XS_Class_C3_XS_calculateMRO);
465 XS(XS_Class_C3_XS_calculateMRO)
477 if(items < 1 || items > 2)
478 croak("Usage: calculateMRO(classname[, cache])");
481 if(items == 2) cache = (HV*)SvRV(ST(1));
483 class_stash = gv_stashsv(classname, 0);
485 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
487 res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
489 res_items = ret_items = AvFILLp(res) + 1;
490 res_ptr = AvARRAY(res);
495 SV* res_item = *res_ptr++;
496 XPUSHs(sv_2mortal(newSVsv(res_item)));
505 XS(XS_Class_C3_XS_plsubgen);
506 XS(XS_Class_C3_XS_plsubgen)
511 XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
516 XS(XS_Class_C3_XS_calc_mdt);
517 XS(XS_Class_C3_XS_calc_mdt)
525 HV* our_c3mro; /* $Class::C3::MRO{classname} */
535 if(items < 1 || items > 2)
536 croak("Usage: calculate_method_dispatch_table(classname[, cache])");
539 class_stash = gv_stashsv(classname, 0);
541 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
543 if(items == 2) cache = (HV*)SvRV(ST(1));
545 class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
548 hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0);
550 hv = get_hv("Class::C3::MRO", 1);
551 hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0);
555 /* skip first entry */
556 mroitems = AvFILLp(class_mro);
557 svp = AvARRAY(class_mro) + 1;
559 SV* mro_class = *svp++;
560 HV* mro_stash = gv_stashsv(mro_class, 0);
562 if(!mro_stash) continue;
565 SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
566 if(ovfp) has_ovf = *ovfp;
569 hv_iterinit(mro_stash);
570 while(he = hv_iternext(mro_stash)) {
578 mskey = hv_iterkeysv(he);
579 if(hv_exists_ent(methods, mskey, 0)) continue;
581 msval = hv_iterval(mro_stash, he);
582 if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
585 if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
586 SV* val = HeVAL(ourent);
587 if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
592 orig = newSVsv(mro_class);
593 sv_catpvn(orig, "::", 2);
594 sv_catsv(orig, mskey);
595 hv_store(meth_hash, "orig", 4, orig, 0);
596 hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0);
597 hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0);
601 hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0);
602 if(has_ovf) hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0);
612 SV* methcv = __nextcan(aTHX_ self, 0);
614 PERL_UNUSED_VAR(items);
616 if(methcv == &PL_sv_undef) {
617 ST(0) = &PL_sv_undef;
620 ST(0) = sv_2mortal(newRV_inc(methcv));
632 SV* methcv = __nextcan(aTHX_ self, 1);
635 call_sv(methcv, GIMME_V);
638 XS(XS_maybe_next_method);
639 XS(XS_maybe_next_method)
644 SV* methcv = __nextcan(aTHX_ self, 0);
646 if(methcv == &PL_sv_undef) {
647 ST(0) = &PL_sv_undef;
652 call_sv(methcv, GIMME_V);
655 MODULE = Class::C3::XS PACKAGE = Class::C3::XS
658 newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
659 newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
660 newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
661 newXS("next::can", XS_next_can, __FILE__);
662 newXS("next::method", XS_next_method, __FILE__);
663 newXS("maybe::next::method", XS_maybe_next_method, __FILE__);