[gitmo/Mouse.git] / xs-src / mouse_type_constraint.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 MGVTBL mouse_util_type_constraints_vtbl;

static const char*
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, 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); /* -W */
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); /* -W */
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

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
_generate_class_type_for(SV* klass, const char* predicate_name = NULL)
PPCODE:
{
    STRLEN klass_len;
    const char* klass_pv;
    HV* stash;
    CV* xsub;

    if(!SvOK(klass)){
        croak("You must define a class name for generate_for");
    }
    klass_pv = SvPV_const(klass, klass_len);
    klass_pv = canonicalize_package_name(klass_pv);

    if(strNE(klass_pv, "UNIVERSAL")){
        xsub = newXS(predicate_name, XS_isa_check, __FILE__);

        stash = gv_stashpvn(klass_pv, klass_len, GV_ADD);

        CvXSUBANY(xsub).any_ptr = sv_magicext(
            (SV*)xsub,
            (SV*)stash, /* mg_obj */
            PERL_MAGIC_ext,
            &mouse_util_type_constraints_vtbl,
            klass_pv,   /* mg_ptr */
            klass_len   /* mg_len */
        );
    }
    else{
        xsub = newXS(predicate_name, XS_isa_check_for_universal, __FILE__);
    }

    if(predicate_name == NULL){ /* anonymous predicate */
        XPUSHs( newRV_noinc((SV*)xsub) );
    }
}

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
	278	static MGVTBL mouse_util_type_constraints_vtbl;
	279
	280	static const char*
	281	canonicalize_package_name(const char* name){
	282
	283	/* "::Foo" -> "Foo" */
	284	if(name[0] == ':' && name[1] == ':'){
	285	name += 2;
	286	}
	287
	288	/* "main::main::main::Foo" -> "Foo" */
	289	while(strnEQ(name, "main::", sizeof("main::")-1)){
	290	name += sizeof("main::")-1;
	291	}
	292
	293	return name;
	294	}
	295
	296	static int
	297	lookup_isa(pTHX_ HV* const instance_stash, const char* const klass_pv){
	298	AV* const linearized_isa = mro_get_linear_isa(instance_stash);
	299	SV** svp = AvARRAY(linearized_isa);
	300	SV** const end = svp + AvFILLp(linearized_isa) + 1;
	301
	302	while(svp != end){
	303	assert(SvPVX(*svp));
	304	if(strEQ(klass_pv, canonicalize_package_name(SvPVX(*svp)))){
	305	return TRUE;
	306	}
	307	svp++;
	308	}
	309	return FALSE;
	310	}
	311
	312	static int
	313	instance_isa(pTHX_ SV* const instance, const MAGIC* const mg){
	314	dMY_CXT;
	315	HV* const instance_stash = SvSTASH(SvRV(instance));
	316	GV* const instance_isa = gv_fetchmeth_autoload(instance_stash, "isa", sizeof("isa")-1, 0);
	317
	318	/* the instance has no own isa method */
	319	if(instance_isa == NULL \|\| GvCV(instance_isa) == GvCV(MY_CXT.universal_isa)){
	320	return MG_klass_stash(mg) == instance_stash
	321	\|\| lookup_isa(aTHX_ instance_stash, MG_klass_pv(mg));
	322	}
	323	/* the instance has its own isa method */
	324	else {
	325	int retval;
	326	dSP;
	327
328	ENTER;
329	SAVETMPS;
330
331	PUSHMARK(SP);
332	EXTEND(SP, 2);
333	PUSHs(instance);
334	mPUSHp(MG_klass_pv(mg), MG_klass_len(mg));
335	PUTBACK;
336
337	call_sv((SV*)instance_isa, G_SCALAR);
338
339	SPAGAIN;
340
341	retval = SvTRUEx(POPs);
342
343	PUTBACK;
344
345	FREETMPS;
346	LEAVE;
347
348	return retval;
349	}
350	}
351
352	XS(XS_isa_check); /* -W */
353	XS(XS_isa_check){
354	dVAR;
355	dXSARGS;
356	SV* sv;
357
358	assert(XSANY.any_ptr != NULL);
359
360	if(items != 1){
361	if(items < 1){
362	croak("Not enough arguments for is-a predicate");
363	}
364	else{
365	croak("Too many arguments for is-a predicate");
366	}
367	}
368
369	sv = ST(0);
370	SvGETMAGIC(sv);
371
372	ST(0) = boolSV( SvROK(sv) && SvOBJECT(SvRV(sv)) && instance_isa(aTHX_ sv, (MAGIC*)XSANY.any_ptr) );
373	XSRETURN(1);
374	}
375
376	XS(XS_isa_check_for_universal); /* -W */
377	XS(XS_isa_check_for_universal){
378	dVAR;
379	dXSARGS;
380	SV* sv;
381	PERL_UNUSED_VAR(cv);
382
383	if(items != 1){
384	if(items < 1){
385	croak("Not enough arguments for is-a predicate");
386	}
387	else{
388	croak("Too many arguments for is-a predicate");
389	}
390	}
391
392	sv = ST(0);
393	SvGETMAGIC(sv);
394
395	ST(0) = boolSV( SvROK(sv) && SvOBJECT(SvRV(sv)) );
396	XSRETURN(1);
397	}
398
399	static void
400	setup_my_cxt(pTHX_ pMY_CXT){
401	MY_CXT.universal_isa = gv_fetchpvs("UNIVERSAL::isa", GV_ADD, SVt_PVCV);
402	SvREFCNT_inc_simple_void_NN(MY_CXT.universal_isa);
403	}
404
405	MODULE = Mouse::Util::TypeConstraints PACKAGE = Mouse::Util::TypeConstraints
406
407	PROTOTYPES: DISABLE
408
409	BOOT:
410	{
411	MY_CXT_INIT;
412	setup_my_cxt(aTHX_ aMY_CXT);
413	}
414
415	#ifdef USE_ITHREADS
416
417	void
418	CLONE(...)
419	CODE:
420	{
421	MY_CXT_CLONE;
422	setup_my_cxt(aTHX_ aMY_CXT);
423	PERL_UNUSED_VAR(items);
424	}
425
426	#endif /* !USE_ITHREADS */
427
428	void
429	_generate_class_type_for(SV* klass, const char* predicate_name = NULL)
430	PPCODE:
431	{
432	STRLEN klass_len;
433	const char* klass_pv;
434	HV* stash;
435	CV* xsub;
436
437	if(!SvOK(klass)){
438	croak("You must define a class name for generate_for");
439	}
440	klass_pv = SvPV_const(klass, klass_len);
441	klass_pv = canonicalize_package_name(klass_pv);
442
443	if(strNE(klass_pv, "UNIVERSAL")){
444	xsub = newXS(predicate_name, XS_isa_check, __FILE__);
445
446	stash = gv_stashpvn(klass_pv, klass_len, GV_ADD);
447
448	CvXSUBANY(xsub).any_ptr = sv_magicext(
449	(SV*)xsub,
450	(SV)stash, / mg_obj */
451	PERL_MAGIC_ext,
452	&mouse_util_type_constraints_vtbl,
453	klass_pv, /* mg_ptr */
454	klass_len /* mg_len */
455	);
456	}
457	else{
458	xsub = newXS(predicate_name, XS_isa_check_for_universal, __FILE__);
459	}
460
461	if(predicate_name == NULL){ /* anonymous predicate */
462	XPUSHs( newRV_noinc((SV*)xsub) );
463	}
464	}
465
466	void
467	Item(SV* sv = &PL_sv_undef)
468	ALIAS:
469	Any = MOUSE_TC_ANY
470	Item = MOUSE_TC_ITEM
471	Undef = MOUSE_TC_UNDEF
472	Defined = MOUSE_TC_DEFINED
473	Bool = MOUSE_TC_BOOL
474	Value = MOUSE_TC_VALUE
475	Ref = MOUSE_TC_REF
476	Str = MOUSE_TC_STR
477	Num = MOUSE_TC_NUM
478	Int = MOUSE_TC_INT
479	ScalarRef = MOUSE_TC_SCALAR_REF
480	ArrayRef = MOUSE_TC_ARRAY_REF
481	HashRef = MOUSE_TC_HASH_REF
482	CodeRef = MOUSE_TC_CODE_REF
483	GlobRef = MOUSE_TC_GLOB_REF
484	FileHandle = MOUSE_TC_FILEHANDLE
485	RegexpRef = MOUSE_TC_REGEXP_REF
486	Object = MOUSE_TC_OBJECT
487	ClassName = MOUSE_TC_CLASS_NAME
488	RoleName = MOUSE_TC_ROLE_NAME
489	CODE:
490	SvGETMAGIC(sv);
491	ST(0) = boolSV( mouse_builtin_tc_check(aTHX_ ix, sv) );
492	XSRETURN(1);
493
494