[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

typedef int (*check_fptr_t)(pTHX_ SV* const data, SV* const sv);

int
mouse_tc_check(pTHX_ SV* const tc_code, SV* const sv) {
    CV* const cv = (CV*)SvRV(tc_code);
    assert(SvTYPE(cv) == SVt_PVCV);

    if(CvXSUB(cv) == XS_Mouse__Util__TypeConstraints_Item){ /* built-in */
        assert(CvXSUBANY(cv).any_iv > 0);

        return mouse_builtin_tc_check(aTHX_ CvXSUBANY(cv).any_iv, sv);
    }
    else if(CvXSUB(cv) == XS_Mouse_parameterized_check){ /* built-in, parameterizad */
        MAGIC* const mg = (MAGIC*)CvXSUBANY(cv).any_ptr;

        assert(CvXSUBANY(cv).any_ptr != NULL);

        /* call the check function directly, skipping call_sv() */
        return CALL_FPTR((check_fptr_t)mg->mg_ptr)(aTHX_ mg->mg_obj, sv);
    }
    else { /* custom */
        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:
        NOOP;
    }

    croak("Mouse-panic: unrecognized type constraint id: %d", (int)tc);
    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(SvTRUE(sv)){
        if(SvIOKp(sv)){
            return SvIVX(sv) == 1;
        }
        else if(SvNOKp(sv)){
            return SvNVX(sv) == 1.0;
        }
        else if(SvPOKp(sv)){ /* "1" */
            return SvCUR(sv) == 1 && SvPVX(sv)[0] == '1';
        }
        else{
            return FALSE;
        }
    }
    else{
        /* false must be boolean */
        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_an_instance_of("Mouse::Meta::Role", meta);

        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_an_instance_of("IO::Handle", sv);
}

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

/* Parameterized type constraints */

int
mouse_parameterized_ArrayRef(pTHX_ SV* const param, SV* const sv) {
    if(mouse_tc_ArrayRef(aTHX_ sv)){
        AV* const av  = (AV*)SvRV(sv);
        I32 const len = av_len(av) + 1;
        I32 i;
        for(i = 0; i < len; i++){
            SV* const value = *av_fetch(av, i, TRUE);
            SvGETMAGIC(value);
            if(!mouse_tc_check(aTHX_ param, value)){
                return FALSE;
            }
        }
        return TRUE;
    }
    return FALSE;
}

int
mouse_parameterized_HashRef(pTHX_ SV* const param, SV* const sv) {
    if(mouse_tc_HashRef(aTHX_ sv)){
        HV* const hv  = (HV*)SvRV(sv);
        HE* he;

        hv_iterinit(hv);
        while((he = hv_iternext(hv))){
            SV* const value = hv_iterval(hv, he);
            SvGETMAGIC(value);
            if(!mouse_tc_check(aTHX_ param, value)){
                return FALSE;
            }
        }
        return TRUE;
    }
    return FALSE;
}

int
mouse_parameterized_Maybe(pTHX_ SV* const param, SV* const sv) {
    if(SvOK(sv)){
        return mouse_tc_check(aTHX_ param, sv);
    }
    return TRUE;
}

/*
 *  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(IsObject(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 */

static CV*
mouse_tc_parameterize(pTHX_ const char* const name, check_fptr_t const fptr, SV* const param) {
    CV* xsub;

    xsub = newXS(name, XS_Mouse_parameterized_check, __FILE__);
    CvXSUBANY(xsub).any_ptr = sv_magicext(
        (SV*)xsub,
        param,       /* mg_obj: refcnt will be increased */
        PERL_MAGIC_ext,
        &mouse_util_type_constraints_vtbl,
        (void*)fptr, /* mg_ptr */
        0            /* mg_len: 0 for static data */
    );

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

    return xsub;
}

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);
    SV*   param;
    void* fptr;

    klass_pv = mouse_canonicalize_package_name(klass_pv);

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

    }
    else{
        param = NULL;
        fptr = (void*)mouse_is_an_instance_of_universal;
    }

    return mouse_tc_parameterize(aTHX_ predicate_name, fptr, param);
}

