[gitmo/Mouse.git] / xs-src / MouseUtil.xs

#include "mouse.h"

#define MY_CXT_KEY "Mouse::Util::_guts" XS_VERSION
typedef struct {
    HV* metas;
} my_cxt_t;
START_MY_CXT

#define ISA_CACHE "::LINEALIZED_ISA_CACHE::"

#ifdef no_mro_get_linear_isa
AV*
mouse_mro_get_linear_isa(pTHX_ HV* const stash){
    GV* const cachegv = *(GV**)hv_fetchs(stash, ISA_CACHE, TRUE);
    AV* isa;
    SV* gen;
    CV* get_linear_isa;

    if(!isGV(cachegv))
        gv_init(cachegv, stash, ISA_CACHE, sizeof(ISA_CACHE)-1, TRUE);

    isa = GvAVn(cachegv);
    gen = GvSVn(cachegv);


    if(SvIOK(gen) && SvIVX(gen) == (IV)mro_get_pkg_gen(stash)){
        return isa; /* returns the cache if available */
    }
    else{
        SvREFCNT_dec(isa);
        GvAV(cachegv) = isa = newAV();
    }

    get_linear_isa = get_cv("Mouse::Util::get_linear_isa", TRUE);

    {
        SV* avref;
        dSP;

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);
        mXPUSHp(HvNAME_get(stash), HvNAMELEN_get(stash));
        PUTBACK;

        call_sv((SV*)get_linear_isa, G_SCALAR);

        SPAGAIN;
        avref = POPs;
        PUTBACK;

        if(IsArrayRef(avref)){
            AV* const av  = (AV*)SvRV(avref);
            I32 const len = AvFILLp(av) + 1;
            I32 i;

            for(i = 0; i < len; i++){
                HV* const stash = gv_stashsv(AvARRAY(av)[i], FALSE);
                if(stash)
                    av_push(isa, newSVpv(HvNAME(stash), 0));
            }
            SvREADONLY_on(isa);
        }
        else{
            Perl_croak(aTHX_ "Mouse:Util::get_linear_isa() didn't return an ARRAY reference");
        }

        FREETMPS;
        LEAVE;
    }

    sv_setiv(gen, (IV)mro_get_pkg_gen(stash));
    return isa;
}
#endif /* !no_mor_get_linear_isa */

#ifdef DEBUGGING
SV**
mouse_av_at_safe(pTHX_ AV* const av, I32 const ix){
    assert(av);
    assert(SvTYPE(av) == SVt_PVAV);
    assert(AvMAX(av) >= ix);
    return &AvARRAY(av)[ix];
}
#endif

void
mouse_throw_error(SV* const metaobject, SV* const data /* not used */, const char* const fmt, ...){
    dTHX;
    va_list args;
    SV* message;

    assert(metaobject);
    assert(fmt);

    va_start(args, fmt);
    message = vnewSVpvf(fmt, &args);
    va_end(args);

    {
        dSP;
        PUSHMARK(SP);
        EXTEND(SP, 6);

        PUSHs(metaobject);
        mPUSHs(message);

        if(data){ /* extra arg, might be useful for debugging */
            mPUSHs(newSVpvs("data"));
            PUSHs(data);
            mPUSHs(newSVpvs("depth"));
            mPUSHi(-1);
        }

        PUTBACK;

        call_method("throw_error", G_VOID);
        croak("throw_error() did not throw the error (%"SVf")", message);
    }
}

static I32
S_dopoptosub(pTHX_ I32 const startingblock)
{
    const PERL_CONTEXT* const cxstk = cxstack;
    I32 i;
    for (i = startingblock; i >= 0; i--) {
        const PERL_CONTEXT* const cx = &cxstk[i];

        switch (CxTYPE(cx)) {
        case CXt_EVAL:
        case CXt_SUB:
        case CXt_FORMAT:
            return i;
        }
    }
    return i;
}

/* workaround Perl-RT #69939 */
I32
mouse_call_sv_safe(pTHX_ SV* const sv, I32 const flags) {
    const PERL_CONTEXT* const cx = &cxstack[S_dopoptosub(aTHX_ cxstack_ix)];
    assert( (flags & G_EVAL) == 0 );

    //warn("cx_type=0x%02x PL_eval=0x%02x (%"SVf")", (unsigned)cx->cx_type, (unsigned)PL_in_eval, sv);
    if(cx->cx_type & CXp_TRYBLOCK) {
        return Perl_call_sv(aTHX_ sv, flags);
    }
    else {
        I32 count;
        ENTER;
        /* Don't do SAVETMPS */

        SAVESPTR(ERRSV);
        ERRSV = sv_newmortal();

        count = Perl_call_sv(aTHX_ sv, flags | G_EVAL);

        if(sv_true(ERRSV)){
            SV* const err = sv_mortalcopy(ERRSV);
            LEAVE;
            sv_setsv(ERRSV, err);
            croak(NULL); /* rethrow */
        }

        LEAVE;

        return count;
    }
}

