[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)

static 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
mouse_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;
}

int
mouse_is_an_instance_of(pTHX_ HV* const stash, SV* const instance){
    assert(stash);
    assert(SvTYPE(stash) == SVt_PVHV);

    if(SvROK(instance) && SvOBJECT(SvRV(instance))){
        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 stash == instance_stash
                || mouse_lookup_isa(aTHX_ instance_stash, HvNAME_get(stash));
        }
        /* the instance has its own isa method */
        else {
            int retval;
            dSP;

            ENTER;
            SAVETMPS;

            PUSHMARK(SP);
            EXTEND(SP, 2);
            PUSHs(instance);
            mPUSHp(HvNAME_get(stash), HvNAMELEN_get(stash));
            PUTBACK;

            call_sv((SV*)instance_isa, G_SCALAR);

            SPAGAIN;

            retval = SvTRUEx(POPs);

            PUTBACK;

            FREETMPS;
            LEAVE;

            return retval;
        }
    }
    return FALSE;
}

static int
mouse_is_an_instance_of_universal(pTHX_ SV* const data, SV* const sv){
    PERL_UNUSED_ARG(data);
    return SvROK(sv) && SvOBJECT(SvRV(sv));
}

static MGVTBL mouse_util_type_constraints_vtbl; /* not used, only for identity */

CV*
mouse_generate_isa_predicate_for(pTHX_ SV* const klass, const char* const predicate_name){
    STRLEN klass_len;
    const char* klass_pv = SvPV_const(klass, klass_len);
    CV* xsub;
    SV*   mg_obj;
    void* mg_ptr;

    klass_pv = mouse_canonicalize_package_name(klass_pv);

    if(strNE(klass_pv, "UNIVERSAL")){
        mg_obj = (SV*)gv_stashpvn(klass_pv, klass_len, GV_ADD);
        mg_ptr = (void*)mouse_is_an_instance_of;

    }
    else{
        mg_obj = NULL;
        mg_ptr = (void*)mouse_is_an_instance_of_universal;
    }

    xsub = newXS(predicate_name, XS_Mouse_parameterized_check, __FILE__);

    CvXSUBANY(xsub).any_ptr = sv_magicext(
        (SV*)xsub,
        mg_obj,
        PERL_MAGIC_ext,
        &mouse_util_type_constraints_vtbl,
        mg_ptr,
        0   /* indicates static data */
    );

    if(!predicate_name){
        sv_2mortal((SV*)xsub);
    }

    return xsub;
}