XS(XS_Mouse_parameterized_check) {
    dVAR;
    dXSARGS;
    MAGIC* const mg = (MAGIC*)XSANY.any_ptr;

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


CV*
_parameterize_ArrayRef_for(SV* param)
ALIAS:
    _parameterize_ArrayRef_for = MOUSE_TC_ARRAY_REF
    _parameterize_HashRef_for  = MOUSE_TC_HASH_REF
    _parameterize_Maybe_for    = MOUSE_TC_MAYBE
CODE:
{
    check_fptr_t fptr;
    SV* const tc_code = mcall0s(param, "_compiled_type_constraint");
    if(!(SvROK(tc_code) && SvTYPE(SvRV(tc_code)) == SVt_PVCV)){
        croak("_compiled_type_constraint didn't return a CODE reference");
    }

    switch(ix){
    case MOUSE_TC_ARRAY_REF:
        fptr = mouse_parameterized_ArrayRef;
        break;
    case MOUSE_TC_HASH_REF:
        fptr = mouse_parameterized_HashRef;
        break;
    default: /* Maybe type */
        fptr = mouse_parameterized_Maybe;
    }
    RETVAL = mouse_tc_parameterize(aTHX_ NULL, fptr, tc_code);
}
OUTPUT:
    RETVAL
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
d33d8840	17	typedef int (check_fptr_t)(pTHX_ SV const data, SV* const sv);
d33d8840	18
1d5ecd5f	19	int
1d5ecd5f	20	mouse_tc_check(pTHX_ SV* const tc_code, SV* const sv) {
28ba5a26	21	CV* const cv = (CV*)SvRV(tc_code);
7ca3334f	22	assert(SvTYPE(cv) == SVt_PVCV);
d33d8840	23
7ca3334f	24	if(CvXSUB(cv) == XS_Mouse__Util__TypeConstraints_Item){ /* built-in */
7ca3334f	25	assert(CvXSUBANY(cv).any_iv > 0);
d33d8840	26
7ca3334f	27	return mouse_builtin_tc_check(aTHX_ CvXSUBANY(cv).any_iv, sv);
	28	}
	29	else if(CvXSUB(cv) == XS_Mouse_parameterized_check){ /* built-in, parameterizad */
	30	MAGIC* const mg = (MAGIC*)CvXSUBANY(cv).any_ptr;
d33d8840	31
7ca3334f	32	assert(CvXSUBANY(cv).any_ptr != NULL);
28ba5a26	33
7ca3334f	34	/* call the check function directly, skipping call_sv() */
7ca3334f	35	return CALL_FPTR((check_fptr_t)mg->mg_ptr)(aTHX_ mg->mg_obj, sv);
1d5ecd5f	36	}
7ca3334f	37	else { /* custom */
1d5ecd5f	38	int ok;
	39	dSP;
	40
	41	ENTER;
	42	SAVETMPS;
	43
	44	PUSHMARK(SP);
	45	XPUSHs(sv);
	46	PUTBACK;
	47
	48	call_sv(tc_code, G_SCALAR);
	49
	50	SPAGAIN;
	51	ok = SvTRUEx(POPs);
	52	PUTBACK;
	53
	54	FREETMPS;
	55	LEAVE;
	56
	57	return ok;
	58	}
	59	}
7d96ae4d	60
7d96ae4d	61	int
1d5ecd5f	62	mouse_builtin_tc_check(pTHX_ mouse_tc const tc, SV* const sv) {
7d96ae4d	63	switch(tc){
	64	case MOUSE_TC_ANY: return mouse_tc_Any(aTHX_ sv);
	65	case MOUSE_TC_ITEM: return mouse_tc_Any(aTHX_ sv);
	66	case MOUSE_TC_UNDEF: return mouse_tc_Undef(aTHX_ sv);
	67	case MOUSE_TC_DEFINED: return mouse_tc_Defined(aTHX_ sv);
	68	case MOUSE_TC_BOOL: return mouse_tc_Bool(aTHX_ sv);
	69	case MOUSE_TC_VALUE: return mouse_tc_Value(aTHX_ sv);
	70	case MOUSE_TC_REF: return mouse_tc_Ref(aTHX_ sv);
	71	case MOUSE_TC_STR: return mouse_tc_Str(aTHX_ sv);
	72	case MOUSE_TC_NUM: return mouse_tc_Num(aTHX_ sv);
	73	case MOUSE_TC_INT: return mouse_tc_Int(aTHX_ sv);
	74	case MOUSE_TC_SCALAR_REF: return mouse_tc_ScalarRef(aTHX_ sv);
	75	case MOUSE_TC_ARRAY_REF: return mouse_tc_ArrayRef(aTHX_ sv);
	76	case MOUSE_TC_HASH_REF: return mouse_tc_HashRef(aTHX_ sv);
	77	case MOUSE_TC_CODE_REF: return mouse_tc_CodeRef(aTHX_ sv);
	78	case MOUSE_TC_GLOB_REF: return mouse_tc_GlobRef(aTHX_ sv);
	79	case MOUSE_TC_FILEHANDLE: return mouse_tc_FileHandle(aTHX_ sv);
	80	case MOUSE_TC_REGEXP_REF: return mouse_tc_RegexpRef(aTHX_ sv);
	81	case MOUSE_TC_OBJECT: return mouse_tc_Object(aTHX_ sv);
	82	case MOUSE_TC_CLASS_NAME: return mouse_tc_ClassName(aTHX_ sv);
	83	case MOUSE_TC_ROLE_NAME: return mouse_tc_RoleName(aTHX_ sv);
	84	default:
7d96ae4d	85	NOOP;
	86	}
	87
f6e3b8a9	88	croak("Mouse-panic: unrecognized type constraint id: %d", (int)tc);
7d96ae4d	89	return FALSE; /* not reached */
	90	}
	91
	92
	93	/*
	94	The following type check functions return an integer, not a bool, to keep them simple,
	95	so if you assign these return value to bool variable, you must use "expr ? TRUE : FALSE".
	96	*/
	97
	98	int
	99	mouse_tc_Any(pTHX_ SV* const sv PERL_UNUSED_DECL) {
	100	assert(sv);
	101	return TRUE;
	102	}
	103
	104	int
	105	mouse_tc_Bool(pTHX_ SV* const sv) {
	106	assert(sv);
f6e3b8a9	107
f6e3b8a9	108	if(SvTRUE(sv)){
7d96ae4d	109	if(SvIOKp(sv)){
f6e3b8a9	110	return SvIVX(sv) == 1;
7d96ae4d	111	}
7d96ae4d	112	else if(SvNOKp(sv)){
f6e3b8a9	113	return SvNVX(sv) == 1.0;
7d96ae4d	114	}
f6e3b8a9	115	else if(SvPOKp(sv)){ /* "1" */
f6e3b8a9	116	return SvCUR(sv) == 1 && SvPVX(sv)[0] == '1';
7d96ae4d	117	}
	118	else{
	119	return FALSE;
	120	}
	121	}
	122	else{
f6e3b8a9	123	/* false must be boolean */
7d96ae4d	124	return TRUE;
	125	}
	126	}
	127
	128	int
	129	mouse_tc_Undef(pTHX_ SV* const sv) {
	130	assert(sv);
	131	return !SvOK(sv);
	132	}
	133
	134	int
	135	mouse_tc_Defined(pTHX_ SV* const sv) {
	136	assert(sv);
	137	return SvOK(sv);
	138	}
	139
	140	int
	141	mouse_tc_Value(pTHX_ SV* const sv) {
	142	assert(sv);
	143	return SvOK(sv) && !SvROK(sv);
	144	}
	145
	146	int
	147	mouse_tc_Num(pTHX_ SV* const sv) {
	148	assert(sv);
	149	return LooksLikeNumber(sv);
	150	}
	151
	152	int
	153	mouse_tc_Int(pTHX_ SV* const sv) {
	154	assert(sv);
	155	if(SvIOKp(sv)){
	156	return TRUE;
	157	}
	158	else if(SvNOKp(sv)){
	159	NV const nv = SvNVX(sv);
	160	return nv > 0 ? (nv == (NV)(UV)nv) : (nv == (NV)(IV)nv);
	161	}
	162	else if(SvPOKp(sv)){
	163	int const num_type = grok_number(SvPVX(sv), SvCUR(sv), NULL);
	164	if(num_type){
	165	return !(num_type & IS_NUMBER_NOT_INT);
	166	}
	167	}
	168	return FALSE;
	169	}
	170
	171	int
	172	mouse_tc_Str(pTHX_ SV* const sv) {
	173	assert(sv);
	174	return SvOK(sv) && !SvROK(sv) && !isGV(sv);
	175	}
	176
	177	int
	178	mouse_tc_ClassName(pTHX_ SV* const sv){
	179	assert(sv);
	180	return is_class_loaded(sv);
	181	}
	182
	183	int
	184	mouse_tc_RoleName(pTHX_ SV* const sv) {
	185	assert(sv);
	186	if(is_class_loaded(sv)){
	187	int ok;
188	SV* meta;
189	dSP;
190
191	ENTER;
192	SAVETMPS;
193
194	PUSHMARK(SP);
195	XPUSHs(sv);
196	PUTBACK;
197	call_pv("Mouse::Util::get_metaclass_by_name", G_SCALAR);
198	SPAGAIN;
199	meta = POPs;
200	PUTBACK;
201
016e4681	202	ok = is_an_instance_of("Mouse::Meta::Role", meta);
7d96ae4d	203
	204	FREETMPS;
	205	LEAVE;
	206
	207	return ok;
	208	}
	209	return FALSE;
	210	}
	211
	212	int
	213	mouse_tc_Ref(pTHX_ SV* const sv) {
	214	assert(sv);
	215	return SvROK(sv);
	216	}
	217
	218	int
	219	mouse_tc_ScalarRef(pTHX_ SV* const sv) {
	220	assert(sv);
	221	return SvROK(sv) && !SvOBJECT(SvRV(sv)) && (SvTYPE(SvRV(sv)) <= SVt_PVLV && !isGV(SvRV(sv)));
	222	}
	223
	224	int
	225	mouse_tc_ArrayRef(pTHX_ SV* const sv) {
	226	assert(sv);
	227	return SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVAV;
	228	}
	229
	230	int
	231	mouse_tc_HashRef(pTHX_ SV* const sv) {
	232	assert(sv);
	233	return SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVHV;
	234	}
	235
	236	int
	237	mouse_tc_CodeRef(pTHX_ SV* const sv) {
	238	assert(sv);
	239	return SvROK(sv) && !SvOBJECT(SvRV(sv))&& SvTYPE(SvRV(sv)) == SVt_PVCV;
	240	}
	241
	242	int
	243	mouse_tc_RegexpRef(pTHX_ SV* const sv) {
	244	assert(sv);
	245	return SvRXOK(sv);
	246	}
	247
	248	int
	249	mouse_tc_GlobRef(pTHX_ SV* const sv) {
	250	assert(sv);
	251	return SvROK(sv) && !SvOBJECT(SvRV(sv)) && isGV(SvRV(sv));
	252	}
	253
	254	int
	255	mouse_tc_FileHandle(pTHX_ SV* const sv) {
	256	GV* gv;
	257	assert(sv);
	258
	259	/* see pp_fileno() in pp_sys.c and Scalar::Util::openhandle() */
	260
	261	gv = (GV*)(SvROK(sv) ? SvRV(sv) : sv);
	262	if(isGV(gv) \|\| SvTYPE(gv) == SVt_PVIO){
	263	IO* const io = isGV(gv) ? GvIO(gv) : (IO*)gv;
	264
	265	if(io && ( IoIFP(io) \|\| SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar) )){
	266	return TRUE;
267	}
268	}
269
016e4681	270	return is_an_instance_of("IO::Handle", sv);
7d96ae4d	271	}
	272
	273	int
	274	mouse_tc_Object(pTHX_ SV* const sv) {
	275	assert(sv);
	276	return SvROK(sv) && SvOBJECT(SvRV(sv)) && !SvRXOK(sv);
	277	}
	278