void
mouse_must_defined(pTHX_ SV* const value, const char* const name) {
    assert(value);
    assert(name);

    SvGETMAGIC(value);
    if(!SvOK(value)){
        croak("You must define %s", name);
    }
}

void
mouse_must_ref(pTHX_ SV* const value, const char* const name, svtype const t) {
    assert(value);
    assert(name);

    SvGETMAGIC(value);
    if(!(SvROK(value) && (t == SVt_NULL || SvTYPE(SvRV(value)) == t))) {
        croak("You must pass %s, not %s",
            name, SvOK(value) ? SvPV_nolen(value) : "undef");
    }
}


bool
mouse_is_class_loaded(pTHX_ SV * const klass){
    HV *stash;
    GV** gvp;
    HE* he;

    if (!(SvPOKp(klass) && SvCUR(klass))) { /* XXX: SvPOK does not work with magical scalars */
        return FALSE;
    }

    stash = gv_stashsv(klass, FALSE);
    if (!stash) {
        return FALSE;
    }

    if (( gvp = (GV**)hv_fetchs(stash, "VERSION", FALSE) )) {
        if(isGV(*gvp) && GvSV(*gvp) && SvOK(GvSV(*gvp))){
            return TRUE;
        }
    }

    if (( gvp = (GV**)hv_fetchs(stash, "ISA", FALSE) )) {
        if(isGV(*gvp) && GvAV(*gvp) && av_len(GvAV(*gvp)) != -1){
            return TRUE;
        }
    }

    hv_iterinit(stash);
    while(( he = hv_iternext(stash) )){
        GV* const gv = (GV*)HeVAL(he);

        if(isGV(gv)){
            if(GvCVu(gv)){ /* is GV and has CV */
                hv_iterinit(stash); /* reset */
                return TRUE;
            }
        }
        else if(SvOK(gv)){ /* is a stub or constant */
            hv_iterinit(stash); /* reset */
            return TRUE;
        }
    }
    return FALSE;
}


SV*
mouse_call0 (pTHX_ SV* const self, SV* const method) {
    dSP;
    SV *ret;

    PUSHMARK(SP);
    XPUSHs(self);
    PUTBACK;

    call_sv_safe(method, G_SCALAR | G_METHOD);

    SPAGAIN;
    ret = POPs;
    PUTBACK;

    return ret;
}

SV*
mouse_call1 (pTHX_ SV* const self, SV* const method, SV* const arg1) {
    dSP;
    SV *ret;

    PUSHMARK(SP);
    EXTEND(SP, 2);
    PUSHs(self);
    PUSHs(arg1);
    PUTBACK;

    call_sv_safe(method, G_SCALAR | G_METHOD);

    SPAGAIN;
    ret = POPs;
    PUTBACK;

    return ret;
}

int
mouse_predicate_call(pTHX_ SV* const self, SV* const method) {
    return sv_true( mcall0(self, method) );
}

SV*
mouse_get_metaclass(pTHX_ SV* metaclass_name){
    dMY_CXT;
    HE* he;

    assert(metaclass_name);
    assert(MY_CXT.metas);

    if(IsObject(metaclass_name)){
        HV* const stash = SvSTASH(SvRV(metaclass_name));

        metaclass_name = newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U);
        sv_2mortal(metaclass_name);
    }

    he = hv_fetch_ent(MY_CXT.metas, metaclass_name, FALSE, 0U);

    return he ? HeVAL(he) : &PL_sv_undef;
}

MAGIC*
mouse_mg_find(pTHX_ SV* const sv, const MGVTBL* const vtbl, I32 const flags){
    MAGIC* mg;

    assert(sv != NULL);
    for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic){
        if(mg->mg_virtual == vtbl){
            return mg;
        }
    }

    if(flags & MOUSEf_DIE_ON_FAIL){
        croak("mouse_mg_find: no MAGIC found for %"SVf, sv_2mortal(newRV_inc(sv)));
    }
    return NULL;
}

