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

/*
 *   full definition of built-in type constraints (ware in Moose::Util::TypeConstraints::OptimizedConstraints)
 */

#include "mouse.h"

#if PERL_BCDVERSION >= 0x5008005
#define LooksLikeNumber(sv) looks_like_number(sv)
#else
#define LooksLikeNumber(sv) ( SvPOKp(sv) ? looks_like_number(sv) : SvNIOKp(sv) )
#endif

#ifndef SvRXOK
#define SvRXOK(sv) (SvROK(sv) && SvMAGICAL(SvRV(sv)) && mg_find(SvRV(sv), PERL_MAGIC_qr))
#endif

int
mouse_tc_check(pTHX_ SV* const tc_code, SV* const sv) {
    if(SvIOK(tc_code)){ /* built-in type constraints */
        return mouse_builtin_tc_check(aTHX_ SvIVX(tc_code), sv);
    }
    else {
        int ok;
        dSP;

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);
        XPUSHs(sv);
        PUTBACK;

        call_sv(tc_code, G_SCALAR);

        SPAGAIN;
        ok = SvTRUEx(POPs);
        PUTBACK;

        FREETMPS;
        LEAVE;

        return ok;
    }
}

int
mouse_builtin_tc_check(pTHX_ mouse_tc const tc, SV* const sv) {
    switch(tc){
    case MOUSE_TC_ANY:        return mouse_tc_Any(aTHX_ sv);
    case MOUSE_TC_ITEM:       return mouse_tc_Any(aTHX_ sv);
    case MOUSE_TC_UNDEF:      return mouse_tc_Undef(aTHX_ sv);
    case MOUSE_TC_DEFINED:    return mouse_tc_Defined(aTHX_ sv);
    case MOUSE_TC_BOOL:       return mouse_tc_Bool(aTHX_ sv);
    case MOUSE_TC_VALUE:      return mouse_tc_Value(aTHX_ sv);
    case MOUSE_TC_REF:        return mouse_tc_Ref(aTHX_ sv);
    case MOUSE_TC_STR:        return mouse_tc_Str(aTHX_ sv);
    case MOUSE_TC_NUM:        return mouse_tc_Num(aTHX_ sv);
    case MOUSE_TC_INT:        return mouse_tc_Int(aTHX_ sv);
    case MOUSE_TC_SCALAR_REF: return mouse_tc_ScalarRef(aTHX_ sv);
    case MOUSE_TC_ARRAY_REF:  return mouse_tc_ArrayRef(aTHX_ sv);
    case MOUSE_TC_HASH_REF:   return mouse_tc_HashRef(aTHX_ sv);
    case MOUSE_TC_CODE_REF:   return mouse_tc_CodeRef(aTHX_ sv);
    case MOUSE_TC_GLOB_REF:   return mouse_tc_GlobRef(aTHX_ sv);
    case MOUSE_TC_FILEHANDLE: return mouse_tc_FileHandle(aTHX_ sv);
    case MOUSE_TC_REGEXP_REF: return mouse_tc_RegexpRef(aTHX_ sv);
    case MOUSE_TC_OBJECT:     return mouse_tc_Object(aTHX_ sv);
    case MOUSE_TC_CLASS_NAME: return mouse_tc_ClassName(aTHX_ sv);
    case MOUSE_TC_ROLE_NAME:  return mouse_tc_RoleName(aTHX_ sv);
    default:
        /* custom type constraints */
        NOOP;
    }

    croak("Custom type constraint is not yet implemented");
    return FALSE; /* not reached */
}


/*
    The following type check functions return an integer, not a bool, to keep them simple,
    so if you assign these return value to bool variable, you must use "expr ? TRUE : FALSE".
*/

int
mouse_tc_Any(pTHX_ SV* const sv PERL_UNUSED_DECL) {
    assert(sv);
    return TRUE;
}

