7 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
9 for (i = startingblock; i >= 0; i--) {
10 register const PERL_CONTEXT * const cx = &cxstk[i];
17 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
24 MODULE = Class::C3::XS PACKAGE = next
26 #ifdef XXX_NEW_PERL /* some sort of cpp check for a perl that has mro_linear */
28 /* we want to define next::can, next::method, and maybe::next::method */
34 register I32 cxix = __dopoptosub_at(cxstack, cxstack_ix);
35 register const PERL_CONTEXT *cx;
36 register const PERL_CONTEXT *ccstack = cxstack;
37 const PERL_SI *top_si = PL_curstackinfo;
40 if(sv_isobject(self)) {
41 selfstash = SvSTASH(SvRV(self));
44 selfstash = gv_stashsv(self, 0);
49 /* we may be in a higher stacklevel, so dig down deeper */
50 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
51 top_si = top_si->si_prev;
52 ccstack = top_si->si_cxstack;
53 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
56 croak("next::/maybe::next:: must be used in method context");
59 /* caller() should not report the automatic calls to &DB::sub */
60 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
64 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
65 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
66 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
67 field below is defined for any cx. */
68 /* caller() should not report the automatic calls to &DB::sub */
69 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
70 cx = &ccstack[dbcxix];
72 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
73 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
74 /* So is ccstack[dbcxix]. */
75 if (isGV(cvgv)) { /* we found a real sub here */
76 const char *stashname;
77 const char *fq_subname;
79 STRLEN fq_subname_len;
83 SV * const sv = sv_2mortal(newSV(0));
85 gv_efullname3(sv, cvgv, NULL);
87 fq_subname = SvPVX(sv);
88 fq_subname_len = SvCUR(sv);
89 /* warn("fqsubname is %s", fq_subname); */
91 subname = strrchr(fq_subname, ':');
94 subname_len = fq_subname_len - (subname - fq_subname);
95 stashname = fq_subname;
96 stashname_len = subname - fq_subname - 2;
97 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
98 croak("Cannot use next::method/next::can/maybe::next::method from an anonymous sub");
106 GV* candidate = NULL;
111 hvname = HvNAME_get(selfstash);
113 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
115 linear_av = mro_linear(selfstash); /* has ourselves at the top of the list */
116 sv_2mortal((SV*)linear_av);
118 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
119 items = AvFILLp(linear_av); /* no +1, to skip over self */
122 linear_sv = *linear_svp++;
124 if(strEQ(SvPVX(linear_sv), stashname)) break;
128 linear_sv = *linear_svp++;
130 curstash = gv_stashsv(linear_sv, FALSE);
133 if (ckWARN(WARN_MISC))
134 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
135 (void*)linear_sv, hvname);
141 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
145 if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, curstash, subname, subname_len, TRUE);
146 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
152 /* Check UNIVERSAL without caching */
153 if((candidate = gv_fetchmeth(NULL, subname, subname_len, 1))) {
154 PUSHs((SV*)GvCV(candidate));
164 cxix = __dopoptosub_at(ccstack, cxix - 1);
168 #else /* mro_linear stuff not in core, so do some helpers for the pure-perl variant */
170 /* we want to define two helper functions:
171 1) A replacement for Alg::C3::merge based on mro_linear_c3, but without the mro_meta caching parts.
172 it should have optional merge cache support just like Alg::C3 does, but only support @ISA, not
173 generic parents. Call it Class::C3::calculateMRO_XS or something.
174 2) A fast "fetch the most recent caller's package/sub-names", based on the xs can function above,
175 to speed up the top half of pure-perl next::method.