GV*
mouse_stash_fetch(pTHX_ HV* const stash, const char* const name, I32 const namelen, I32 const create) {
    GV** const gvp = (GV**)hv_fetch(stash, name, namelen, create);

    if(gvp){
        if(!isGV(*gvp)){
            gv_init(*gvp, stash, name, namelen, GV_ADDMULTI);
        }
        return *gvp;
    }
    else{
        return NULL;
    }
}

void
mouse_install_sub(pTHX_ GV* const gv, SV* const code_ref) {
    CV* cv;

    assert(gv != NULL);
    assert(code_ref != NULL);
    assert(isGV(gv));
    assert(IsCodeRef(code_ref));

    if(GvCVu(gv)){ /* delete *slot{gv} to work around "redefine" warning */
        SvREFCNT_dec(GvCV(gv));
        GvCV(gv) = NULL;
    }

    sv_setsv_mg((SV*)gv, code_ref); /* *gv = $code_ref */

    /* name the CODE ref if it's anonymous */
    cv = (CV*)SvRV(code_ref);
    if(CvANON(cv)
        && CvGV(cv) /* a cv under construction has no gv */ ){
        HV* dbsub;

        /* update %DB::sub to make NYTProf happy */
        if((PL_perldb & (PERLDBf_SUBLINE|PERLDB_NAMEANON))
            && PL_DBsub && (dbsub = GvHV(PL_DBsub))
        ){
            /* see Perl_newATTRSUB() in op.c */
            SV* const subname = sv_newmortal();
            HE* orig;

            gv_efullname3(subname, CvGV(cv), NULL);
            orig = hv_fetch_ent(dbsub, subname, FALSE, 0U);
            if(orig){
                gv_efullname3(subname, gv, NULL);
                (void)hv_store_ent(dbsub, subname, HeVAL(orig), 0U);
                SvREFCNT_inc_simple_void_NN(HeVAL(orig));
            }
        }

        CvGV(cv) = gv;
        CvANON_off(cv);
    }
}

MODULE = Mouse::Util  PACKAGE = Mouse::Util

PROTOTYPES:   DISABLE
VERSIONCHECK: DISABLE

BOOT:
{
    MY_CXT_INIT;
    MY_CXT.metas = NULL;
}

void
__register_metaclass_storage(HV* metas, bool cloning)
CODE:
{
    if(cloning){
        MY_CXT_CLONE;
        MY_CXT.metas = NULL;
    }
    {
        dMY_CXT;
        if(MY_CXT.metas && ckWARN(WARN_REDEFINE)){
            Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Metaclass storage more than once");
        }
        MY_CXT.metas = metas;
        SvREFCNT_inc_simple_void_NN(metas);
    }
}

bool
is_valid_class_name(SV* sv)
CODE:
{
    SvGETMAGIC(sv);
    if(SvPOKp(sv) && SvCUR(sv) > 0){
        UV i;
        RETVAL = TRUE;
        for(i = 0; i < SvCUR(sv); i++){
            char const c = SvPVX(sv)[i];
            if(!(isALNUM(c) || c == ':')){
                RETVAL = FALSE;
                break;
            }
        }
    }
    else{
        RETVAL = SvNIOKp(sv) ? TRUE : FALSE;
    }
}
OUTPUT:
    RETVAL

bool
is_class_loaded(SV* sv)

void
get_code_info(CV* code)
PREINIT:
    GV* gv;
    HV* stash;
PPCODE:
    if((gv = CvGV(code)) && isGV(gv) && (stash = GvSTASH(gv))){
        EXTEND(SP, 2);
        mPUSHs(newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U));
        mPUSHs(newSVpvn_share(GvNAME_get(gv), GvNAMELEN_get(gv), 0U));
    }

SV*
get_code_package(CV* code)
PREINIT:
    HV* stash;
CODE:
    if(CvGV(code) && isGV(CvGV(code)) && (stash = GvSTASH(CvGV(code)))){
        RETVAL = newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U);
    }
    else{
        RETVAL = &PL_sv_no;
    }
OUTPUT:
    RETVAL

CV*
get_code_ref(SV* package, SV* name)
CODE:
{
    HV* stash;
    STRLEN name_len;
    const char* name_pv;
    GV* gv;

    must_defined(package, "a package name");
    must_defined(name,    "a subroutine name");

    stash = gv_stashsv(package, FALSE);
    if(!stash){
        XSRETURN_UNDEF;
    }

    name_pv = SvPV_const(name, name_len);
    gv = stash_fetch(stash, name_pv, name_len, FALSE);
    RETVAL = gv ? GvCVu(gv) : NULL;

    if(!RETVAL){
        XSRETURN_UNDEF;
    }
}
OUTPUT:
    RETVAL

