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 /* This will increment undef to 1, which is what we
193 want for a newly created entry. */
196 croak("failed to store value in hash");
202 /* Initialize retval to build the return value in */
204 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
206 /* This loop won't terminate until we either finish building
207 the MRO, or get an exception. */
213 /* "foreach $seq (@seqs)" */
214 SV** const avptr = AvARRAY(seqs);
215 for(s = 0; s <= AvFILLp(seqs); s++) {
217 AV * const seq = (AV*)(avptr[s]);
219 if(!seq) continue; /* skip empty seqs */
220 svp = av_fetch(seq, heads[s], 0);
221 seqhead = *svp; /* seqhead = head of this seq */
225 /* if we haven't found a winner for this round yet,
226 and this seqhead is not in tails (or the count
227 for it in tails has dropped to zero), then this
228 seqhead is our new winner, and is added to the
229 final MRO immediately */
231 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
232 && (val = HeVAL(tail_entry))
235 winner = newSVsv(cand);
236 av_push(retval, winner);
237 /* note however that even when we find a winner,
238 we continue looping over @seqs to do housekeeping */
240 if(!sv_cmp(seqhead, winner)) {
241 /* Once we have a winner (including the iteration
242 where we first found him), inc the head ptr
243 for any seq which had the winner as a head,
244 NULL out any seq which is now empty,
245 and adjust tails for consistency */
247 const int new_head = ++heads[s];
248 if(new_head > AvFILLp(seq)) {
249 SvREFCNT_dec(avptr[s]);
255 /* Because we know this new seqhead used to be
256 a tail, we can assume it is in tails and has
257 a positive value, which we need to dec */
258 svp = av_fetch(seq, new_head, 0);
260 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
261 val = HeVAL(tail_entry);
267 /* if we found no candidates, we are done building the MRO.
268 !cand means no seqs have any entries left to check */
274 /* If we had candidates, but nobody won, then the @ISA
275 hierarchy is not C3-incompatible */
279 /* we have to do some cleanup before we croak */
281 errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t"
282 "current merge results [\n", stashname);
283 for (i = 0; i <= av_len(retval); i++) {
284 SV **elem = av_fetch(retval, i, 0);
285 sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
287 sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
289 SvREFCNT_dec(retval);
292 croak("%"SVf, SVfARG(errmsg));
296 else { /* @ISA was undefined or empty */
297 /* build a retval containing only ourselves */
299 av_push(retval, newSVpvn(stashname, stashname_len));
303 /* we don't want anyone modifying the cache entry but us,
304 and we do so by replacing it completely */
305 SvREADONLY_on(retval);
307 if(!made_mortal_cache) {
308 SvREFCNT_inc(retval);
309 if(!hv_store(cache, stashname, stashname_len, (SV*)retval, 0)) {
310 croak("failed to store value in hash");
318 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
320 for (i = startingblock; i >= 0; i--) {
321 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
326 XS(XS_Class_C3_XS_nextcan);
327 XS(XS_Class_C3_XS_nextcan)
332 const I32 throw_nomethod = SvIVX(ST(1));
333 register I32 cxix = cxstack_ix;
334 register const PERL_CONTEXT *ccstack = cxstack;
335 const PERL_SI *top_si = PL_curstackinfo;
339 const char *fq_subname;
341 STRLEN fq_subname_len;
342 STRLEN stashname_len;
349 GV* candidate = NULL;
360 if(sv_isobject(self))
361 selfstash = SvSTASH(SvRV(self));
363 selfstash = gv_stashsv(self, 0);
367 hvname = HvNAME(selfstash);
369 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
371 /* This block finds the contextually-enclosing fully-qualified subname,
372 much like looking at (caller($i))[3] until you find a real sub that
373 isn't ANON, etc (also skips over pureperl next::method, etc) */
374 for(i = 0; i < 2; i++) {
375 cxix = __dopoptosub_at(ccstack, cxix);
377 /* we may be in a higher stacklevel, so dig down deeper */
379 if(top_si->si_type == PERLSI_MAIN)
380 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
381 top_si = top_si->si_prev;
382 ccstack = top_si->si_cxstack;
383 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
386 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
387 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
388 cxix = __dopoptosub_at(ccstack, cxix - 1);
393 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
394 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
395 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
402 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
405 cxix = __dopoptosub_at(ccstack, cxix - 1);
409 /* we found a real sub here */
412 gv_efullname3(sv, cvgv, NULL);
415 fq_subname = SvPVX(sv);
416 fq_subname_len = SvCUR(sv);
418 subname = strrchr(fq_subname, ':');
423 subname = strrchr(fq_subname, ':');
425 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
428 subname_len = fq_subname_len - (subname - fq_subname);
429 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
430 cxix = __dopoptosub_at(ccstack, cxix - 1);
438 /* If we made it to here, we found our context */
440 /* cachekey = "objpkg|context::method::name" */
441 cachekey = sv_2mortal(newSVpv(hvname, 0));
442 sv_catpvn(cachekey, "|", 1);
443 sv_catsv(cachekey, sv);
445 nmcache = get_hv("next::METHOD_CACHE", 1);
446 if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
447 SV* val = HeVAL(cache_entry);
448 if(val == &PL_sv_undef) {
450 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
453 XPUSHs(sv_2mortal(newRV_inc(val)));
457 /* beyond here is just for cache misses, so perf isn't as critical */
459 stashname_len = subname - fq_subname - 2;
460 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
462 linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
464 linear_svp = AvARRAY(linear_av);
465 entries = AvFILLp(linear_av) + 1;
468 SV* const linear_sv = *linear_svp++;
470 if(sv_eq(linear_sv, stashname))
475 SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
476 HV* cc3_mro = get_hv("Class::C3::MRO", 0);
479 SV* const linear_sv = *linear_svp++;
483 HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
484 if(he_cc3_mro_class) {
485 SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
486 if(SvROK(cc3_mro_class_sv)) {
487 HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
488 SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
489 if(svp_cc3_mro_class_methods) {
490 SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
491 if(SvROK(cc3_mro_class_methods_sv)) {
492 HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
493 if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
501 cstash = gv_stashsv(linear_sv, FALSE);
504 if (ckWARN(WARN_MISC))
505 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
506 (void*)linear_sv, hvname);
512 gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
518 if (SvTYPE(candidate) != SVt_PVGV)
519 gv_init(candidate, cstash, subname, subname_len, TRUE);
520 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
521 SvREFCNT_dec(linear_av);
522 SvREFCNT_inc((SV*)cand_cv);
523 if (!hv_store_ent(nmcache, cachekey, (SV*)cand_cv, 0)) {
524 croak("failed to store value in hash");
526 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
532 SvREFCNT_dec(linear_av);
533 if (!hv_store_ent(nmcache, cachekey, &PL_sv_undef, 0)) {
534 croak("failed to store value in hash");
537 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
541 XS(XS_Class_C3_XS_calculateMRO);
542 XS(XS_Class_C3_XS_calculateMRO)
554 if(items < 1 || items > 2)
555 croak("Usage: calculateMRO(classname[, cache])");
558 if(items == 2) cache = (HV*)SvRV(ST(1));
560 class_stash = gv_stashsv(classname, 0);
562 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
564 res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
566 res_items = ret_items = AvFILLp(res) + 1;
567 res_ptr = AvARRAY(res);
572 SV* res_item = *res_ptr++;
573 XPUSHs(sv_2mortal(newSVsv(res_item)));
582 XS(XS_Class_C3_XS_plsubgen);
583 XS(XS_Class_C3_XS_plsubgen)
588 XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
593 XS(XS_Class_C3_XS_calc_mdt);
594 XS(XS_Class_C3_XS_calc_mdt)
602 HV* our_c3mro; /* $Class::C3::MRO{classname} */
612 if(items < 1 || items > 2)
613 croak("Usage: calculate_method_dispatch_table(classname[, cache])");
616 class_stash = gv_stashsv(classname, 0);
618 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
620 if(items == 2) cache = (HV*)SvRV(ST(1));
622 class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
625 if(!hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0)) {
626 croak("failed to store value in hash");
629 hv = get_hv("Class::C3::MRO", 1);
630 if(!hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0)) {
631 croak("failed to store value in hash");
636 /* skip first entry */
637 mroitems = AvFILLp(class_mro);
638 svp = AvARRAY(class_mro) + 1;
640 SV* mro_class = *svp++;
641 HV* mro_stash = gv_stashsv(mro_class, 0);
643 if(!mro_stash) continue;
646 SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
647 if(ovfp) has_ovf = *ovfp;
650 hv_iterinit(mro_stash);
651 while((he = hv_iternext(mro_stash))) {
659 mskey = hv_iterkeysv(he);
660 if(hv_exists_ent(methods, mskey, 0)) continue;
662 msval = hv_iterval(mro_stash, he);
663 if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
666 if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
667 SV* val = HeVAL(ourent);
668 if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
673 orig = newSVsv(mro_class);
674 sv_catpvn(orig, "::", 2);
675 sv_catsv(orig, mskey);
676 if( !hv_store(meth_hash, "orig", 4, orig, 0)
677 || !hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0)
678 || !hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0) ) {
679 croak("failed to store value in hash");
684 if(!hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0)) {
685 croak("failed to store value in hash");
688 if(!hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0)) {
689 croak("failed to store value in hash");
695 MODULE = Class::C3::XS PACKAGE = Class::C3::XS
700 newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
701 newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
702 newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
703 newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__);