619338ac	279	/* Parameterized type constraints */
	280
	281	int
	282	mouse_parameterized_ArrayRef(pTHX_ SV* const param, SV* const sv) {
	283	if(mouse_tc_ArrayRef(aTHX_ sv)){
	284	AV* const av = (AV*)SvRV(sv);
	285	I32 const len = av_len(av) + 1;
	286	I32 i;
	287	for(i = 0; i < len; i++){
	288	SV* const value = *av_fetch(av, i, TRUE);
	289	SvGETMAGIC(value);
	290	if(!mouse_tc_check(aTHX_ param, value)){
	291	return FALSE;
	292	}
	293	}
	294	return TRUE;
	295	}
	296	return FALSE;
	297	}
	298
	299	int
	300	mouse_parameterized_HashRef(pTHX_ SV* const param, SV* const sv) {
	301	if(mouse_tc_HashRef(aTHX_ sv)){
	302	HV* const hv = (HV*)SvRV(sv);
	303	HE* he;
	304
	305	hv_iterinit(hv);
	306	while((he = hv_iternext(hv))){
	307	SV* const value = hv_iterval(hv, he);
	308	SvGETMAGIC(value);
	309	if(!mouse_tc_check(aTHX_ param, value)){
	310	return FALSE;
	311	}
	312	}
	313	return TRUE;
	314	}
	315	return FALSE;
	316	}
	317
	318	int
	319	mouse_parameterized_Maybe(pTHX_ SV* const param, SV* const sv) {
	320	if(SvOK(sv)){
	321	return mouse_tc_check(aTHX_ param, sv);
	322	}
	323	return TRUE;
	324	}
	325