void
generate_isa_predicate_for(SV* arg, SV* predicate_name = NULL)
ALIAS:
    generate_isa_predicate_for = 0
    generate_can_predicate_for = 1
PPCODE:
{
    const char* name_pv = NULL;
    CV* xsub;

    must_defined(arg, ix == 0 ? "a class_name" : "method names");

    if(predicate_name){
        must_defined(predicate_name, "a predicate name");
        name_pv = SvPV_nolen_const(predicate_name);
    }

    if(ix == 0){
        xsub = mouse_generate_isa_predicate_for(aTHX_ arg, name_pv);
    }
    else{
        xsub = mouse_generate_can_predicate_for(aTHX_ arg, name_pv);
    }

    if(predicate_name == NULL){ /* anonymous predicate */
        mXPUSHs( newRV_inc((SV*)xsub) );
    }
}

# This xsub will redefine &Mouse::Util::install_subroutines()
void
install_subroutines(SV* into, ...)
CODE:
{
    HV* stash;
    I32 i;

    must_defined(into, "a package name");
    stash = gv_stashsv(into, TRUE);

    if( ((items-1) % 2) != 0 ){
        croak_xs_usage(cv, "into, name => coderef [, other_name, other_coderef ...]");
    }

    for(i = 1; i < items; i += 2) {
        SV* const name = ST(i);
        SV* const code = ST(i+1);
        STRLEN len;
        const char* pv;
        GV* gv;

        must_defined(name, "a subroutine name");
        must_ref(code, "a CODE reference", SVt_PVCV);

        pv = SvPV_const(name, len);
        gv = stash_fetch(stash, pv, len, TRUE);

        mouse_install_sub(aTHX_ gv, code);
    }
}
Commit	Line	Data
646c0371	1	#include "mouse.h"
646c0371	2
fd168725	3	#define MY_CXT_KEY "Mouse::Util::_guts" XS_VERSION
	4	typedef struct {
	5	HV* metas;
	6	} my_cxt_t;
	7	START_MY_CXT
	8
646c0371	9	#define ISA_CACHE "::LINEALIZED_ISA_CACHE::"
	10
	11	#ifdef no_mro_get_linear_isa
	12	AV*
	13	mouse_mro_get_linear_isa(pTHX_ HV* const stash){
6582d0e3	14	GV* const cachegv = (GV*)hv_fetchs(stash, ISA_CACHE, TRUE);
	15	AV* isa;
	16	SV* gen;
	17	CV* get_linear_isa;
	18
	19	if(!isGV(cachegv))
	20	gv_init(cachegv, stash, ISA_CACHE, sizeof(ISA_CACHE)-1, TRUE);
	21
	22	isa = GvAVn(cachegv);
	23	gen = GvSVn(cachegv);
	24
	25
	26	if(SvIOK(gen) && SvIVX(gen) == (IV)mro_get_pkg_gen(stash)){
	27	return isa; /* returns the cache if available */
	28	}
	29	else{
cd658d1f	30	SvREFCNT_dec(isa);
cd658d1f	31	GvAV(cachegv) = isa = newAV();
6582d0e3	32	}
	33
	34	get_linear_isa = get_cv("Mouse::Util::get_linear_isa", TRUE);
	35
	36	{
	37	SV* avref;
	38	dSP;
	39
	40	ENTER;
	41	SAVETMPS;
	42
	43	PUSHMARK(SP);
	44	mXPUSHp(HvNAME_get(stash), HvNAMELEN_get(stash));
	45	PUTBACK;
	46
	47	call_sv((SV*)get_linear_isa, G_SCALAR);
	48
	49	SPAGAIN;
	50	avref = POPs;
	51	PUTBACK;
	52
80aa5731	53	if(IsArrayRef(avref)){
6582d0e3	54	AV* const av = (AV*)SvRV(avref);
	55	I32 const len = AvFILLp(av) + 1;
	56	I32 i;
	57
	58	for(i = 0; i < len; i++){
	59	HV* const stash = gv_stashsv(AvARRAY(av)[i], FALSE);
	60	if(stash)
	61	av_push(isa, newSVpv(HvNAME(stash), 0));
	62	}
	63	SvREADONLY_on(isa);
	64	}
	65	else{
	66	Perl_croak(aTHX_ "Mouse:Util::get_linear_isa() didn't return an ARRAY reference");
	67	}
	68
	69	FREETMPS;
	70	LEAVE;
	71	}
	72
	73	sv_setiv(gen, (IV)mro_get_pkg_gen(stash));
cd658d1f	74	return isa;
646c0371	75	}
	76	#endif /* !no_mor_get_linear_isa */
	77
	78	#ifdef DEBUGGING
	79	SV**
	80	mouse_av_at_safe(pTHX_ AV* const av, I32 const ix){
	81	assert(av);
	82	assert(SvTYPE(av) == SVt_PVAV);
	83	assert(AvMAX(av) >= ix);
	84	return &AvARRAY(av)[ix];
	85	}
	86	#endif
	87
	88	void
	89	mouse_throw_error(SV* const metaobject, SV* const data /* not used /, const char const fmt, ...){
	90	dTHX;
	91	va_list args;
	92	SV* message;
	93
646c0371	94	assert(metaobject);
	95	assert(fmt);
	96
	97	va_start(args, fmt);
	98	message = vnewSVpvf(fmt, &args);
	99	va_end(args);
	100
	101	{
	102	dSP;
	103	PUSHMARK(SP);
077f2efd	104	EXTEND(SP, 6);
646c0371	105
	106	PUSHs(metaobject);
	107	mPUSHs(message);
	108
431e4817	109	if(data){ /* extra arg, might be useful for debugging */
077f2efd	110	mPUSHs(newSVpvs("data"));
431e4817	111	PUSHs(data);
	112	mPUSHs(newSVpvs("depth"));
	113	mPUSHi(-1);
	114	}