int
mouse_tc_Bool(pTHX_ SV* const sv) {
    assert(sv);
    if(SvOK(sv)){
        if(SvIOKp(sv)){
            return SvIVX(sv) == 1 || SvIVX(sv) == 0;
        }
        else if(SvNOKp(sv)){
            return SvNVX(sv) == 1.0 || SvNVX(sv) == 0.0;
        }
        else if(SvPOKp(sv)){ /* "" or "1" or "0" */
            return SvCUR(sv) == 0
                || ( SvCUR(sv) == 1 && ( SvPVX(sv)[0] == '1' || SvPVX(sv)[0] == '0' ) );
        }
        else{
            return FALSE;
        }
    }
    else{
        return TRUE;
    }
}

int
mouse_tc_Undef(pTHX_ SV* const sv) {
    assert(sv);
    return !SvOK(sv);
}

int
mouse_tc_Defined(pTHX_ SV* const sv) {
    assert(sv);
    return SvOK(sv);
}

int
mouse_tc_Value(pTHX_ SV* const sv) {
    assert(sv);
    return SvOK(sv) && !SvROK(sv);
}

int
mouse_tc_Num(pTHX_ SV* const sv) {
    assert(sv);
    return LooksLikeNumber(sv);
}

int
mouse_tc_Int(pTHX_ SV* const sv) {
    assert(sv);
    if(SvIOKp(sv)){
        return TRUE;
    }
    else if(SvNOKp(sv)){
        NV const nv = SvNVX(sv);
        return nv > 0 ? (nv == (NV)(UV)nv) : (nv == (NV)(IV)nv);
    }
    else if(SvPOKp(sv)){
        int const num_type = grok_number(SvPVX(sv), SvCUR(sv), NULL);
        if(num_type){
            return !(num_type & IS_NUMBER_NOT_INT);
        }
    }
    return FALSE;
}

int
mouse_tc_Str(pTHX_ SV* const sv) {
    assert(sv);
    return SvOK(sv) && !SvROK(sv) && !isGV(sv);
}

int
mouse_tc_ClassName(pTHX_ SV* const sv){ 
    assert(sv);
    return is_class_loaded(sv);
}

int
mouse_tc_RoleName(pTHX_ SV* const sv) {
    assert(sv);
    if(is_class_loaded(sv)){
        int ok;
        SV* meta;
        dSP;

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);
        XPUSHs(sv);
        PUTBACK;
        call_pv("Mouse::Util::get_metaclass_by_name", G_SCALAR);
        SPAGAIN;
        meta = POPs;
        PUTBACK;

        ok =  is_instance_of(meta, newSVpvs_flags("Mouse::Meta::Role", SVs_TEMP));

        FREETMPS;
        LEAVE;

        return ok;
    }
    return FALSE;
}

int
mouse_tc_Ref(pTHX_ SV* const sv) {
    assert(sv);
    return SvROK(sv);
}

int
mouse_tc_ScalarRef(pTHX_ SV* const sv) {
    assert(sv);
    return SvROK(sv) && !SvOBJECT(SvRV(sv)) && (SvTYPE(SvRV(sv)) <= SVt_PVLV && !isGV(SvRV(sv)));
}

int
mouse_tc_ArrayRef(pTHX_ SV* const sv) {
    assert(sv);
    return SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVAV;
}

int
mouse_tc_HashRef(pTHX_ SV* const sv) {
    assert(sv);
    return SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVHV;
}

int
mouse_tc_CodeRef(pTHX_ SV* const sv) {
    assert(sv);
    return SvROK(sv)  && !SvOBJECT(SvRV(sv))&& SvTYPE(SvRV(sv)) == SVt_PVCV;
}

int
mouse_tc_RegexpRef(pTHX_ SV* const sv) {
    assert(sv);
    return SvRXOK(sv);
}

int
mouse_tc_GlobRef(pTHX_ SV* const sv) {
    assert(sv);
    return SvROK(sv) && !SvOBJECT(SvRV(sv)) && isGV(SvRV(sv));
}