1d5ecd5f	326	/*
	327	* This class_type generator is taken from Scalar::Util::Instance
	328	*/
	329
	330	#define MY_CXT_KEY "Mouse::Util::TypeConstraints::_guts" XS_VERSION
	331	typedef struct sui_cxt{
	332	GV* universal_isa;
	333	} my_cxt_t;
	334	START_MY_CXT
	335
	336	#define MG_klass_stash(mg) ((HV*)(mg)->mg_obj)
	337	#define MG_klass_pv(mg) ((mg)->mg_ptr)
	338	#define MG_klass_len(mg) ((mg)->mg_len)
	339
441964ce	340	static const char*
f48920c1	341	mouse_canonicalize_package_name(const char* name){
1d5ecd5f	342
	343	/* "::Foo" -> "Foo" */
	344	if(name[0] == ':' && name[1] == ':'){
	345	name += 2;
	346	}
	347
	348	/* "main::main::main::Foo" -> "Foo" */
	349	while(strnEQ(name, "main::", sizeof("main::")-1)){
	350	name += sizeof("main::")-1;
	351	}
	352
	353	return name;
	354	}
	355
	356	static int
441964ce	357	mouse_lookup_isa(pTHX_ HV* const instance_stash, const char* const klass_pv){
1d5ecd5f	358	AV* const linearized_isa = mro_get_linear_isa(instance_stash);
	359	SV** svp = AvARRAY(linearized_isa);
	360	SV** const end = svp + AvFILLp(linearized_isa) + 1;
	361
	362	while(svp != end){
	363	assert(SvPVX(*svp));
f48920c1	364	if(strEQ(klass_pv, mouse_canonicalize_package_name(SvPVX(*svp)))){
1d5ecd5f	365	return TRUE;
	366	}
	367	svp++;
	368	}
	369	return FALSE;
	370	}
	371
