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 */
234 /* we have to do some cleanup before we croak */
236 SvREFCNT_dec(retval);
239 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
240 "merging failed on parent '%s'", stashname, SvPV_nolen(cand));
244 else { /* @ISA was undefined or empty */
245 /* build a retval containing only ourselves */
247 av_push(retval, newSVpvn(stashname, stashname_len));
250 /* we don't want anyone modifying the cache entry but us,
251 and we do so by replacing it completely */
252 SvREADONLY_on(retval);
254 if(!made_mortal_cache) {
255 SvREFCNT_inc(retval);
256 if(!hv_store(cache, stashname, stashname_len, (SV*)retval, 0)) {
257 croak("failed to store value in hash");
265 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
267 for (i = startingblock; i >= 0; i--) {
268 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
273 XS(XS_Class_C3_XS_nextcan);
274 XS(XS_Class_C3_XS_nextcan)
279 const I32 throw_nomethod = SvIVX(ST(1));
280 register I32 cxix = cxstack_ix;
281 register const PERL_CONTEXT *ccstack = cxstack;
282 const PERL_SI *top_si = PL_curstackinfo;
286 const char *fq_subname;
288 STRLEN fq_subname_len;
289 STRLEN stashname_len;
296 GV* candidate = NULL;
307 if(sv_isobject(self))
308 selfstash = SvSTASH(SvRV(self));
310 selfstash = gv_stashsv(self, 0);
314 hvname = HvNAME(selfstash);
316 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
318 /* This block finds the contextually-enclosing fully-qualified subname,
319 much like looking at (caller($i))[3] until you find a real sub that
320 isn't ANON, etc (also skips over pureperl next::method, etc) */
321 for(i = 0; i < 2; i++) {
322 cxix = __dopoptosub_at(ccstack, cxix);
324 /* we may be in a higher stacklevel, so dig down deeper */
326 if(top_si->si_type == PERLSI_MAIN)
327 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
328 top_si = top_si->si_prev;
329 ccstack = top_si->si_cxstack;
330 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
333 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
334 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
335 cxix = __dopoptosub_at(ccstack, cxix - 1);
340 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
341 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
342 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
349 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
352 cxix = __dopoptosub_at(ccstack, cxix - 1);
356 /* we found a real sub here */
357 sv = sv_2mortal(newSV(0));
359 gv_efullname3(sv, cvgv, NULL);
361 fq_subname = SvPVX(sv);
362 fq_subname_len = SvCUR(sv);
364 subname = strrchr(fq_subname, ':');
366 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
369 subname_len = fq_subname_len - (subname - fq_subname);
370 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
371 cxix = __dopoptosub_at(ccstack, cxix - 1);
379 /* If we made it to here, we found our context */
381 /* cachekey = "objpkg|context::method::name" */
382 cachekey = sv_2mortal(newSVpv(hvname, 0));
383 sv_catpvn(cachekey, "|", 1);
384 sv_catsv(cachekey, sv);
386 nmcache = get_hv("next::METHOD_CACHE", 1);
387 if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
388 SV* val = HeVAL(cache_entry);
389 if(val == &PL_sv_undef) {
391 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
394 XPUSHs(sv_2mortal(newRV_inc(val)));
398 /* beyond here is just for cache misses, so perf isn't as critical */
400 stashname_len = subname - fq_subname - 2;
401 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
403 linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
405 linear_svp = AvARRAY(linear_av);
406 entries = AvFILLp(linear_av) + 1;
409 SV* const linear_sv = *linear_svp++;
411 if(sv_eq(linear_sv, stashname))
416 SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
417 HV* cc3_mro = get_hv("Class::C3::MRO", 0);
420 SV* const linear_sv = *linear_svp++;
424 HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
425 if(he_cc3_mro_class) {
426 SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
427 if(SvROK(cc3_mro_class_sv)) {
428 HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
429 SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
430 if(svp_cc3_mro_class_methods) {
431 SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
432 if(SvROK(cc3_mro_class_methods_sv)) {
433 HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
434 if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
442 cstash = gv_stashsv(linear_sv, FALSE);
445 if (ckWARN(WARN_MISC))
446 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
447 (void*)linear_sv, hvname);
453 gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
459 if (SvTYPE(candidate) != SVt_PVGV)
460 gv_init(candidate, cstash, subname, subname_len, TRUE);
461 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
462 SvREFCNT_dec(linear_av);
463 SvREFCNT_inc((SV*)cand_cv);
464 if (!hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0)) {
465 croak("failed to store value in hash");
467 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
473 SvREFCNT_dec(linear_av);
474 if (!hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0)) {
475 croak("failed to store value in hash");
478 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
482 XS(XS_Class_C3_XS_calculateMRO);
483 XS(XS_Class_C3_XS_calculateMRO)
495 if(items < 1 || items > 2)
496 croak("Usage: calculateMRO(classname[, cache])");
499 if(items == 2) cache = (HV*)SvRV(ST(1));
501 class_stash = gv_stashsv(classname, 0);
503 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
505 res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
507 res_items = ret_items = AvFILLp(res) + 1;
508 res_ptr = AvARRAY(res);
513 SV* res_item = *res_ptr++;
514 XPUSHs(sv_2mortal(newSVsv(res_item)));
523 XS(XS_Class_C3_XS_plsubgen);
524 XS(XS_Class_C3_XS_plsubgen)
529 XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
534 XS(XS_Class_C3_XS_calc_mdt);
535 XS(XS_Class_C3_XS_calc_mdt)
543 HV* our_c3mro; /* $Class::C3::MRO{classname} */
553 if(items < 1 || items > 2)
554 croak("Usage: calculate_method_dispatch_table(classname[, cache])");
557 class_stash = gv_stashsv(classname, 0);
559 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
561 if(items == 2) cache = (HV*)SvRV(ST(1));
563 class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
566 if(!hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0)) {
567 croak("failed to store value in hash");
570 hv = get_hv("Class::C3::MRO", 1);
571 if(!hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0)) {
572 croak("failed to store value in hash");
577 /* skip first entry */
578 mroitems = AvFILLp(class_mro);
579 svp = AvARRAY(class_mro) + 1;
581 SV* mro_class = *svp++;
582 HV* mro_stash = gv_stashsv(mro_class, 0);
584 if(!mro_stash) continue;
587 SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
588 if(ovfp) has_ovf = *ovfp;
591 hv_iterinit(mro_stash);
592 while((he = hv_iternext(mro_stash))) {
600 mskey = hv_iterkeysv(he);
601 if(hv_exists_ent(methods, mskey, 0)) continue;
603 msval = hv_iterval(mro_stash, he);
604 if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
607 if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
608 SV* val = HeVAL(ourent);
609 if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
614 orig = newSVsv(mro_class);
615 sv_catpvn(orig, "::", 2);
616 sv_catsv(orig, mskey);
617 if( !hv_store(meth_hash, "orig", 4, orig, 0)
618 || !hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0)
619 || !hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0) ) {
620 croak("failed to store value in hash");
625 if(!hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0)) {
626 croak("failed to store value in hash");
629 if(!hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0)) {
630 croak("failed to store value in hash");
636 MODULE = Class::C3::XS PACKAGE = Class::C3::XS
641 newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
642 newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
643 newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
644 newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__);