int
mouse_tc_FileHandle(pTHX_ SV* const sv) {
    GV* gv;
    assert(sv);

    /* see pp_fileno() in pp_sys.c and Scalar::Util::openhandle() */

    gv = (GV*)(SvROK(sv) ? SvRV(sv) : sv);
    if(isGV(gv) || SvTYPE(gv) == SVt_PVIO){
        IO* const io = isGV(gv) ? GvIO(gv) : (IO*)gv;

        if(io && ( IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar) )){
            return TRUE;
        }
    }

    return is_instance_of(sv, newSVpvs_flags("IO::Handle", SVs_TEMP));
}

int
mouse_tc_Object(pTHX_ SV* const sv) {
    assert(sv);
    return SvROK(sv) && SvOBJECT(SvRV(sv)) && !SvRXOK(sv);
}

/*
 *  This class_type generator is taken from Scalar::Util::Instance
 */

#define MY_CXT_KEY "Mouse::Util::TypeConstraints::_guts" XS_VERSION
typedef struct sui_cxt{
    GV* universal_isa;
} my_cxt_t;
START_MY_CXT

#define MG_klass_stash(mg) ((HV*)(mg)->mg_obj)
#define MG_klass_pv(mg)    ((mg)->mg_ptr)
#define MG_klass_len(mg)   ((mg)->mg_len)

const char*
mouse_canonicalize_package_name(const char* name){

    /* "::Foo" -> "Foo" */
    if(name[0] == ':' && name[1] == ':'){
        name += 2;
    }

    /* "main::main::main::Foo" -> "Foo" */
    while(strnEQ(name, "main::", sizeof("main::")-1)){
        name += sizeof("main::")-1;
    }

    return name;
}

static int
lookup_isa(pTHX_ HV* const instance_stash, const char* const klass_pv){
    AV*  const linearized_isa = mro_get_linear_isa(instance_stash);
    SV**       svp            = AvARRAY(linearized_isa);
    SV** const end            = svp + AvFILLp(linearized_isa) + 1;

    while(svp != end){
        assert(SvPVX(*svp));
        if(strEQ(klass_pv, mouse_canonicalize_package_name(SvPVX(*svp)))){
            return TRUE;
        }
        svp++;
    }
    return FALSE;
}

static int
instance_isa(pTHX_ SV* const instance, const MAGIC* const mg){
    dMY_CXT;
    HV* const instance_stash = SvSTASH(SvRV(instance));
    GV* const instance_isa   = gv_fetchmeth_autoload(instance_stash, "isa", sizeof("isa")-1, 0);

    /* the instance has no own isa method */
    if(instance_isa == NULL || GvCV(instance_isa) == GvCV(MY_CXT.universal_isa)){
        return MG_klass_stash(mg) == instance_stash
            || lookup_isa(aTHX_ instance_stash, MG_klass_pv(mg));
    }
    /* the instance has its own isa method */
    else {
        int retval;
        dSP;

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);
        EXTEND(SP, 2);
        PUSHs(instance);
        mPUSHp(MG_klass_pv(mg), MG_klass_len(mg));
        PUTBACK;

        call_sv((SV*)instance_isa, G_SCALAR);

        SPAGAIN;

        retval = SvTRUEx(POPs);

        PUTBACK;

        FREETMPS;
        LEAVE;

        return retval;
    }
}


XS(XS_isa_check){
    dVAR;
    dXSARGS;
    SV* sv;

    assert(XSANY.any_ptr != NULL);

    if(items != 1){
        if(items < 1){
            croak("Not enough arguments for is-a predicate");
        }
        else{
            croak("Too many arguments for is-a predicate");
        }
    }

    sv = ST(0);
    SvGETMAGIC(sv);

    ST(0) = boolSV( SvROK(sv) && SvOBJECT(SvRV(sv)) && instance_isa(aTHX_ sv, (MAGIC*)XSANY.any_ptr) );
    XSRETURN(1);
}


