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;
269 XS(XS_Class_C3_XS_nextcan);
270 XS(XS_Class_C3_XS_nextcan)
275 const I32 throw_nomethod = SvIVX(ST(1));
277 register const PERL_CONTEXT *ccstack = cxstack;
278 const PERL_SI *top_si = PL_curstackinfo;
282 const char *fq_subname;
284 STRLEN fq_subname_len;
285 STRLEN stashname_len;
292 GV* candidate = NULL;
302 if(sv_isobject(self))
303 selfstash = SvSTASH(SvRV(self));
305 selfstash = gv_stashsv(self, 0);
309 hvname = HvNAME(selfstash);
311 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
313 cxix = __dopoptosub_at(cxstack, cxstack_ix);
314 cxix = __dopoptosub_at(ccstack, cxix - 1); /* skip next::method, etc */
316 /* This block finds the contextually-enclosing fully-qualified subname,
317 much like looking at (caller($i))[3] until you find a real sub that
320 /* we may be in a higher stacklevel, so dig down deeper */
322 if(top_si->si_type == PERLSI_MAIN)
323 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
324 top_si = top_si->si_prev;
325 ccstack = top_si->si_cxstack;
326 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
329 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
330 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
331 cxix = __dopoptosub_at(ccstack, cxix - 1);
336 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
337 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
338 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
345 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
348 cxix = __dopoptosub_at(ccstack, cxix - 1);
352 /* we found a real sub here */
353 sv = sv_2mortal(newSV(0));
355 gv_efullname3(sv, cvgv, NULL);
357 fq_subname = SvPVX(sv);
358 fq_subname_len = SvCUR(sv);
360 subname = strrchr(fq_subname, ':');
362 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
365 subname_len = fq_subname_len - (subname - fq_subname);
366 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
367 cxix = __dopoptosub_at(ccstack, cxix - 1);
373 /* If we made it to here, we found our context */
375 /* cachekey = "objpkg|context::method::name" */
376 cachekey = sv_2mortal(newSVpv(hvname, 0));
377 sv_catpvn(cachekey, "|", 1);
378 sv_catsv(cachekey, sv);
380 nmcache = get_hv("next::METHOD_CACHE", 1);
381 if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
382 SV* val = HeVAL(cache_entry);
383 if(val == &PL_sv_undef) {
385 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
388 XPUSHs(sv_2mortal(newRV_inc(val)));
392 /* beyond here is just for cache misses, so perf isn't as critical */
394 stashname_len = subname - fq_subname - 2;
395 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
397 linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
399 linear_svp = AvARRAY(linear_av);
400 entries = AvFILLp(linear_av) + 1;
403 SV* const linear_sv = *linear_svp++;
405 if(sv_eq(linear_sv, stashname))
410 SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
411 HV* cc3_mro = get_hv("Class::C3::MRO", 0);
414 SV* const linear_sv = *linear_svp++;
418 HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
419 if(he_cc3_mro_class) {
420 SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
421 if(SvROK(cc3_mro_class_sv)) {
422 HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
423 SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
424 if(svp_cc3_mro_class_methods) {
425 SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
426 if(SvROK(cc3_mro_class_methods_sv)) {
427 HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
428 if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
436 cstash = gv_stashsv(linear_sv, FALSE);
439 if (ckWARN(WARN_MISC))
440 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
441 (void*)linear_sv, hvname);
447 gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
453 if (SvTYPE(candidate) != SVt_PVGV)
454 gv_init(candidate, cstash, subname, subname_len, TRUE);
455 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
456 SvREFCNT_dec(linear_av);
457 SvREFCNT_inc((SV*)cand_cv);
458 hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0);
459 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
465 SvREFCNT_dec(linear_av);
466 hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0);
468 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
472 XS(XS_Class_C3_XS_calculateMRO);
473 XS(XS_Class_C3_XS_calculateMRO)
485 if(items < 1 || items > 2)
486 croak("Usage: calculateMRO(classname[, cache])");
489 if(items == 2) cache = (HV*)SvRV(ST(1));
491 class_stash = gv_stashsv(classname, 0);
493 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
495 res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
497 res_items = ret_items = AvFILLp(res) + 1;
498 res_ptr = AvARRAY(res);
503 SV* res_item = *res_ptr++;
504 XPUSHs(sv_2mortal(newSVsv(res_item)));
513 XS(XS_Class_C3_XS_plsubgen);
514 XS(XS_Class_C3_XS_plsubgen)
519 XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
524 XS(XS_Class_C3_XS_calc_mdt);
525 XS(XS_Class_C3_XS_calc_mdt)
533 HV* our_c3mro; /* $Class::C3::MRO{classname} */
543 if(items < 1 || items > 2)
544 croak("Usage: calculate_method_dispatch_table(classname[, cache])");
547 class_stash = gv_stashsv(classname, 0);
549 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
551 if(items == 2) cache = (HV*)SvRV(ST(1));
553 class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
556 hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0);
558 hv = get_hv("Class::C3::MRO", 1);
559 hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0);
563 /* skip first entry */
564 mroitems = AvFILLp(class_mro);
565 svp = AvARRAY(class_mro) + 1;
567 SV* mro_class = *svp++;
568 HV* mro_stash = gv_stashsv(mro_class, 0);
570 if(!mro_stash) continue;
573 SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
574 if(ovfp) has_ovf = *ovfp;
577 hv_iterinit(mro_stash);
578 while(he = hv_iternext(mro_stash)) {
586 mskey = hv_iterkeysv(he);
587 if(hv_exists_ent(methods, mskey, 0)) continue;
589 msval = hv_iterval(mro_stash, he);
590 if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
593 if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
594 SV* val = HeVAL(ourent);
595 if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
600 orig = newSVsv(mro_class);
601 sv_catpvn(orig, "::", 2);
602 sv_catsv(orig, mskey);
603 hv_store(meth_hash, "orig", 4, orig, 0);
604 hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0);
605 hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0);
609 hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0);
610 if(has_ovf) hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0);
614 MODULE = Class::C3::XS PACKAGE = Class::C3::XS
617 newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
618 newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
619 newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
620 newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__);