441964ce	372	int
	373	mouse_is_an_instance_of(pTHX_ HV* const stash, SV* const instance){
	374	assert(stash);
	375	assert(SvTYPE(stash) == SVt_PVHV);
	376
016e4681	377	if(IsObject(instance)){
441964ce	378	dMY_CXT;
	379	HV* const instance_stash = SvSTASH(SvRV(instance));
	380	GV* const instance_isa = gv_fetchmeth_autoload(instance_stash, "isa", sizeof("isa")-1, 0);
	381
	382	/* the instance has no own isa method */
	383	if(instance_isa == NULL \|\| GvCV(instance_isa) == GvCV(MY_CXT.universal_isa)){
	384	return stash == instance_stash
	385	\|\| mouse_lookup_isa(aTHX_ instance_stash, HvNAME_get(stash));
	386	}
	387	/* the instance has its own isa method */
	388	else {
	389	int retval;
	390	dSP;
1d5ecd5f	391
441964ce	392	ENTER;
441964ce	393	SAVETMPS;
1d5ecd5f	394
441964ce	395	PUSHMARK(SP);
	396	EXTEND(SP, 2);
	397	PUSHs(instance);
	398	mPUSHp(HvNAME_get(stash), HvNAMELEN_get(stash));
	399	PUTBACK;
1d5ecd5f	400
441964ce	401	call_sv((SV*)instance_isa, G_SCALAR);
1d5ecd5f	402
441964ce	403	SPAGAIN;
1d5ecd5f	404
441964ce	405	retval = SvTRUEx(POPs);
1d5ecd5f	406
441964ce	407	PUTBACK;
1d5ecd5f	408
441964ce	409	FREETMPS;
441964ce	410	LEAVE;
1d5ecd5f	411
441964ce	412	return retval;
441964ce	413	}
1d5ecd5f	414	}
441964ce	415	return FALSE;
	416	}
	417
	418	static int
	419	mouse_is_an_instance_of_universal(pTHX_ SV* const data, SV* const sv){
	420	PERL_UNUSED_ARG(data);
	421	return SvROK(sv) && SvOBJECT(SvRV(sv));
1d5ecd5f	422	}
1d5ecd5f	423
441964ce	424	static MGVTBL mouse_util_type_constraints_vtbl; /* not used, only for identity */
f48920c1	425
619338ac	426	static CV*
916eb82f	427	mouse_tc_parameterize(pTHX_ const char* const name, check_fptr_t const fptr, SV* const param) {
619338ac	428	CV* xsub;
916eb82f	429
619338ac	430	xsub = newXS(name, XS_Mouse_parameterized_check, __FILE__);
916eb82f	431	CvXSUBANY(xsub).any_ptr = sv_magicext(
	432	(SV*)xsub,
	433	param, /* mg_obj: refcnt will be increased */
	434	PERL_MAGIC_ext,
	435	&mouse_util_type_constraints_vtbl,
	436	(void)fptr, / mg_ptr */
	437	0 /* mg_len: 0 for static data */
	438	);
	439
	440	if(!name){
	441	sv_2mortal((SV*)xsub);
	442	}
	443
	444	return xsub;
	445	}
	446
	447	CV*