XS(XS_isa_check_for_universal){
    dVAR;
    dXSARGS;
    SV* sv;
    PERL_UNUSED_VAR(cv);

    if(items != 1){
        if(items < 1){
            croak("Not enough arguments for is-a predicate");
        }
        else{
            croak("Too many arguments for is-a predicate");
        }
    }

    sv = ST(0);
    SvGETMAGIC(sv);

    ST(0) = boolSV( SvROK(sv) && SvOBJECT(SvRV(sv)) );
    XSRETURN(1);
}

static void
setup_my_cxt(pTHX_ pMY_CXT){
    MY_CXT.universal_isa = gv_fetchpvs("UNIVERSAL::isa", GV_ADD, SVt_PVCV);
    SvREFCNT_inc_simple_void_NN(MY_CXT.universal_isa);
}

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

PROTOTYPES:   DISABLE
VERSIONCHECK: DISABLE

BOOT:
{
    MY_CXT_INIT;
    setup_my_cxt(aTHX_ aMY_CXT);
}

#ifdef USE_ITHREADS

void
CLONE(...)
CODE:
{
    MY_CXT_CLONE;
    setup_my_cxt(aTHX_ aMY_CXT);
    PERL_UNUSED_VAR(items);
}

#endif /* !USE_ITHREADS */

void
Item(SV* sv = &PL_sv_undef)
ALIAS:
    Any        = MOUSE_TC_ANY
    Item       = MOUSE_TC_ITEM
    Undef      = MOUSE_TC_UNDEF
    Defined    = MOUSE_TC_DEFINED
    Bool       = MOUSE_TC_BOOL
    Value      = MOUSE_TC_VALUE
    Ref        = MOUSE_TC_REF
    Str        = MOUSE_TC_STR
    Num        = MOUSE_TC_NUM
    Int        = MOUSE_TC_INT
    ScalarRef  = MOUSE_TC_SCALAR_REF
    ArrayRef   = MOUSE_TC_ARRAY_REF
    HashRef    = MOUSE_TC_HASH_REF
    CodeRef    = MOUSE_TC_CODE_REF
    GlobRef    = MOUSE_TC_GLOB_REF
    FileHandle = MOUSE_TC_FILEHANDLE
    RegexpRef  = MOUSE_TC_REGEXP_REF
    Object     = MOUSE_TC_OBJECT
    ClassName  = MOUSE_TC_CLASS_NAME
    RoleName   = MOUSE_TC_ROLE_NAME
CODE:
    SvGETMAGIC(sv);
    ST(0) = boolSV( mouse_builtin_tc_check(aTHX_ ix, sv) );
    XSRETURN(1);
Commit	Line	Data
7d96ae4d	1	/*
	2	* full definition of built-in type constraints (ware in Moose::Util::TypeConstraints::OptimizedConstraints)
	3	*/
	4
	5	#include "mouse.h"
	6
	7	#if PERL_BCDVERSION >= 0x5008005
	8	#define LooksLikeNumber(sv) looks_like_number(sv)
	9	#else
	10	#define LooksLikeNumber(sv) ( SvPOKp(sv) ? looks_like_number(sv) : SvNIOKp(sv) )
	11	#endif
	12
	13	#ifndef SvRXOK
	14	#define SvRXOK(sv) (SvROK(sv) && SvMAGICAL(SvRV(sv)) && mg_find(SvRV(sv), PERL_MAGIC_qr))
	15	#endif
	16
1d5ecd5f	17	int
	18	mouse_tc_check(pTHX_ SV* const tc_code, SV* const sv) {
	19	if(SvIOK(tc_code)){ /* built-in type constraints */
	20	return mouse_builtin_tc_check(aTHX_ SvIVX(tc_code), sv);
	21	}
	22	else {
	23	int ok;
	24	dSP;
	25
	26	ENTER;
	27	SAVETMPS;
	28
	29	PUSHMARK(SP);
	30	XPUSHs(sv);
	31	PUTBACK;
	32
	33	call_sv(tc_code, G_SCALAR);
	34
	35	SPAGAIN;
	36	ok = SvTRUEx(POPs);
	37	PUTBACK;
	38
	39	FREETMPS;
	40	LEAVE;
	41
	42	return ok;
	43	}
	44	}