XS(XS_Mouse_parameterized_check) {
    dVAR;
    dXSARGS;
    MAGIC* const mg = (MAGIC*)XSANY.any_ptr;
    typedef int (*check_fptr_t)(pTHX_ SV* const data, SV* const sv);

    if(items < 1){
        croak("Too few arguments for parameterized check functions");
    }

    SvGETMAGIC( ST(0) );
    ST(0) = boolSV( CALL_FPTR((check_fptr_t)mg->mg_ptr)(aTHX_ mg->mg_obj, ST(0)) );
    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
441964ce	278	static 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
441964ce	295	mouse_lookup_isa(pTHX_ HV* const instance_stash, const char* const klass_pv){
1d5ecd5f	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
441964ce	310	int
	311	mouse_is_an_instance_of(pTHX_ HV* const stash, SV* const instance){
	312	assert(stash);
	313	assert(SvTYPE(stash) == SVt_PVHV);
	314
	315	if(SvROK(instance) && SvOBJECT(SvRV(instance))){
	316	dMY_CXT;
	317	HV* const instance_stash = SvSTASH(SvRV(instance));
	318	GV* const instance_isa = gv_fetchmeth_autoload(instance_stash, "isa", sizeof("isa")-1, 0);
	319
	320	/* the instance has no own isa method */
	321	if(instance_isa == NULL \|\| GvCV(instance_isa) == GvCV(MY_CXT.universal_isa)){
	322	return stash == instance_stash
	323	\|\| mouse_lookup_isa(aTHX_ instance_stash, HvNAME_get(stash));
	324	}
	325	/* the instance has its own isa method */
	326	else {
	327	int retval;
	328	dSP;
1d5ecd5f	329
441964ce	330	ENTER;
441964ce	331	SAVETMPS;
1d5ecd5f	332
441964ce	333	PUSHMARK(SP);
	334	EXTEND(SP, 2);
	335	PUSHs(instance);
	336	mPUSHp(HvNAME_get(stash), HvNAMELEN_get(stash));
	337	PUTBACK;
1d5ecd5f	338
441964ce	339	call_sv((SV*)instance_isa, G_SCALAR);
1d5ecd5f	340
441964ce	341	SPAGAIN;
1d5ecd5f	342
441964ce	343	retval = SvTRUEx(POPs);
1d5ecd5f	344
441964ce	345	PUTBACK;
1d5ecd5f	346
441964ce	347	FREETMPS;
441964ce	348	LEAVE;
1d5ecd5f	349
441964ce	350	return retval;
441964ce	351	}
1d5ecd5f	352	}
441964ce	353	return FALSE;
	354	}
	355
	356	static int
	357	mouse_is_an_instance_of_universal(pTHX_ SV* const data, SV* const sv){
	358	PERL_UNUSED_ARG(data);
	359	return SvROK(sv) && SvOBJECT(SvRV(sv));
1d5ecd5f	360	}
1d5ecd5f	361
441964ce	362	static MGVTBL mouse_util_type_constraints_vtbl; /* not used, only for identity */
f48920c1	363
441964ce	364	CV*
672bde7c	365	mouse_generate_isa_predicate_for(pTHX_ SV* const klass, const char* const predicate_name){
441964ce	366	STRLEN klass_len;
	367	const char* klass_pv = SvPV_const(klass, klass_len);
	368	CV* xsub;
	369	SV* mg_obj;
	370	void* mg_ptr;
1d5ecd5f	371
441964ce	372	klass_pv = mouse_canonicalize_package_name(klass_pv);
1d5ecd5f	373
441964ce	374	if(strNE(klass_pv, "UNIVERSAL")){
	375	mg_obj = (SV*)gv_stashpvn(klass_pv, klass_len, GV_ADD);
	376	mg_ptr = (void*)mouse_is_an_instance_of;
	377
	378	}
	379	else{
	380	mg_obj = NULL;
	381	mg_ptr = (void*)mouse_is_an_instance_of_universal;
1d5ecd5f	382	}
1d5ecd5f	383
441964ce	384	xsub = newXS(predicate_name, XS_Mouse_parameterized_check, __FILE__);
1d5ecd5f	385
441964ce	386	CvXSUBANY(xsub).any_ptr = sv_magicext(
	387	(SV*)xsub,
	388	mg_obj,
	389	PERL_MAGIC_ext,
	390	&mouse_util_type_constraints_vtbl,
	391	mg_ptr,
	392	0 /* indicates static data */
	393	);
1d5ecd5f	394
441964ce	395	if(!predicate_name){
	396	sv_2mortal((SV*)xsub);
	397	}
	398
	399	return xsub;
	400	}
f48920c1	401
441964ce	402	XS(XS_Mouse_parameterized_check) {
1d5ecd5f	403	dVAR;
1d5ecd5f	404	dXSARGS;
441964ce	405	MAGIC* const mg = (MAGIC*)XSANY.any_ptr;
441964ce	406	typedef int (check_fptr_t)(pTHX_ SV const data, SV* const sv);
1d5ecd5f	407
441964ce	408	if(items < 1){
441964ce	409	croak("Too few arguments for parameterized check functions");
1d5ecd5f	410	}
1d5ecd5f	411
441964ce	412	SvGETMAGIC( ST(0) );
441964ce	413	ST(0) = boolSV( CALL_FPTR((check_fptr_t)mg->mg_ptr)(aTHX_ mg->mg_obj, ST(0)) );
1d5ecd5f	414	XSRETURN(1);
	415	}
	416
	417	static void
	418	setup_my_cxt(pTHX_ pMY_CXT){
	419	MY_CXT.universal_isa = gv_fetchpvs("UNIVERSAL::isa", GV_ADD, SVt_PVCV);
	420	SvREFCNT_inc_simple_void_NN(MY_CXT.universal_isa);
	421	}
	422
	423	MODULE = Mouse::Util::TypeConstraints PACKAGE = Mouse::Util::TypeConstraints
	424
646c0371	425	PROTOTYPES: DISABLE
646c0371	426	VERSIONCHECK: DISABLE
1d5ecd5f	427
	428	BOOT:
	429	{
	430	MY_CXT_INIT;
	431	setup_my_cxt(aTHX_ aMY_CXT);
	432	}
	433
	434	#ifdef USE_ITHREADS
	435
	436	void
	437	CLONE(...)
	438	CODE:
	439	{
	440	MY_CXT_CLONE;
	441	setup_my_cxt(aTHX_ aMY_CXT);
	442	PERL_UNUSED_VAR(items);
	443	}
	444
	445	#endif /* !USE_ITHREADS */
	446
	447	void
1d5ecd5f	448	Item(SV* sv = &PL_sv_undef)
	449	ALIAS:
	450	Any = MOUSE_TC_ANY
	451	Item = MOUSE_TC_ITEM
	452	Undef = MOUSE_TC_UNDEF
	453	Defined = MOUSE_TC_DEFINED
	454	Bool = MOUSE_TC_BOOL
	455	Value = MOUSE_TC_VALUE
	456	Ref = MOUSE_TC_REF
	457	Str = MOUSE_TC_STR
	458	Num = MOUSE_TC_NUM
	459	Int = MOUSE_TC_INT
	460	ScalarRef = MOUSE_TC_SCALAR_REF
	461	ArrayRef = MOUSE_TC_ARRAY_REF
	462	HashRef = MOUSE_TC_HASH_REF
	463	CodeRef = MOUSE_TC_CODE_REF
	464	GlobRef = MOUSE_TC_GLOB_REF
	465	FileHandle = MOUSE_TC_FILEHANDLE
	466	RegexpRef = MOUSE_TC_REGEXP_REF
	467	Object = MOUSE_TC_OBJECT
	468	ClassName = MOUSE_TC_CLASS_NAME
	469	RoleName = MOUSE_TC_ROLE_NAME
	470	CODE:
	471	SvGETMAGIC(sv);
	472	ST(0) = boolSV( mouse_builtin_tc_check(aTHX_ ix, sv) );
	473	XSRETURN(1);
	474
	475