[gitmo/Class-C3-XS.git] / lib / Class / C3 / XS.xs


#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
 
STATIC I32
__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
    I32 i;
    for (i = startingblock; i >= 0; i--) {
	register const PERL_CONTEXT * const cx = &cxstk[i];
	switch (CxTYPE(cx)) {
	default:
	    continue;
	case CXt_EVAL:
	case CXt_SUB:
	case CXt_FORMAT:
	    DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
	    return i;
	}
    }
    return i;
}

MODULE = Class::C3::XS	PACKAGE = next

#ifdef XXX_NEW_PERL /* some sort of cpp check for a perl that has mro_linear */

/* we want to define next::can, next::method, and maybe::next::method */

CV*
canxs(self)
    SV* self
  PPCODE:
    register I32 cxix = __dopoptosub_at(cxstack, cxstack_ix);
    register const PERL_CONTEXT *cx;
    register const PERL_CONTEXT *ccstack = cxstack;
    const PERL_SI *top_si = PL_curstackinfo;
    HV* selfstash;
    //sv_dump(self);
    if(sv_isobject(self)) {
        selfstash = SvSTASH(SvRV(self));
    }
    else {
        selfstash = gv_stashsv(self, 0);
    }
    assert(selfstash);

    for (;;) {
        /* we may be in a higher stacklevel, so dig down deeper */
        while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
            top_si = top_si->si_prev;
            ccstack = top_si->si_cxstack;
            cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
        }
        if (cxix < 0) {
            croak("next::/maybe::next:: must be used in method context");
        }
    
        /* caller() should not report the automatic calls to &DB::sub */
        if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
            continue;

        cx = &ccstack[cxix];
        if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
            const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
            /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
               field below is defined for any cx. */
            /* caller() should not report the automatic calls to &DB::sub */
            if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
                cx = &ccstack[dbcxix];
            }
            if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
	        GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
	        /* So is ccstack[dbcxix]. */
	        if (isGV(cvgv)) { /* we found a real sub here */
                    const char *stashname;
                    const char *fq_subname;
                    const char *subname;
                    STRLEN fq_subname_len;
                    STRLEN stashname_len;
                    STRLEN subname_len;
                    GV * found_gv;
	            SV * const sv = sv_2mortal(newSV(0));

	            gv_efullname3(sv, cvgv, NULL);

                    fq_subname = SvPVX(sv);
                    fq_subname_len = SvCUR(sv);
/*                    warn("fqsubname is %s", fq_subname); */
                    
                    subname = strrchr(fq_subname, ':');
                    if(subname) {
                        subname++;
                        subname_len = fq_subname_len - (subname - fq_subname);
                        stashname = fq_subname;
                        stashname_len = subname - fq_subname - 2;
                        if(subname_len == 8 && strEQ(subname, "__ANON__")) {
                            croak("Cannot use next::method/next::can/maybe::next::method from an anonymous sub");
                        }
                        else {
                            GV** gvp;
                            AV* linear_av;
                            SV** linear_svp;
                            SV* linear_sv;
                            HV* curstash;
                            GV* candidate = NULL;
                            CV* cand_cv = NULL;
                            const char *hvname;
                            I32 items;

                            hvname = HvNAME_get(selfstash);
                            if (!hvname)
                              Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");

                            linear_av = mro_linear(selfstash); /* has ourselves at the top of the list */
                            sv_2mortal((SV*)linear_av);

                            linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
                            items = AvFILLp(linear_av); /* no +1, to skip over self */

                            while (items--) {
                                linear_sv = *linear_svp++;
                                assert(linear_sv);
                                if(strEQ(SvPVX(linear_sv), stashname)) break;
                            }

                            while (items--) {
                                linear_sv = *linear_svp++;
                                assert(linear_sv);
                                curstash = gv_stashsv(linear_sv, FALSE);

                                if (!curstash) {
                                    if (ckWARN(WARN_MISC))
                                        Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
                                            (void*)linear_sv, hvname);
                                    continue;
                                }

                                assert(curstash);

                                gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
                                if (!gvp) continue;
                                candidate = *gvp;
                                assert(candidate);
                                if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, curstash, subname, subname_len, TRUE);
                                if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
                                    PUSHs((SV*)cand_cv);
                                    return;
                                }
                            }
    
                            /* Check UNIVERSAL without caching */
                            if((candidate = gv_fetchmeth(NULL, subname, subname_len, 1))) {
                                PUSHs((SV*)GvCV(candidate));
                                return;
                            }
                            PUSHs(&PL_sv_undef);
                            return;
                        }
                    }
	        }
            }

	    cxix = __dopoptosub_at(ccstack, cxix - 1);
        }