7d96ae4d	45
7d96ae4d	46	int
1d5ecd5f	47	mouse_builtin_tc_check(pTHX_ mouse_tc const tc, SV* const sv) {
7d96ae4d	48	switch(tc){
	49	case MOUSE_TC_ANY: return mouse_tc_Any(aTHX_ sv);
	50	case MOUSE_TC_ITEM: return mouse_tc_Any(aTHX_ sv);
	51	case MOUSE_TC_UNDEF: return mouse_tc_Undef(aTHX_ sv);
	52	case MOUSE_TC_DEFINED: return mouse_tc_Defined(aTHX_ sv);
	53	case MOUSE_TC_BOOL: return mouse_tc_Bool(aTHX_ sv);
	54	case MOUSE_TC_VALUE: return mouse_tc_Value(aTHX_ sv);
	55	case MOUSE_TC_REF: return mouse_tc_Ref(aTHX_ sv);
	56	case MOUSE_TC_STR: return mouse_tc_Str(aTHX_ sv);
	57	case MOUSE_TC_NUM: return mouse_tc_Num(aTHX_ sv);
	58	case MOUSE_TC_INT: return mouse_tc_Int(aTHX_ sv);
	59	case MOUSE_TC_SCALAR_REF: return mouse_tc_ScalarRef(aTHX_ sv);
	60	case MOUSE_TC_ARRAY_REF: return mouse_tc_ArrayRef(aTHX_ sv);
	61	case MOUSE_TC_HASH_REF: return mouse_tc_HashRef(aTHX_ sv);
	62	case MOUSE_TC_CODE_REF: return mouse_tc_CodeRef(aTHX_ sv);
	63	case MOUSE_TC_GLOB_REF: return mouse_tc_GlobRef(aTHX_ sv);
	64	case MOUSE_TC_FILEHANDLE: return mouse_tc_FileHandle(aTHX_ sv);
	65	case MOUSE_TC_REGEXP_REF: return mouse_tc_RegexpRef(aTHX_ sv);
	66	case MOUSE_TC_OBJECT: return mouse_tc_Object(aTHX_ sv);
	67	case MOUSE_TC_CLASS_NAME: return mouse_tc_ClassName(aTHX_ sv);
	68	case MOUSE_TC_ROLE_NAME: return mouse_tc_RoleName(aTHX_ sv);
	69	default:
	70	/* custom type constraints */
	71	NOOP;
	72	}
	73
	74	croak("Custom type constraint is not yet implemented");
	75	return FALSE; /* not reached */
	76	}
	77
	78
	79	/*
	80	The following type check functions return an integer, not a bool, to keep them simple,
	81	so if you assign these return value to bool variable, you must use "expr ? TRUE : FALSE".
	82	*/
	83
	84	int
	85	mouse_tc_Any(pTHX_ SV* const sv PERL_UNUSED_DECL) {
	86	assert(sv);
	87	return TRUE;
	88	}
	89
	90	int
	91	mouse_tc_Bool(pTHX_ SV* const sv) {
	92	assert(sv);
	93	if(SvOK(sv)){
	94	if(SvIOKp(sv)){
	95	return SvIVX(sv) == 1 \|\| SvIVX(sv) == 0;
	96	}
	97	else if(SvNOKp(sv)){
	98	return SvNVX(sv) == 1.0 \|\| SvNVX(sv) == 0.0;
	99	}
	100	else if(SvPOKp(sv)){ /* "" or "1" or "0" */
	101	return SvCUR(sv) == 0
	102	\|\| ( SvCUR(sv) == 1 && ( SvPVX(sv)[0] == '1' \|\| SvPVX(sv)[0] == '0' ) );
	103	}
	104	else{
	105	return FALSE;
	106	}
	107	}
	108	else{
	109	return TRUE;
	110	}
	111	}
