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 */
54 # define SVfARG(p) ((void*)(p))
57 /* Most of this code is backported from the bleadperl patch's
58 mro.c, and then modified to work with Class::C3's
63 __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level)
69 const char* stashname;
71 I32 made_mortal_cache = 0;
75 stashname = HvNAME(stash);
76 stashname_len = strlen(stashname);
79 "Can't linearize anonymous symbol table");
82 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
86 cache = (HV*)sv_2mortal((SV*)newHV());
87 made_mortal_cache = 1;
90 SV** cache_entry = hv_fetch(cache, stashname, stashname_len, 0);
92 return (AV*)SvREFCNT_inc(*cache_entry);
95 /* not in cache, make a new one */
97 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
98 isa = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
99 if(isa && AvFILLp(isa) >= 0) {
103 AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
106 /* This builds @seqs, which is an array of arrays.
107 The members of @seqs are the MROs of
108 the members of @ISA, followed by @ISA itself.
110 I32 items = AvFILLp(isa) + 1;
111 SV** isa_ptr = AvARRAY(isa);
113 SV* const isa_item = *isa_ptr++;
114 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
115 if(!isa_item_stash) {
116 /* if no stash, make a temporary fake MRO
117 containing just itself */
118 AV* const isa_lin = newAV();
119 av_push(isa_lin, newSVsv(isa_item));
120 av_push(seqs, (SV*)isa_lin);
124 AV* const isa_lin = __mro_linear_isa_c3(aTHX_ isa_item_stash, cache, level + 1);
126 if(items == 0 && AvFILLp(seqs) == -1) {
127 /* Only one parent class. For this case, the C3
128 linearisation is this class followed by the parent's
129 linearisation, so don't bother with the expensive
132 I32 subrv_items = AvFILLp(isa_lin) + 1;
133 SV *const *subrv_p = AvARRAY(isa_lin);
135 /* Hijack the allocated but unused array seqs to be the
136 return value. It's currently mortalised. */
140 av_extend(retval, subrv_items);
141 AvFILLp(retval) = subrv_items;
142 svp = AvARRAY(retval);
144 /* First entry is this class. */
145 *svp++ = newSVpvn(stashname, stashname_len);
147 while(subrv_items--) {
148 /* These values are unlikely to be shared hash key
149 scalars, so no point in adding code to optimising
150 for a case that is unlikely to be true.
151 (Or prove me wrong and do it.) */
153 SV *const val = *subrv_p++;
154 *svp++ = newSVsv(val);
157 SvREFCNT_dec(isa_lin);
158 SvREFCNT_inc(retval);
162 av_push(seqs, (SV*)isa_lin);
165 av_push(seqs, SvREFCNT_inc((SV*)isa));
166 tails = (HV*)sv_2mortal((SV*)newHV());
168 /* This builds "heads", which as an array of integer array
169 indices, one per seq, which point at the virtual "head"
170 of the seq (initially zero) */
171 Newz(0xdead, heads, AvFILLp(seqs)+1, I32);
173 /* This builds %tails, which has one key for every class
174 mentioned in the tail of any sequence in @seqs (tail meaning
175 everything after the first class, the "head"). The value
176 is how many times this key appears in the tails of @seqs.
178 seqs_ptr = AvARRAY(seqs);
179 seqs_items = AvFILLp(seqs) + 1;
180 while(seqs_items--) {
181 AV* const seq = (AV*)*seqs_ptr++;
182 I32 seq_items = AvFILLp(seq);
184 SV** seq_ptr = AvARRAY(seq) + 1;
186 SV* const seqitem = *seq_ptr++;
187 /* LVALUE fetch will create a new undefined SV if necessary
189 HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
191 SV* const val = HeVAL(he);
192 /* For 5.8.0 and later, sv_inc() with increment undef to
193 an IV of 1, which is what we want for a newly created
194 entry. However, for 5.6.x it will become an NV of
195 1.0, which confuses the SvIVX() checks above */
202 croak("failed to store value in hash");
208 /* Initialize retval to build the return value in */
210 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
212 /* This loop won't terminate until we either finish building
213 the MRO, or get an exception. */
219 /* "foreach $seq (@seqs)" */
220 SV** const avptr = AvARRAY(seqs);
221 for(s = 0; s <= AvFILLp(seqs); s++) {
223 AV * const seq = (AV*)(avptr[s]);
225 if(!seq) continue; /* skip empty seqs */
226 svp = av_fetch(seq, heads[s], 0);
227 seqhead = *svp; /* seqhead = head of this seq */
231 /* if we haven't found a winner for this round yet,
232 and this seqhead is not in tails (or the count
233 for it in tails has dropped to zero), then this
234 seqhead is our new winner, and is added to the
235 final MRO immediately */
237 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
238 && (val = HeVAL(tail_entry))
241 winner = newSVsv(cand);
242 av_push(retval, winner);
243 /* note however that even when we find a winner,
244 we continue looping over @seqs to do housekeeping */
246 if(!sv_cmp(seqhead, winner)) {
247 /* Once we have a winner (including the iteration
248 where we first found him), inc the head ptr
249 for any seq which had the winner as a head,
250 NULL out any seq which is now empty,
251 and adjust tails for consistency */
253 const int new_head = ++heads[s];
254 if(new_head > AvFILLp(seq)) {
255 SvREFCNT_dec(avptr[s]);
261 /* Because we know this new seqhead used to be
262 a tail, we can assume it is in tails and has
263 a positive value, which we need to dec */
264 svp = av_fetch(seq, new_head, 0);
266 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
267 val = HeVAL(tail_entry);
273 /* if we found no candidates, we are done building the MRO.
274 !cand means no seqs have any entries left to check */
280 /* If we had candidates, but nobody won, then the @ISA
281 hierarchy is not C3-incompatible */
285 /* we have to do some cleanup before we croak */
287 errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t"
288 "current merge results [\n", stashname);
289 for (i = 0; i <= av_len(retval); i++) {
290 SV **elem = av_fetch(retval, i, 0);
291 sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
293 sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
295 SvREFCNT_dec(retval);
298 croak("%"SVf, SVfARG(errmsg));
302 else { /* @ISA was undefined or empty */
303 /* build a retval containing only ourselves */
305 av_push(retval, newSVpvn(stashname, stashname_len));
309 /* we don't want anyone modifying the cache entry but us,
310 and we do so by replacing it completely */
311 SvREADONLY_on(retval);
313 if(!made_mortal_cache) {
314 SvREFCNT_inc(retval);
315 if(!hv_store(cache, stashname, stashname_len, (SV*)retval, 0)) {
316 croak("failed to store value in hash");
324 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
326 for (i = startingblock; i >= 0; i--) {
327 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
332 XS(XS_Class_C3_XS_nextcan);
333 XS(XS_Class_C3_XS_nextcan)
338 const I32 throw_nomethod = SvIVX(ST(1));
339 register I32 cxix = cxstack_ix;
340 register const PERL_CONTEXT *ccstack = cxstack;
341 const PERL_SI *top_si = PL_curstackinfo;
345 const char *fq_subname;
347 STRLEN fq_subname_len;
348 STRLEN stashname_len;
355 GV* candidate = NULL;
366 if(sv_isobject(self))
367 selfstash = SvSTASH(SvRV(self));
369 selfstash = gv_stashsv(self, 0);
373 hvname = HvNAME(selfstash);
375 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
377 /* This block finds the contextually-enclosing fully-qualified subname,
378 much like looking at (caller($i))[3] until you find a real sub that
379 isn't ANON, etc (also skips over pureperl next::method, etc) */
380 for(i = 0; i < 2; i++) {
381 cxix = __dopoptosub_at(ccstack, cxix);
383 /* we may be in a higher stacklevel, so dig down deeper */
385 if(top_si->si_type == PERLSI_MAIN)
386 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
387 top_si = top_si->si_prev;
388 ccstack = top_si->si_cxstack;
389 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
392 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
393 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
394 cxix = __dopoptosub_at(ccstack, cxix - 1);
399 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
400 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
401 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
408 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
411 cxix = __dopoptosub_at(ccstack, cxix - 1);
415 /* we found a real sub here */
418 gv_efullname3(sv, cvgv, NULL);
421 fq_subname = SvPVX(sv);
422 fq_subname_len = SvCUR(sv);
424 subname = strrchr(fq_subname, ':');
429 subname = strrchr(fq_subname, ':');
431 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
434 subname_len = fq_subname_len - (subname - fq_subname);
435 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
436 cxix = __dopoptosub_at(ccstack, cxix - 1);
444 /* If we made it to here, we found our context */
446 /* cachekey = "objpkg|context::method::name" */
447 cachekey = sv_2mortal(newSVpv(hvname, 0));
448 sv_catpvn(cachekey, "|", 1);
449 sv_catsv(cachekey, sv);
451 nmcache = get_hv("next::METHOD_CACHE", 1);
452 if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
453 SV* val = HeVAL(cache_entry);
454 if(val == &PL_sv_undef) {
456 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
459 XPUSHs(sv_2mortal(newRV_inc(val)));
463 /* beyond here is just for cache misses, so perf isn't as critical */
465 stashname_len = subname - fq_subname - 2;
466 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
468 linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
470 linear_svp = AvARRAY(linear_av);
471 entries = AvFILLp(linear_av) + 1;
474 SV* const linear_sv = *linear_svp++;
476 if(sv_eq(linear_sv, stashname))
481 SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
482 HV* cc3_mro = get_hv("Class::C3::MRO", 0);
485 SV* const linear_sv = *linear_svp++;
489 HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
490 if(he_cc3_mro_class) {
491 SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
492 if(SvROK(cc3_mro_class_sv)) {
493 HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
494 SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
495 if(svp_cc3_mro_class_methods) {
496 SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
497 if(SvROK(cc3_mro_class_methods_sv)) {
498 HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
499 if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
507 cstash = gv_stashsv(linear_sv, FALSE);
510 if (ckWARN(WARN_MISC))
511 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
512 (void*)linear_sv, hvname);
518 gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
524 if (SvTYPE(candidate) != SVt_PVGV)
525 gv_init(candidate, cstash, subname, subname_len, TRUE);
526 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
527 SvREFCNT_dec(linear_av);
528 SvREFCNT_inc((SV*)cand_cv);
529 if (!hv_store_ent(nmcache, cachekey, (SV*)cand_cv, 0)) {
530 croak("failed to store value in hash");
532 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
538 SvREFCNT_dec(linear_av);
539 if (!hv_store_ent(nmcache, cachekey, &PL_sv_undef, 0)) {
540 croak("failed to store value in hash");
543 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
547 XS(XS_Class_C3_XS_calculateMRO);
548 XS(XS_Class_C3_XS_calculateMRO)
560 if(items < 1 || items > 2)
561 croak("Usage: calculateMRO(classname[, cache])");
564 if(items == 2) cache = (HV*)SvRV(ST(1));
566 class_stash = gv_stashsv(classname, 0);
568 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
570 res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
572 res_items = ret_items = AvFILLp(res) + 1;
573 res_ptr = AvARRAY(res);
578 SV* res_item = *res_ptr++;
579 XPUSHs(sv_2mortal(newSVsv(res_item)));
588 XS(XS_Class_C3_XS_plsubgen);
589 XS(XS_Class_C3_XS_plsubgen)
594 XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
599 XS(XS_Class_C3_XS_calc_mdt);
600 XS(XS_Class_C3_XS_calc_mdt)
608 HV* our_c3mro; /* $Class::C3::MRO{classname} */
618 if(items < 1 || items > 2)
619 croak("Usage: calculate_method_dispatch_table(classname[, cache])");
622 class_stash = gv_stashsv(classname, 0);
624 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
626 if(items == 2) cache = (HV*)SvRV(ST(1));
628 class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
631 if(!hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0)) {
632 croak("failed to store value in hash");
635 hv = get_hv("Class::C3::MRO", 1);
636 if(!hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0)) {
637 croak("failed to store value in hash");
642 /* skip first entry */
643 mroitems = AvFILLp(class_mro);
644 svp = AvARRAY(class_mro) + 1;
646 SV* mro_class = *svp++;
647 HV* mro_stash = gv_stashsv(mro_class, 0);
649 if(!mro_stash) continue;
652 SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
653 if(ovfp) has_ovf = *ovfp;
656 hv_iterinit(mro_stash);
657 while((he = hv_iternext(mro_stash))) {
665 mskey = hv_iterkeysv(he);
666 if(hv_exists_ent(methods, mskey, 0)) continue;
668 msval = hv_iterval(mro_stash, he);
669 if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
672 if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
673 SV* val = HeVAL(ourent);
674 if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
679 orig = newSVsv(mro_class);
680 sv_catpvn(orig, "::", 2);
681 sv_catsv(orig, mskey);
682 if( !hv_store(meth_hash, "orig", 4, orig, 0)
683 || !hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0)
684 || !hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0) ) {
685 croak("failed to store value in hash");
690 if(!hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0)) {
691 croak("failed to store value in hash");
694 if(!hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0)) {
695 croak("failed to store value in hash");
701 MODULE = Class::C3::XS PACKAGE = Class::C3::XS
706 newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
707 newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
708 newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
709 newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__);