view release on metacpan or  search on metacpan

Instance.xs  view on Meta::CPAN

    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 = Scalar::Util::Instance    PACKAGE = Scalar::Util::Instance

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_for(self, 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,
            &scalar_util_instance_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) );
    }
}