112
113	int
114	mouse_tc_Undef(pTHX_ SV* const sv) {
115	assert(sv);
116	return !SvOK(sv);
117	}
118
119	int
120	mouse_tc_Defined(pTHX_ SV* const sv) {
121	assert(sv);
122	return SvOK(sv);
123	}
124
125	int
126	mouse_tc_Value(pTHX_ SV* const sv) {
127	assert(sv);
128	return SvOK(sv) && !SvROK(sv);
129	}
130
131	int
132	mouse_tc_Num(pTHX_ SV* const sv) {
133	assert(sv);
134	return LooksLikeNumber(sv);
135	}
136
137	int
138	mouse_tc_Int(pTHX_ SV* const sv) {
139	assert(sv);
140	if(SvIOKp(sv)){
141	return TRUE;
142	}
143	else if(SvNOKp(sv)){
144	NV const nv = SvNVX(sv);
145	return nv > 0 ? (nv == (NV)(UV)nv) : (nv == (NV)(IV)nv);
146	}
147	else if(SvPOKp(sv)){
148	int const num_type = grok_number(SvPVX(sv), SvCUR(sv), NULL);
149	if(num_type){
150	return !(num_type & IS_NUMBER_NOT_INT);
151	}
152	}
153	return FALSE;
154	}
155
156	int
157	mouse_tc_Str(pTHX_ SV* const sv) {
158	assert(sv);
159	return SvOK(sv) && !SvROK(sv) && !isGV(sv);
160	}
161
162	int
163	mouse_tc_ClassName(pTHX_ SV* const sv){
164	assert(sv);
165	return is_class_loaded(sv);
166	}
167
168	int
169	mouse_tc_RoleName(pTHX_ SV* const sv) {
170	assert(sv);
171	if(is_class_loaded(sv)){
172	int ok;
173	SV* meta;
174	dSP;
175
176	ENTER;
177	SAVETMPS;
178
179	PUSHMARK(SP);
180	XPUSHs(sv);
181	PUTBACK;
182	call_pv("Mouse::Util::get_metaclass_by_name", G_SCALAR);
183	SPAGAIN;
184	meta = POPs;
185	PUTBACK;
186
187	ok = is_instance_of(meta, newSVpvs_flags("Mouse::Meta::Role", SVs_TEMP));
188
189	FREETMPS;
190	LEAVE;
191
192	return ok;
193	}
194	return FALSE;
195	}
196
197	int
198	mouse_tc_Ref(pTHX_ SV* const sv) {
199	assert(sv);
200	return SvROK(sv);
201	}
202
203	int
204	mouse_tc_ScalarRef(pTHX_ SV* const sv) {
205	assert(sv);
206	return SvROK(sv) && !SvOBJECT(SvRV(sv)) && (SvTYPE(SvRV(sv)) <= SVt_PVLV && !isGV(SvRV(sv)));
207	}
208
209	int
210	mouse_tc_ArrayRef(pTHX_ SV* const sv) {
211	assert(sv);
212	return SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVAV;
213	}
214
215	int
216	mouse_tc_HashRef(pTHX_ SV* const sv) {
217	assert(sv);
218	return SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVHV;
219	}
220
221	int
222	mouse_tc_CodeRef(pTHX_ SV* const sv) {
223	assert(sv);
224	return SvROK(sv) && !SvOBJECT(SvRV(sv))&& SvTYPE(SvRV(sv)) == SVt_PVCV;
225	}
226
227	int
228	mouse_tc_RegexpRef(pTHX_ SV* const sv) {
229	assert(sv);
230	return SvRXOK(sv);
231	}
232
233	int
234	mouse_tc_GlobRef(pTHX_ SV* const sv) {
235	assert(sv);
236	return SvROK(sv) && !SvOBJECT(SvRV(sv)) && isGV(SvRV(sv));
237	}
238
239	int
240	mouse_tc_FileHandle(pTHX_ SV* const sv) {
241	GV* gv;
242	assert(sv);
243
244	/* see pp_fileno() in pp_sys.c and Scalar::Util::openhandle() */
245
246	gv = (GV*)(SvROK(sv) ? SvRV(sv) : sv);
247	if(isGV(gv) \|\| SvTYPE(gv) == SVt_PVIO){
248	IO* const io = isGV(gv) ? GvIO(gv) : (IO*)gv;
249
250	if(io && ( IoIFP(io) \|\| SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar) )){
251	return TRUE;
252	}
253	}
254
255	return is_instance_of(sv, newSVpvs_flags("IO::Handle", SVs_TEMP));
256	}
257
258	int
259	mouse_tc_Object(pTHX_ SV* const sv) {
260	assert(sv);
261	return SvROK(sv) && SvOBJECT(SvRV(sv)) && !SvRXOK(sv);
262	}
263
1d5ecd5f	264	/*
	265	* This class_type generator is taken from Scalar::Util::Instance
	266	*/
	267
	268	#define MY_CXT_KEY "Mouse::Util::TypeConstraints::_guts" XS_VERSION
	269	typedef struct sui_cxt{
	270	GV* universal_isa;
	271	} my_cxt_t;
	272	START_MY_CXT
	273
	274	#define MG_klass_stash(mg) ((HV*)(mg)->mg_obj)
	275	#define MG_klass_pv(mg) ((mg)->mg_ptr)
	276	#define MG_klass_len(mg) ((mg)->mg_len)
	277
