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));
276 register I32 cxix = cxstack_ix;
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;
303 if(sv_isobject(self))
304 selfstash = SvSTASH(SvRV(self));
306 selfstash = gv_stashsv(self, 0);
310 hvname = HvNAME(selfstash);
312 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
314 /* This block finds the contextually-enclosing fully-qualified subname,
315 much like looking at (caller($i))[3] until you find a real sub that
316 isn't ANON, etc (also skips over pureperl next::method, etc) */
317 for(i = 0; i < 2; i++) {
318 cxix = __dopoptosub_at(ccstack, cxix);
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);
375 /* If we made it to here, we found our context */
377 /* cachekey = "objpkg|context::method::name" */
378 cachekey = sv_2mortal(newSVpv(hvname, 0));
379 sv_catpvn(cachekey, "|", 1);
380 sv_catsv(cachekey, sv);
382 nmcache = get_hv("next::METHOD_CACHE", 1);
383 if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
384 SV* val = HeVAL(cache_entry);
385 if(val == &PL_sv_undef) {
387 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
390 XPUSHs(sv_2mortal(newRV_inc(val)));
394 /* beyond here is just for cache misses, so perf isn't as critical */
396 stashname_len = subname - fq_subname - 2;
397 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
399 linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
401 linear_svp = AvARRAY(linear_av);
402 entries = AvFILLp(linear_av) + 1;
405 SV* const linear_sv = *linear_svp++;
407 if(sv_eq(linear_sv, stashname))
412 SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
413 HV* cc3_mro = get_hv("Class::C3::MRO", 0);
416 SV* const linear_sv = *linear_svp++;
420 HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
421 if(he_cc3_mro_class) {
422 SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
423 if(SvROK(cc3_mro_class_sv)) {
424 HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
425 SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
426 if(svp_cc3_mro_class_methods) {
427 SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
428 if(SvROK(cc3_mro_class_methods_sv)) {
429 HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
430 if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
438 cstash = gv_stashsv(linear_sv, FALSE);
441 if (ckWARN(WARN_MISC))
442 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
443 (void*)linear_sv, hvname);
449 gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
455 if (SvTYPE(candidate) != SVt_PVGV)
456 gv_init(candidate, cstash, subname, subname_len, TRUE);
457 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
458 SvREFCNT_dec(linear_av);
459 SvREFCNT_inc((SV*)cand_cv);
460 hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0);
461 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
467 SvREFCNT_dec(linear_av);
468 hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0);
470 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
474 XS(XS_Class_C3_XS_calculateMRO);
475 XS(XS_Class_C3_XS_calculateMRO)
487 if(items < 1 || items > 2)
488 croak("Usage: calculateMRO(classname[, cache])");
491 if(items == 2) cache = (HV*)SvRV(ST(1));
493 class_stash = gv_stashsv(classname, 0);
495 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
497 res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
499 res_items = ret_items = AvFILLp(res) + 1;
500 res_ptr = AvARRAY(res);
505 SV* res_item = *res_ptr++;
506 XPUSHs(sv_2mortal(newSVsv(res_item)));
515 XS(XS_Class_C3_XS_plsubgen);
516 XS(XS_Class_C3_XS_plsubgen)
521 XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
526 XS(XS_Class_C3_XS_calc_mdt);
527 XS(XS_Class_C3_XS_calc_mdt)
535 HV* our_c3mro; /* $Class::C3::MRO{classname} */
545 if(items < 1 || items > 2)
546 croak("Usage: calculate_method_dispatch_table(classname[, cache])");
549 class_stash = gv_stashsv(classname, 0);
551 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
553 if(items == 2) cache = (HV*)SvRV(ST(1));
555 class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
558 hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0);
560 hv = get_hv("Class::C3::MRO", 1);
561 hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0);
565 /* skip first entry */
566 mroitems = AvFILLp(class_mro);
567 svp = AvARRAY(class_mro) + 1;
569 SV* mro_class = *svp++;
570 HV* mro_stash = gv_stashsv(mro_class, 0);
572 if(!mro_stash) continue;
575 SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
576 if(ovfp) has_ovf = *ovfp;
579 hv_iterinit(mro_stash);
580 while(he = hv_iternext(mro_stash)) {
588 mskey = hv_iterkeysv(he);
589 if(hv_exists_ent(methods, mskey, 0)) continue;
591 msval = hv_iterval(mro_stash, he);
592 if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
595 if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
596 SV* val = HeVAL(ourent);
597 if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
602 orig = newSVsv(mro_class);
603 sv_catpvn(orig, "::", 2);
604 sv_catsv(orig, mskey);
605 hv_store(meth_hash, "orig", 4, orig, 0);
606 hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0);
607 hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0);
611 hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0);
612 if(has_ovf) hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0);
616 MODULE = Class::C3::XS PACKAGE = Class::C3::XS
619 newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
620 newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
621 newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
622 newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__);