#else /* mro_linear stuff not in core, so do some helpers for the pure-perl variant */

/* we want to define two helper functions:
   1) A replacement for Alg::C3::merge based on mro_linear_c3, but without the mro_meta caching parts.
      it should have optional merge cache support just like Alg::C3 does, but only support @ISA, not
      generic parents.  Call it Class::C3::calculateMRO_XS or something.
   2) A fast "fetch the most recent caller's package/sub-names", based on the xs can function above,
      to speed up the top half of pure-perl next::method.
*/
#endif
Commit	Line	Data
8995e827	1
	2	#include "EXTERN.h"
	3	#include "perl.h"
	4	#include "XSUB.h"
	5
	6	STATIC I32
	7	__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
	8	I32 i;
	9	for (i = startingblock; i >= 0; i--) {
	10	register const PERL_CONTEXT * const cx = &cxstk[i];
	11	switch (CxTYPE(cx)) {
	12	default:
	13	continue;
	14	case CXt_EVAL:
	15	case CXt_SUB:
	16	case CXt_FORMAT:
	17	DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
	18	return i;
	19	}
	20	}
	21	return i;
	22	}
	23
	24	MODULE = Class::C3::XS PACKAGE = next
	25
	26	#ifdef XXX_NEW_PERL /* some sort of cpp check for a perl that has mro_linear */
	27
	28	/* we want to define next::can, next::method, and maybe::next::method */
	29
	30	CV*
	31	canxs(self)
	32	SV* self
	33	PPCODE:
	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;
	38	HV* selfstash;
	39	//sv_dump(self);
	40	if(sv_isobject(self)) {
	41	selfstash = SvSTASH(SvRV(self));
	42	}
	43	else {
	44	selfstash = gv_stashsv(self, 0);
	45	}
	46	assert(selfstash);
	47
	48	for (;;) {
	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);
	54	}
	55	if (cxix < 0) {
	56	croak("next::/maybe::next:: must be used in method context");
	57	}
	58
	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))
	61	continue;
	62
	63	cx = &ccstack[cxix];
	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];
71	}
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;
78	const char *subname;
79	STRLEN fq_subname_len;
80	STRLEN stashname_len;
81	STRLEN subname_len;
82	GV * found_gv;
83	SV * const sv = sv_2mortal(newSV(0));
84
85	gv_efullname3(sv, cvgv, NULL);
86
87	fq_subname = SvPVX(sv);
88	fq_subname_len = SvCUR(sv);
89	/* warn("fqsubname is %s", fq_subname); */
90
91	subname = strrchr(fq_subname, ':');
92	if(subname) {
93	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");
99	}
100	else {
101	GV** gvp;
102	AV* linear_av;
103	SV** linear_svp;
104	SV* linear_sv;
105	HV* curstash;
106	GV* candidate = NULL;
107	CV* cand_cv = NULL;
108	const char *hvname;
109	I32 items;
110
111	hvname = HvNAME_get(selfstash);
112	if (!hvname)
113	Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
114
115	linear_av = mro_linear(selfstash); /* has ourselves at the top of the list */
116	sv_2mortal((SV*)linear_av);
117
118	linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
119	items = AvFILLp(linear_av); /* no +1, to skip over self */
120
121	while (items--) {
122	linear_sv = *linear_svp++;
123	assert(linear_sv);
124	if(strEQ(SvPVX(linear_sv), stashname)) break;
125	}
126
127	while (items--) {
128	linear_sv = *linear_svp++;
129	assert(linear_sv);
130	curstash = gv_stashsv(linear_sv, FALSE);
131
132	if (!curstash) {
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);
136	continue;
137	}
138
139	assert(curstash);
140
141	gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
142	if (!gvp) continue;
143	candidate = *gvp;
144	assert(candidate);
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)) {
147	PUSHs((SV*)cand_cv);
148	return;
149	}
150	}
151
152	/* Check UNIVERSAL without caching */
153	if((candidate = gv_fetchmeth(NULL, subname, subname_len, 1))) {
154	PUSHs((SV*)GvCV(candidate));
155	return;
156	}
157	PUSHs(&PL_sv_undef);
158	return;
159	}
160	}
161	}
162	}
163
164	cxix = __dopoptosub_at(ccstack, cxix - 1);
165	}
166
167
168	#else /* mro_linear stuff not in core, so do some helpers for the pure-perl variant */
169
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.
176	*/
177	#endif