f48920c1	278	const char*
f48920c1	279	mouse_canonicalize_package_name(const char* name){
1d5ecd5f	280
	281	/* "::Foo" -> "Foo" */
	282	if(name[0] == ':' && name[1] == ':'){
	283	name += 2;
	284	}
	285
	286	/* "main::main::main::Foo" -> "Foo" */
	287	while(strnEQ(name, "main::", sizeof("main::")-1)){
	288	name += sizeof("main::")-1;
	289	}
	290
	291	return name;
	292	}
	293
	294	static int
	295	lookup_isa(pTHX_ HV* const instance_stash, const char* const klass_pv){
	296	AV* const linearized_isa = mro_get_linear_isa(instance_stash);
	297	SV** svp = AvARRAY(linearized_isa);
	298	SV** const end = svp + AvFILLp(linearized_isa) + 1;
	299
	300	while(svp != end){
	301	assert(SvPVX(*svp));
f48920c1	302	if(strEQ(klass_pv, mouse_canonicalize_package_name(SvPVX(*svp)))){
1d5ecd5f	303	return TRUE;
	304	}
	305	svp++;
	306	}
	307	return FALSE;
	308	}
	309
	310	static int
	311	instance_isa(pTHX_ SV* const instance, const MAGIC* const mg){
	312	dMY_CXT;
	313	HV* const instance_stash = SvSTASH(SvRV(instance));
	314	GV* const instance_isa = gv_fetchmeth_autoload(instance_stash, "isa", sizeof("isa")-1, 0);
	315
	316	/* the instance has no own isa method */
	317	if(instance_isa == NULL \|\| GvCV(instance_isa) == GvCV(MY_CXT.universal_isa)){
	318	return MG_klass_stash(mg) == instance_stash
	319	\|\| lookup_isa(aTHX_ instance_stash, MG_klass_pv(mg));
	320	}
	321	/* the instance has its own isa method */
	322	else {
	323	int retval;
	324	dSP;
	325
	326	ENTER;
	327	SAVETMPS;
	328
	329	PUSHMARK(SP);
	330	EXTEND(SP, 2);
	331	PUSHs(instance);
	332	mPUSHp(MG_klass_pv(mg), MG_klass_len(mg));
	333	PUTBACK;
	334
	335	call_sv((SV*)instance_isa, G_SCALAR);
	336
	337	SPAGAIN;
	338
	339	retval = SvTRUEx(POPs);
	340
	341	PUTBACK;
	342
	343	FREETMPS;
	344	LEAVE;
	345
	346	return retval;
	347	}
	348	}
	349