646c0371	115
	116	PUTBACK;
	117
	118	call_method("throw_error", G_VOID);
	119	croak("throw_error() did not throw the error (%"SVf")", message);
	120	}
	121	}
	122
5433f845	123	static I32
	124	S_dopoptosub(pTHX_ I32 const startingblock)
	125	{
	126	const PERL_CONTEXT* const cxstk = cxstack;
	127	I32 i;
	128	for (i = startingblock; i >= 0; i--) {
	129	const PERL_CONTEXT* const cx = &cxstk[i];
	130
	131	switch (CxTYPE(cx)) {
	132	case CXt_EVAL:
	133	case CXt_SUB:
	134	case CXt_FORMAT:
	135	return i;
	136	}
	137	}
	138	return i;
	139	}
	140
8fcdb997	141	/* workaround Perl-RT #69939 */
b3cd4c14	142	I32
b3cd4c14	143	mouse_call_sv_safe(pTHX_ SV* const sv, I32 const flags) {
5433f845	144	const PERL_CONTEXT* const cx = &cxstack[S_dopoptosub(aTHX_ cxstack_ix)];
b3cd4c14	145	assert( (flags & G_EVAL) == 0 );
5433f845	146
5433f845	147	//warn("cx_type=0x%02x PL_eval=0x%02x (%"SVf")", (unsigned)cx->cx_type, (unsigned)PL_in_eval, sv);
8fcdb997	148	if(cx->cx_type & CXp_TRYBLOCK) {
	149	return Perl_call_sv(aTHX_ sv, flags);
	150	}
	151	else {
b3cd4c14	152	I32 count;
8fcdb997	153	ENTER;
	154	/* Don't do SAVETMPS */
	155
	156	SAVESPTR(ERRSV);
	157	ERRSV = sv_newmortal();
b3cd4c14	158
	159	count = Perl_call_sv(aTHX_ sv, flags \| G_EVAL);
	160
	161	if(sv_true(ERRSV)){
8fcdb997	162	SV* const err = sv_mortalcopy(ERRSV);
8fcdb997	163	LEAVE;
f07982df	164	sv_setsv(ERRSV, err);
f07982df	165	croak(NULL); /* rethrow */
b3cd4c14	166	}
8fcdb997	167
	168	LEAVE;
	169
b3cd4c14	170	return count;
b3cd4c14	171	}
b3cd4c14	172	}
b3cd4c14	173
d06d9266	174	void
	175	mouse_must_defined(pTHX_ SV* const value, const char* const name) {
	176	assert(value);
	177	assert(name);
	178
	179	SvGETMAGIC(value);
	180	if(!SvOK(value)){
	181	croak("You must define %s", name);
	182	}
	183	}
	184
	185	void
	186	mouse_must_ref(pTHX_ SV* const value, const char* const name, svtype const t) {
	187	assert(value);
	188	assert(name);
	189
	190	SvGETMAGIC(value);
	191	if(!(SvROK(value) && (t == SVt_NULL \|\| SvTYPE(SvRV(value)) == t))) {
	192	croak("You must pass %s, not %s",
	193	name, SvOK(value) ? SvPV_nolen(value) : "undef");
	194	}
	195	}
	196
	197