672bde7c	448	mouse_generate_isa_predicate_for(pTHX_ SV* const klass, const char* const predicate_name){
441964ce	449	STRLEN klass_len;
441964ce	450	const char* klass_pv = SvPV_const(klass, klass_len);
916eb82f	451	SV* param;
916eb82f	452	void* fptr;
1d5ecd5f	453
441964ce	454	klass_pv = mouse_canonicalize_package_name(klass_pv);
1d5ecd5f	455
441964ce	456	if(strNE(klass_pv, "UNIVERSAL")){
916eb82f	457	param = (SV*)gv_stashpvn(klass_pv, klass_len, GV_ADD);
916eb82f	458	fptr = (void*)mouse_is_an_instance_of;
441964ce	459
	460	}
	461	else{
916eb82f	462	param = NULL;
916eb82f	463	fptr = (void*)mouse_is_an_instance_of_universal;
441964ce	464	}
441964ce	465
916eb82f	466	return mouse_tc_parameterize(aTHX_ predicate_name, fptr, param);
441964ce	467	}
f48920c1	468
441964ce	469	XS(XS_Mouse_parameterized_check) {
1d5ecd5f	470	dVAR;
1d5ecd5f	471	dXSARGS;
441964ce	472	MAGIC* const mg = (MAGIC*)XSANY.any_ptr;
1d5ecd5f	473
441964ce	474	if(items < 1){
441964ce	475	croak("Too few arguments for parameterized check functions");
1d5ecd5f	476	}
1d5ecd5f	477
441964ce	478	SvGETMAGIC( ST(0) );
441964ce	479	ST(0) = boolSV( CALL_FPTR((check_fptr_t)mg->mg_ptr)(aTHX_ mg->mg_obj, ST(0)) );
1d5ecd5f	480	XSRETURN(1);
	481	}
	482
	483	static void
	484	setup_my_cxt(pTHX_ pMY_CXT){
	485	MY_CXT.universal_isa = gv_fetchpvs("UNIVERSAL::isa", GV_ADD, SVt_PVCV);
	486	SvREFCNT_inc_simple_void_NN(MY_CXT.universal_isa);
	487	}
	488
	489	MODULE = Mouse::Util::TypeConstraints PACKAGE = Mouse::Util::TypeConstraints
	490