f48920c1	350
1d5ecd5f	351	XS(XS_isa_check){
	352	dVAR;
	353	dXSARGS;
	354	SV* sv;
	355
	356	assert(XSANY.any_ptr != NULL);
	357
	358	if(items != 1){
	359	if(items < 1){
	360	croak("Not enough arguments for is-a predicate");
	361	}
	362	else{
	363	croak("Too many arguments for is-a predicate");
	364	}
	365	}
	366
	367	sv = ST(0);
	368	SvGETMAGIC(sv);
	369
	370	ST(0) = boolSV( SvROK(sv) && SvOBJECT(SvRV(sv)) && instance_isa(aTHX_ sv, (MAGIC*)XSANY.any_ptr) );
	371	XSRETURN(1);
	372	}
	373
f48920c1	374
1d5ecd5f	375	XS(XS_isa_check_for_universal){
	376	dVAR;
	377	dXSARGS;
	378	SV* sv;
	379	PERL_UNUSED_VAR(cv);
	380
	381	if(items != 1){
	382	if(items < 1){
	383	croak("Not enough arguments for is-a predicate");
	384	}
	385	else{
	386	croak("Too many arguments for is-a predicate");
	387	}
	388	}
	389
	390	sv = ST(0);
	391	SvGETMAGIC(sv);
	392
	393	ST(0) = boolSV( SvROK(sv) && SvOBJECT(SvRV(sv)) );
	394	XSRETURN(1);
	395	}
	396
	397	static void
	398	setup_my_cxt(pTHX_ pMY_CXT){
	399	MY_CXT.universal_isa = gv_fetchpvs("UNIVERSAL::isa", GV_ADD, SVt_PVCV);
	400	SvREFCNT_inc_simple_void_NN(MY_CXT.universal_isa);
	401	}
	402
	403	MODULE = Mouse::Util::TypeConstraints PACKAGE = Mouse::Util::TypeConstraints
	404
646c0371	405	PROTOTYPES: DISABLE
646c0371	406	VERSIONCHECK: DISABLE
1d5ecd5f	407
	408	BOOT:
	409	{
	410	MY_CXT_INIT;
	411	setup_my_cxt(aTHX_ aMY_CXT);
	412	}
	413
	414	#ifdef USE_ITHREADS
	415
	416	void
	417	CLONE(...)
	418	CODE:
	419	{
	420	MY_CXT_CLONE;
	421	setup_my_cxt(aTHX_ aMY_CXT);
	422	PERL_UNUSED_VAR(items);
	423	}
	424
	425	#endif /* !USE_ITHREADS */
	426
	427	void
1d5ecd5f	428	Item(SV* sv = &PL_sv_undef)
	429	ALIAS:
	430	Any = MOUSE_TC_ANY
	431	Item = MOUSE_TC_ITEM
	432	Undef = MOUSE_TC_UNDEF
	433	Defined = MOUSE_TC_DEFINED
	434	Bool = MOUSE_TC_BOOL
	435	Value = MOUSE_TC_VALUE
	436	Ref = MOUSE_TC_REF
	437	Str = MOUSE_TC_STR
	438	Num = MOUSE_TC_NUM
	439	Int = MOUSE_TC_INT
	440	ScalarRef = MOUSE_TC_SCALAR_REF
	441	ArrayRef = MOUSE_TC_ARRAY_REF
	442	HashRef = MOUSE_TC_HASH_REF
	443	CodeRef = MOUSE_TC_CODE_REF
	444	GlobRef = MOUSE_TC_GLOB_REF
	445	FileHandle = MOUSE_TC_FILEHANDLE
	446	RegexpRef = MOUSE_TC_REGEXP_REF
	447	Object = MOUSE_TC_OBJECT
	448	ClassName = MOUSE_TC_CLASS_NAME
	449	RoleName = MOUSE_TC_ROLE_NAME
	450	CODE:
	451	SvGETMAGIC(sv);
	452	ST(0) = boolSV( mouse_builtin_tc_check(aTHX_ ix, sv) );
	453	XSRETURN(1);
	454
	455