646c0371	198	bool
	199	mouse_is_class_loaded(pTHX_ SV * const klass){
	200	HV *stash;
	201	GV** gvp;
	202	HE* he;
	203
	204	if (!(SvPOKp(klass) && SvCUR(klass))) { /* XXX: SvPOK does not work with magical scalars */
	205	return FALSE;
	206	}
	207
	208	stash = gv_stashsv(klass, FALSE);
	209	if (!stash) {
	210	return FALSE;
	211	}
	212
	213	if (( gvp = (GV**)hv_fetchs(stash, "VERSION", FALSE) )) {
	214	if(isGV(gvp) && GvSV(gvp) && SvOK(GvSV(*gvp))){
	215	return TRUE;
	216	}
	217	}
	218
	219	if (( gvp = (GV**)hv_fetchs(stash, "ISA", FALSE) )) {
	220	if(isGV(gvp) && GvAV(gvp) && av_len(GvAV(*gvp)) != -1){
	221	return TRUE;
	222	}
	223	}
	224
	225	hv_iterinit(stash);
	226	while(( he = hv_iternext(stash) )){
	227	GV* const gv = (GV*)HeVAL(he);
	228
	229	if(isGV(gv)){
fa4ac648	230	if(GvCVu(gv)){ /* is GV and has CV */
fa4ac648	231	hv_iterinit(stash); /* reset */
646c0371	232	return TRUE;
	233	}
	234	}
fa4ac648	235	else if(SvOK(gv)){ /* is a stub or constant */
fa4ac648	236	hv_iterinit(stash); /* reset */
646c0371	237	return TRUE;
	238	}
	239	}
	240	return FALSE;
	241	}
	242
	243
0aad0266	244	SV*
0aad0266	245	mouse_call0 (pTHX_ SV* const self, SV* const method) {
646c0371	246	dSP;
	247	SV *ret;
	248
	249	PUSHMARK(SP);
	250	XPUSHs(self);
	251	PUTBACK;
	252
b3cd4c14	253	call_sv_safe(method, G_SCALAR \| G_METHOD);
646c0371	254
	255	SPAGAIN;
	256	ret = POPs;
	257	PUTBACK;
	258
	259	return ret;
	260	}
	261
0aad0266	262	SV*
0aad0266	263	mouse_call1 (pTHX_ SV* const self, SV* const method, SV* const arg1) {
646c0371	264	dSP;
	265	SV *ret;
	266
	267	PUSHMARK(SP);
	268	EXTEND(SP, 2);
	269	PUSHs(self);
	270	PUSHs(arg1);
	271	PUTBACK;
	272
b3cd4c14	273	call_sv_safe(method, G_SCALAR \| G_METHOD);
646c0371	274
	275	SPAGAIN;
	276	ret = POPs;
	277	PUTBACK;
	278
	279	return ret;
	280	}
	281
0aad0266	282	int
0aad0266	283	mouse_predicate_call(pTHX_ SV* const self, SV* const method) {
6ad77996	284	return sv_true( mcall0(self, method) );
0aad0266	285	}
0aad0266	286
a39e9541	287	SV*
aa2d2e2c	288	mouse_get_metaclass(pTHX_ SV* metaclass_name){
fd168725	289	dMY_CXT;
fd168725	290	HE* he;
a39e9541	291
aa2d2e2c	292	assert(metaclass_name);
fd168725	293	assert(MY_CXT.metas);
fd168725	294
aa2d2e2c	295	if(IsObject(metaclass_name)){
a5c683f6	296	HV* const stash = SvSTASH(SvRV(metaclass_name));
aa2d2e2c	297
	298	metaclass_name = newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U);
	299	sv_2mortal(metaclass_name);
	300	}
	301
