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) {
102 HV* const tails = (HV*)sv_2mortal((SV*)newHV());
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);
125 av_push(seqs, (SV*)isa_lin);
128 av_push(seqs, SvREFCNT_inc((SV*)isa));
130 /* This builds "heads", which as an array of integer array
131 indices, one per seq, which point at the virtual "head"
132 of the seq (initially zero) */
133 Newz(0xdead, heads, AvFILLp(seqs)+1, I32);
135 /* This builds %tails, which has one key for every class
136 mentioned in the tail of any sequence in @seqs (tail meaning
137 everything after the first class, the "head"). The value
138 is how many times this key appears in the tails of @seqs.
140 seqs_ptr = AvARRAY(seqs);
141 seqs_items = AvFILLp(seqs) + 1;
142 while(seqs_items--) {
143 AV* const seq = (AV*)*seqs_ptr++;
144 I32 seq_items = AvFILLp(seq);
146 SV** seq_ptr = AvARRAY(seq) + 1;
148 SV* const seqitem = *seq_ptr++;
149 HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
151 if(!hv_store_ent(tails, seqitem, newSViv(1), 0)) {
152 croak("failed to store value in hash");
156 SV* const val = HeVAL(he);
163 /* Initialize retval to build the return value in */
165 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
167 /* This loop won't terminate until we either finish building
168 the MRO, or get an exception. */
174 /* "foreach $seq (@seqs)" */
175 SV** const avptr = AvARRAY(seqs);
176 for(s = 0; s <= AvFILLp(seqs); s++) {
178 AV * const seq = (AV*)(avptr[s]);
180 if(!seq) continue; /* skip empty seqs */
181 svp = av_fetch(seq, heads[s], 0);
182 seqhead = *svp; /* seqhead = head of this seq */
186 /* if we haven't found a winner for this round yet,
187 and this seqhead is not in tails (or the count
188 for it in tails has dropped to zero), then this
189 seqhead is our new winner, and is added to the
190 final MRO immediately */
192 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
193 && (val = HeVAL(tail_entry))
196 winner = newSVsv(cand);
197 av_push(retval, winner);
198 /* note however that even when we find a winner,
199 we continue looping over @seqs to do housekeeping */
201 if(!sv_cmp(seqhead, winner)) {
202 /* Once we have a winner (including the iteration
203 where we first found him), inc the head ptr
204 for any seq which had the winner as a head,
205 NULL out any seq which is now empty,
206 and adjust tails for consistency */
208 const int new_head = ++heads[s];
209 if(new_head > AvFILLp(seq)) {
210 SvREFCNT_dec(avptr[s]);
216 /* Because we know this new seqhead used to be
217 a tail, we can assume it is in tails and has
218 a positive value, which we need to dec */
219 svp = av_fetch(seq, new_head, 0);
221 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
222 val = HeVAL(tail_entry);
228 /* if we found no candidates, we are done building the MRO.
229 !cand means no seqs have any entries left to check */
235 /* If we had candidates, but nobody won, then the @ISA
236 hierarchy is not C3-incompatible */
240 /* we have to do some cleanup before we croak */
242 errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t"
243 "current merge results [\n", stashname);
244 for (i = 0; i <= av_len(retval); i++) {
245 SV **elem = av_fetch(retval, i, 0);
246 sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
248 sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
250 SvREFCNT_dec(retval);
253 croak("%"SVf, SVfARG(errmsg));
257 else { /* @ISA was undefined or empty */
258 /* build a retval containing only ourselves */
260 av_push(retval, newSVpvn(stashname, stashname_len));
263 /* we don't want anyone modifying the cache entry but us,
264 and we do so by replacing it completely */
265 SvREADONLY_on(retval);
267 if(!made_mortal_cache) {
268 SvREFCNT_inc(retval);
269 if(!hv_store(cache, stashname, stashname_len, (SV*)retval, 0)) {
270 croak("failed to store value in hash");
278 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
280 for (i = startingblock; i >= 0; i--) {
281 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
286 XS(XS_Class_C3_XS_nextcan);
287 XS(XS_Class_C3_XS_nextcan)
292 const I32 throw_nomethod = SvIVX(ST(1));
293 register I32 cxix = cxstack_ix;
294 register const PERL_CONTEXT *ccstack = cxstack;
295 const PERL_SI *top_si = PL_curstackinfo;
299 const char *fq_subname;
301 STRLEN fq_subname_len;
302 STRLEN stashname_len;
309 GV* candidate = NULL;
320 if(sv_isobject(self))
321 selfstash = SvSTASH(SvRV(self));
323 selfstash = gv_stashsv(self, 0);
327 hvname = HvNAME(selfstash);
329 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
331 /* This block finds the contextually-enclosing fully-qualified subname,
332 much like looking at (caller($i))[3] until you find a real sub that
333 isn't ANON, etc (also skips over pureperl next::method, etc) */
334 for(i = 0; i < 2; i++) {
335 cxix = __dopoptosub_at(ccstack, cxix);
337 /* we may be in a higher stacklevel, so dig down deeper */
339 if(top_si->si_type == PERLSI_MAIN)
340 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
341 top_si = top_si->si_prev;
342 ccstack = top_si->si_cxstack;
343 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
346 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
347 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
348 cxix = __dopoptosub_at(ccstack, cxix - 1);
353 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
354 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
355 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
362 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
365 cxix = __dopoptosub_at(ccstack, cxix - 1);
369 /* we found a real sub here */
370 sv = sv_2mortal(newSV(0));
372 gv_efullname3(sv, cvgv, NULL);
374 fq_subname = SvPVX(sv);
375 fq_subname_len = SvCUR(sv);
377 subname = strrchr(fq_subname, ':');
379 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
382 subname_len = fq_subname_len - (subname - fq_subname);
383 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
384 cxix = __dopoptosub_at(ccstack, cxix - 1);
392 /* If we made it to here, we found our context */
394 /* cachekey = "objpkg|context::method::name" */
395 cachekey = sv_2mortal(newSVpv(hvname, 0));
396 sv_catpvn(cachekey, "|", 1);
397 sv_catsv(cachekey, sv);
399 nmcache = get_hv("next::METHOD_CACHE", 1);
400 if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
401 SV* val = HeVAL(cache_entry);
402 if(val == &PL_sv_undef) {
404 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
407 XPUSHs(sv_2mortal(newRV_inc(val)));
411 /* beyond here is just for cache misses, so perf isn't as critical */
413 stashname_len = subname - fq_subname - 2;
414 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
416 linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
418 linear_svp = AvARRAY(linear_av);
419 entries = AvFILLp(linear_av) + 1;
422 SV* const linear_sv = *linear_svp++;
424 if(sv_eq(linear_sv, stashname))
429 SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
430 HV* cc3_mro = get_hv("Class::C3::MRO", 0);
433 SV* const linear_sv = *linear_svp++;
437 HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
438 if(he_cc3_mro_class) {
439 SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
440 if(SvROK(cc3_mro_class_sv)) {
441 HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
442 SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
443 if(svp_cc3_mro_class_methods) {
444 SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
445 if(SvROK(cc3_mro_class_methods_sv)) {
446 HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
447 if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
455 cstash = gv_stashsv(linear_sv, FALSE);
458 if (ckWARN(WARN_MISC))
459 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
460 (void*)linear_sv, hvname);
466 gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
472 if (SvTYPE(candidate) != SVt_PVGV)
473 gv_init(candidate, cstash, subname, subname_len, TRUE);
474 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
475 SvREFCNT_dec(linear_av);
476 SvREFCNT_inc((SV*)cand_cv);
477 if (!hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0)) {
478 croak("failed to store value in hash");
480 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
486 SvREFCNT_dec(linear_av);
487 if (!hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0)) {
488 croak("failed to store value in hash");
491 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
495 XS(XS_Class_C3_XS_calculateMRO);
496 XS(XS_Class_C3_XS_calculateMRO)
508 if(items < 1 || items > 2)
509 croak("Usage: calculateMRO(classname[, cache])");
512 if(items == 2) cache = (HV*)SvRV(ST(1));
514 class_stash = gv_stashsv(classname, 0);
516 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
518 res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
520 res_items = ret_items = AvFILLp(res) + 1;
521 res_ptr = AvARRAY(res);
526 SV* res_item = *res_ptr++;
527 XPUSHs(sv_2mortal(newSVsv(res_item)));
536 XS(XS_Class_C3_XS_plsubgen);
537 XS(XS_Class_C3_XS_plsubgen)
542 XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
547 XS(XS_Class_C3_XS_calc_mdt);
548 XS(XS_Class_C3_XS_calc_mdt)
556 HV* our_c3mro; /* $Class::C3::MRO{classname} */
566 if(items < 1 || items > 2)
567 croak("Usage: calculate_method_dispatch_table(classname[, cache])");
570 class_stash = gv_stashsv(classname, 0);
572 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
574 if(items == 2) cache = (HV*)SvRV(ST(1));
576 class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
579 if(!hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0)) {
580 croak("failed to store value in hash");
583 hv = get_hv("Class::C3::MRO", 1);
584 if(!hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0)) {
585 croak("failed to store value in hash");
590 /* skip first entry */
591 mroitems = AvFILLp(class_mro);
592 svp = AvARRAY(class_mro) + 1;
594 SV* mro_class = *svp++;
595 HV* mro_stash = gv_stashsv(mro_class, 0);
597 if(!mro_stash) continue;
600 SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
601 if(ovfp) has_ovf = *ovfp;
604 hv_iterinit(mro_stash);
605 while((he = hv_iternext(mro_stash))) {
613 mskey = hv_iterkeysv(he);
614 if(hv_exists_ent(methods, mskey, 0)) continue;
616 msval = hv_iterval(mro_stash, he);
617 if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
620 if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
621 SV* val = HeVAL(ourent);
622 if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
627 orig = newSVsv(mro_class);
628 sv_catpvn(orig, "::", 2);
629 sv_catsv(orig, mskey);
630 if( !hv_store(meth_hash, "orig", 4, orig, 0)
631 || !hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0)
632 || !hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0) ) {
633 croak("failed to store value in hash");
638 if(!hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0)) {
639 croak("failed to store value in hash");
642 if(!hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0)) {
643 croak("failed to store value in hash");
649 MODULE = Class::C3::XS PACKAGE = Class::C3::XS
654 newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
655 newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
656 newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
657 newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__);