646c0371	491	PROTOTYPES: DISABLE
646c0371	492	VERSIONCHECK: DISABLE
1d5ecd5f	493
	494	BOOT:
	495	{
	496	MY_CXT_INIT;
	497	setup_my_cxt(aTHX_ aMY_CXT);
	498	}
	499
	500	#ifdef USE_ITHREADS
	501
	502	void
	503	CLONE(...)
	504	CODE:
	505	{
	506	MY_CXT_CLONE;
	507	setup_my_cxt(aTHX_ aMY_CXT);
	508	PERL_UNUSED_VAR(items);
	509	}
	510
	511	#endif /* !USE_ITHREADS */
	512
	513	void
1d5ecd5f	514	Item(SV* sv = &PL_sv_undef)
	515	ALIAS:
	516	Any = MOUSE_TC_ANY
	517	Item = MOUSE_TC_ITEM
	518	Undef = MOUSE_TC_UNDEF
	519	Defined = MOUSE_TC_DEFINED
	520	Bool = MOUSE_TC_BOOL
	521	Value = MOUSE_TC_VALUE
	522	Ref = MOUSE_TC_REF
	523	Str = MOUSE_TC_STR
	524	Num = MOUSE_TC_NUM
	525	Int = MOUSE_TC_INT
	526	ScalarRef = MOUSE_TC_SCALAR_REF
	527	ArrayRef = MOUSE_TC_ARRAY_REF
	528	HashRef = MOUSE_TC_HASH_REF
	529	CodeRef = MOUSE_TC_CODE_REF
	530	GlobRef = MOUSE_TC_GLOB_REF
	531	FileHandle = MOUSE_TC_FILEHANDLE
	532	RegexpRef = MOUSE_TC_REGEXP_REF
	533	Object = MOUSE_TC_OBJECT
	534	ClassName = MOUSE_TC_CLASS_NAME
	535	RoleName = MOUSE_TC_ROLE_NAME
	536	CODE:
	537	SvGETMAGIC(sv);
	538	ST(0) = boolSV( mouse_builtin_tc_check(aTHX_ ix, sv) );
	539	XSRETURN(1);
	540
	541
619338ac	542	CV*
	543	_parameterize_ArrayRef_for(SV* param)
	544	ALIAS:
	545	_parameterize_ArrayRef_for = MOUSE_TC_ARRAY_REF
	546	_parameterize_HashRef_for = MOUSE_TC_HASH_REF
	547	_parameterize_Maybe_for = MOUSE_TC_MAYBE
	548	CODE:
	549	{
	550	check_fptr_t fptr;
	551	SV* const tc_code = mcall0s(param, "_compiled_type_constraint");
	552	if(!(SvROK(tc_code) && SvTYPE(SvRV(tc_code)) == SVt_PVCV)){
	553	croak("_compiled_type_constraint didn't return a CODE reference");
	554	}
	555
	556	switch(ix){
	557	case MOUSE_TC_ARRAY_REF:
	558	fptr = mouse_parameterized_ArrayRef;
	559	break;
	560	case MOUSE_TC_HASH_REF:
	561	fptr = mouse_parameterized_HashRef;
	562	break;
	563	default: /* Maybe type */
	564	fptr = mouse_parameterized_Maybe;
	565	}
	566	RETVAL = mouse_tc_parameterize(aTHX_ NULL, fptr, tc_code);
	567	}
	568	OUTPUT:
	569	RETVAL
	570