fd168725	302	he = hv_fetch_ent(MY_CXT.metas, metaclass_name, FALSE, 0U);
a39e9541	303
fd168725	304	return he ? HeVAL(he) : &PL_sv_undef;
a39e9541	305	}
a39e9541	306
646c0371	307	MAGIC*
	308	mouse_mg_find(pTHX_ SV* const sv, const MGVTBL* const vtbl, I32 const flags){
	309	MAGIC* mg;
	310
	311	assert(sv != NULL);
	312	for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic){
	313	if(mg->mg_virtual == vtbl){
	314	return mg;
	315	}
	316	}
	317
	318	if(flags & MOUSEf_DIE_ON_FAIL){
	319	croak("mouse_mg_find: no MAGIC found for %"SVf, sv_2mortal(newRV_inc(sv)));
	320	}
	321	return NULL;
	322	}
	323
a39e9541	324	GV*
	325	mouse_stash_fetch(pTHX_ HV* const stash, const char* const name, I32 const namelen, I32 const create) {
	326	GV const gvp = (GV)hv_fetch(stash, name, namelen, create);
	327
	328	if(gvp){
	329	if(!isGV(*gvp)){
	330	gv_init(*gvp, stash, name, namelen, GV_ADDMULTI);
	331	}
	332	return *gvp;
	333	}
	334	else{
	335	return NULL;
	336	}
	337	}
	338
d67f600d	339	void
	340	mouse_install_sub(pTHX_ GV* const gv, SV* const code_ref) {
	341	CV* cv;
	342
	343	assert(gv != NULL);
	344	assert(code_ref != NULL);
	345	assert(isGV(gv));
	346	assert(IsCodeRef(code_ref));
	347
	348	if(GvCVu(gv)){ /* delete slot{gv} to work around "redefine" warning /
	349	SvREFCNT_dec(GvCV(gv));
	350	GvCV(gv) = NULL;
	351	}
d06d9266	352
d67f600d	353	sv_setsv_mg((SV)gv, code_ref); / gv = $code_ref /
	354
	355	/* name the CODE ref if it's anonymous */
	356	cv = (CV*)SvRV(code_ref);
	357	if(CvANON(cv)
	358	&& CvGV(cv) /* a cv under construction has no gv */ ){
	359	HV* dbsub;
	360
	361	/* update %DB::sub to make NYTProf happy */
	362	if((PL_perldb & (PERLDBf_SUBLINE\|PERLDB_NAMEANON))
	363	&& PL_DBsub && (dbsub = GvHV(PL_DBsub))
	364	){
	365	/* see Perl_newATTRSUB() in op.c */
	366	SV* const subname = sv_newmortal();
	367	HE* orig;
	368
	369	gv_efullname3(subname, CvGV(cv), NULL);
	370	orig = hv_fetch_ent(dbsub, subname, FALSE, 0U);
	371	if(orig){
	372	gv_efullname3(subname, gv, NULL);
	373	(void)hv_store_ent(dbsub, subname, HeVAL(orig), 0U);
	374	SvREFCNT_inc_simple_void_NN(HeVAL(orig));
	375	}
	376	}
	377
	378	CvGV(cv) = gv;
	379	CvANON_off(cv);
	380	}
	381	}
	382
646c0371	383	MODULE = Mouse::Util PACKAGE = Mouse::Util
	384
	385	PROTOTYPES: DISABLE
	386	VERSIONCHECK: DISABLE
	387
fd168725	388	BOOT:
	389	{
	390	MY_CXT_INIT;
	391	MY_CXT.metas = NULL;
	392	}
	393
	394	void
	395	__register_metaclass_storage(HV* metas, bool cloning)
	396	CODE:
	397	{
	398	if(cloning){
	399	MY_CXT_CLONE;
	400	MY_CXT.metas = NULL;
	401	}
	402	{
	403	dMY_CXT;
25ba356e	404	if(MY_CXT.metas && ckWARN(WARN_REDEFINE)){
	405	Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Metaclass storage more than once");
	406	}
fd168725	407	MY_CXT.metas = metas;
	408	SvREFCNT_inc_simple_void_NN(metas);
	409	}
	410	}
	411
646c0371	412	bool
0ffc4183	413	is_valid_class_name(SV* sv)
	414	CODE:
	415	{
	416	SvGETMAGIC(sv);
	417	if(SvPOKp(sv) && SvCUR(sv) > 0){
	418	UV i;
	419	RETVAL = TRUE;
	420	for(i = 0; i < SvCUR(sv); i++){
	421	char const c = SvPVX(sv)[i];
	422	if(!(isALNUM(c) \|\| c == ':')){
	423	RETVAL = FALSE;
	424	break;
	425	}
	426	}
	427	}
	428	else{
	429	RETVAL = SvNIOKp(sv) ? TRUE : FALSE;
	430	}
	431	}
	432	OUTPUT:
	433	RETVAL
	434
	435	bool
646c0371	436	is_class_loaded(SV* sv)
	437
	438	void
	439	get_code_info(CV* code)
	440	PREINIT:
	441	GV* gv;
	442	HV* stash;
	443	PPCODE:
	444	if((gv = CvGV(code)) && isGV(gv) && (stash = GvSTASH(gv))){
	445	EXTEND(SP, 2);
	446	mPUSHs(newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U));
	447	mPUSHs(newSVpvn_share(GvNAME_get(gv), GvNAMELEN_get(gv), 0U));
	448	}
	449
	450	SV*
	451	get_code_package(CV* code)
	452	PREINIT:
	453	HV* stash;
	454	CODE:
	455	if(CvGV(code) && isGV(CvGV(code)) && (stash = GvSTASH(CvGV(code)))){
	456	RETVAL = newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U);
	457	}
	458	else{
	459	RETVAL = &PL_sv_no;
	460	}
	461	OUTPUT:
	462	RETVAL
	463
	464	CV*
	465	get_code_ref(SV* package, SV* name)
	466	CODE:
	467	{
	468	HV* stash;
a39e9541	469	STRLEN name_len;
	470	const char* name_pv;
	471	GV* gv;
646c0371	472
d06d9266	473	must_defined(package, "a package name");
d06d9266	474	must_defined(name, "a subroutine name");
646c0371	475
	476	stash = gv_stashsv(package, FALSE);
	477	if(!stash){
	478	XSRETURN_UNDEF;
	479	}
a39e9541	480
	481	name_pv = SvPV_const(name, name_len);
	482	gv = stash_fetch(stash, name_pv, name_len, FALSE);
	483	RETVAL = gv ? GvCVu(gv) : NULL;
646c0371	484
	485	if(!RETVAL){
	486	XSRETURN_UNDEF;
	487	}
	488	}
	489	OUTPUT:
	490	RETVAL
	491
	492	void
