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 if(!hv_store_ent(tails, seqitem, newSViv(1), 0)) {
148 croak("failed to store value in hash");
152 SV* const val = HeVAL(he);
159 /* Initialize retval to build the return value in */
161 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
163 /* This loop won't terminate until we either finish building
164 the MRO, or get an exception. */
170 /* "foreach $seq (@seqs)" */
171 SV** const avptr = AvARRAY(seqs);
172 for(s = 0; s <= AvFILLp(seqs); s++) {
174 AV * const seq = (AV*)(avptr[s]);
176 if(!seq) continue; /* skip empty seqs */
177 svp = av_fetch(seq, heads[s], 0);
178 seqhead = *svp; /* seqhead = head of this seq */
182 /* if we haven't found a winner for this round yet,
183 and this seqhead is not in tails (or the count
184 for it in tails has dropped to zero), then this
185 seqhead is our new winner, and is added to the
186 final MRO immediately */
188 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
189 && (val = HeVAL(tail_entry))
192 winner = newSVsv(cand);
193 av_push(retval, winner);
194 /* note however that even when we find a winner,
195 we continue looping over @seqs to do housekeeping */
197 if(!sv_cmp(seqhead, winner)) {
198 /* Once we have a winner (including the iteration
199 where we first found him), inc the head ptr
200 for any seq which had the winner as a head,
201 NULL out any seq which is now empty,
202 and adjust tails for consistency */
204 const int new_head = ++heads[s];
205 if(new_head > AvFILLp(seq)) {
206 SvREFCNT_dec(avptr[s]);
212 /* Because we know this new seqhead used to be
213 a tail, we can assume it is in tails and has
214 a positive value, which we need to dec */
215 svp = av_fetch(seq, new_head, 0);
217 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
218 val = HeVAL(tail_entry);
224 /* if we found no candidates, we are done building the MRO.
225 !cand means no seqs have any entries left to check */
231 /* If we had candidates, but nobody won, then the @ISA
232 hierarchy is not C3-incompatible */
236 /* we have to do some cleanup before we croak */
238 errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t"
239 "current merge results [\n", stashname);
240 for (i = 0; i <= av_len(retval); i++) {
241 SV **elem = av_fetch(retval, i, 0);
242 sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
244 sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
246 SvREFCNT_dec(retval);
249 croak("%"SVf, SVfARG(errmsg));
253 else { /* @ISA was undefined or empty */
254 /* build a retval containing only ourselves */
256 av_push(retval, newSVpvn(stashname, stashname_len));
259 /* we don't want anyone modifying the cache entry but us,
260 and we do so by replacing it completely */
261 SvREADONLY_on(retval);
263 if(!made_mortal_cache) {
264 SvREFCNT_inc(retval);
265 if(!hv_store(cache, stashname, stashname_len, (SV*)retval, 0)) {
266 croak("failed to store value in hash");
274 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
276 for (i = startingblock; i >= 0; i--) {
277 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
282 XS(XS_Class_C3_XS_nextcan);
283 XS(XS_Class_C3_XS_nextcan)
288 const I32 throw_nomethod = SvIVX(ST(1));
289 register I32 cxix = cxstack_ix;
290 register const PERL_CONTEXT *ccstack = cxstack;
291 const PERL_SI *top_si = PL_curstackinfo;
295 const char *fq_subname;
297 STRLEN fq_subname_len;
298 STRLEN stashname_len;
305 GV* candidate = NULL;
316 if(sv_isobject(self))
317 selfstash = SvSTASH(SvRV(self));
319 selfstash = gv_stashsv(self, 0);
323 hvname = HvNAME(selfstash);
325 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
327 /* This block finds the contextually-enclosing fully-qualified subname,
328 much like looking at (caller($i))[3] until you find a real sub that
329 isn't ANON, etc (also skips over pureperl next::method, etc) */
330 for(i = 0; i < 2; i++) {
331 cxix = __dopoptosub_at(ccstack, cxix);
333 /* we may be in a higher stacklevel, so dig down deeper */
335 if(top_si->si_type == PERLSI_MAIN)
336 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
337 top_si = top_si->si_prev;
338 ccstack = top_si->si_cxstack;
339 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
342 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
343 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
344 cxix = __dopoptosub_at(ccstack, cxix - 1);
349 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
350 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
351 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
358 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
361 cxix = __dopoptosub_at(ccstack, cxix - 1);
365 /* we found a real sub here */
366 sv = sv_2mortal(newSV(0));
368 gv_efullname3(sv, cvgv, NULL);
370 fq_subname = SvPVX(sv);
371 fq_subname_len = SvCUR(sv);
373 subname = strrchr(fq_subname, ':');
375 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
378 subname_len = fq_subname_len - (subname - fq_subname);
379 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
380 cxix = __dopoptosub_at(ccstack, cxix - 1);
388 /* If we made it to here, we found our context */
390 /* cachekey = "objpkg|context::method::name" */
391 cachekey = sv_2mortal(newSVpv(hvname, 0));
392 sv_catpvn(cachekey, "|", 1);
393 sv_catsv(cachekey, sv);
395 nmcache = get_hv("next::METHOD_CACHE", 1);
396 if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
397 SV* val = HeVAL(cache_entry);
398 if(val == &PL_sv_undef) {
400 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
403 XPUSHs(sv_2mortal(newRV_inc(val)));
407 /* beyond here is just for cache misses, so perf isn't as critical */
409 stashname_len = subname - fq_subname - 2;
410 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
412 linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
414 linear_svp = AvARRAY(linear_av);
415 entries = AvFILLp(linear_av) + 1;
418 SV* const linear_sv = *linear_svp++;
420 if(sv_eq(linear_sv, stashname))
425 SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
426 HV* cc3_mro = get_hv("Class::C3::MRO", 0);
429 SV* const linear_sv = *linear_svp++;
433 HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
434 if(he_cc3_mro_class) {
435 SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
436 if(SvROK(cc3_mro_class_sv)) {
437 HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
438 SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
439 if(svp_cc3_mro_class_methods) {
440 SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
441 if(SvROK(cc3_mro_class_methods_sv)) {
442 HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
443 if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
451 cstash = gv_stashsv(linear_sv, FALSE);
454 if (ckWARN(WARN_MISC))
455 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
456 (void*)linear_sv, hvname);
462 gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
468 if (SvTYPE(candidate) != SVt_PVGV)
469 gv_init(candidate, cstash, subname, subname_len, TRUE);
470 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
471 SvREFCNT_dec(linear_av);
472 SvREFCNT_inc((SV*)cand_cv);
473 if (!hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0)) {
474 croak("failed to store value in hash");
476 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
482 SvREFCNT_dec(linear_av);
483 if (!hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0)) {
484 croak("failed to store value in hash");
487 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
491 XS(XS_Class_C3_XS_calculateMRO);
492 XS(XS_Class_C3_XS_calculateMRO)
504 if(items < 1 || items > 2)
505 croak("Usage: calculateMRO(classname[, cache])");
508 if(items == 2) cache = (HV*)SvRV(ST(1));
510 class_stash = gv_stashsv(classname, 0);
512 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
514 res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
516 res_items = ret_items = AvFILLp(res) + 1;
517 res_ptr = AvARRAY(res);
522 SV* res_item = *res_ptr++;
523 XPUSHs(sv_2mortal(newSVsv(res_item)));
532 XS(XS_Class_C3_XS_plsubgen);
533 XS(XS_Class_C3_XS_plsubgen)
538 XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
543 XS(XS_Class_C3_XS_calc_mdt);
544 XS(XS_Class_C3_XS_calc_mdt)
552 HV* our_c3mro; /* $Class::C3::MRO{classname} */
562 if(items < 1 || items > 2)
563 croak("Usage: calculate_method_dispatch_table(classname[, cache])");
566 class_stash = gv_stashsv(classname, 0);
568 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
570 if(items == 2) cache = (HV*)SvRV(ST(1));
572 class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
575 if(!hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0)) {
576 croak("failed to store value in hash");
579 hv = get_hv("Class::C3::MRO", 1);
580 if(!hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0)) {
581 croak("failed to store value in hash");
586 /* skip first entry */
587 mroitems = AvFILLp(class_mro);
588 svp = AvARRAY(class_mro) + 1;
590 SV* mro_class = *svp++;
591 HV* mro_stash = gv_stashsv(mro_class, 0);
593 if(!mro_stash) continue;
596 SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
597 if(ovfp) has_ovf = *ovfp;
600 hv_iterinit(mro_stash);
601 while((he = hv_iternext(mro_stash))) {
609 mskey = hv_iterkeysv(he);
610 if(hv_exists_ent(methods, mskey, 0)) continue;
612 msval = hv_iterval(mro_stash, he);
613 if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
616 if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
617 SV* val = HeVAL(ourent);
618 if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
623 orig = newSVsv(mro_class);
624 sv_catpvn(orig, "::", 2);
625 sv_catsv(orig, mskey);
626 if( !hv_store(meth_hash, "orig", 4, orig, 0)
627 || !hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0)
628 || !hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0) ) {
629 croak("failed to store value in hash");
634 if(!hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0)) {
635 croak("failed to store value in hash");
638 if(!hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0)) {
639 croak("failed to store value in hash");
645 MODULE = Class::C3::XS PACKAGE = Class::C3::XS
650 newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
651 newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
652 newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
653 newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__);