ebe91068	493	generate_isa_predicate_for(SV* arg, SV* predicate_name = NULL)
	494	ALIAS:
	495	generate_isa_predicate_for = 0
	496	generate_can_predicate_for = 1
646c0371	497	PPCODE:
646c0371	498	{
441964ce	499	const char* name_pv = NULL;
646c0371	500	CV* xsub;
646c0371	501
d06d9266	502	must_defined(arg, ix == 0 ? "a class_name" : "method names");
646c0371	503
441964ce	504	if(predicate_name){
d06d9266	505	must_defined(predicate_name, "a predicate name");
441964ce	506	name_pv = SvPV_nolen_const(predicate_name);
646c0371	507	}
646c0371	508
ebe91068	509	if(ix == 0){
	510	xsub = mouse_generate_isa_predicate_for(aTHX_ arg, name_pv);
	511	}
	512	else{
	513	xsub = mouse_generate_can_predicate_for(aTHX_ arg, name_pv);
	514	}
441964ce	515
646c0371	516	if(predicate_name == NULL){ /* anonymous predicate */
73337709	517	mXPUSHs( newRV_inc((SV*)xsub) );
646c0371	518	}
646c0371	519	}
d67f600d	520
	521	# This xsub will redefine &Mouse::Util::install_subroutines()
	522	void
	523	install_subroutines(SV* into, ...)
	524	CODE:
	525	{
	526	HV* stash;
	527	I32 i;
	528
d06d9266	529	must_defined(into, "a package name");
d67f600d	530	stash = gv_stashsv(into, TRUE);
	531
	532	if( ((items-1) % 2) != 0 ){
	533	croak_xs_usage(cv, "into, name => coderef [, other_name, other_coderef ...]");
	534	}
	535
	536	for(i = 1; i < items; i += 2) {
	537	SV* const name = ST(i);
	538	SV* const code = ST(i+1);
	539	STRLEN len;
	540	const char* pv;
	541	GV* gv;
	542
d06d9266	543	must_defined(name, "a subroutine name");
d06d9266	544	must_ref(code, "a CODE reference", SVt_PVCV);
d67f600d	545
	546	pv = SvPV_const(name, len);
	547	gv = stash_fetch(stash, pv, len, TRUE);
	548
	549	mouse_install_sub(aTHX_ gv, code);
	550	}
	551	}