view release on metacpan or  search on metacpan

xs/object/object.c  view on Meta::CPAN

    /* Add registered types */
    if (g_type_registry) {
        HE *he;
        hv_iterinit(g_type_registry);
        while ((he = hv_iternext(g_type_registry))) {
            av_push(result, newSVsv(hv_iterkeysv(he)));
        }
    }
    
    ST(0) = newRV_noinc((SV*)result);
    sv_2mortal(ST(0));
    XSRETURN(1);
}

/* ============================================
   Singleton support
   ============================================ */

/* XS implementation of instance() method for singletons */
static XS(xs_singleton_instance) {
    dXSARGS;
    ClassMeta *meta = INT2PTR(ClassMeta*, CvXSUBANY(cv).any_iv);

    PERL_UNUSED_ARG(items);

    if (!meta) {
        croak("Singleton metadata not found");
    }

    /* Return cached instance if it exists */
    if (meta->singleton_instance && SvOK(meta->singleton_instance)) {
        ST(0) = meta->singleton_instance;
        XSRETURN(1);
    }

    /* Create new instance */
    {
        dSP;
        int count;
        SV *obj;
        GV *build_gv;
        char full_build[256];

        ENTER;
        SAVETMPS;

        /* Call ClassName->new() */
        PUSHMARK(SP);
        XPUSHs(sv_2mortal(newSVpv(meta->class_name, 0)));
        PUTBACK;

        count = call_method("new", G_SCALAR);

        SPAGAIN;

        if (count != 1) {
            croak("Singleton new() did not return object");
        }

        obj = POPs;
        SvREFCNT_inc(obj);  /* Keep the object alive */

        PUTBACK;

        /* Check for BUILD method and call it */
        snprintf(full_build, sizeof(full_build), "%s::BUILD", meta->class_name);
        build_gv = gv_fetchpv(full_build, 0, SVt_PVCV);
        if (build_gv && GvCV(build_gv)) {
            PUSHMARK(SP);
            XPUSHs(obj);
            PUTBACK;
            call_method("BUILD", G_VOID | G_DISCARD);
        }

        /* Cache the instance */
        meta->singleton_instance = obj;

        FREETMPS;
        LEAVE;

        ST(0) = obj;
        XSRETURN(1);
    }
}

/* ============================================
   Role API
   ============================================ */

/* object::role("RoleName", @slot_specs) - define a role */
static XS(xs_role) {
    dXSARGS;
    STRLEN role_len;
    const char *role_pv;
    RoleMeta *meta;
    IV i;
    
    if (items < 1) croak("Usage: object::role($role_name, @slot_specs)");
    
    role_pv = SvPV(ST(0), role_len);
    
    /* Check if role already exists */
    meta = get_role_meta(aTHX_ role_pv, role_len);
    if (meta) {
        croak("Role '%s' already defined", role_pv);
    }
    
    /* Create role meta */
    Newxz(meta, 1, RoleMeta);
    Newxz(meta->role_name, role_len + 1, char);
    Copy(role_pv, meta->role_name, role_len, char);
    meta->role_name[role_len] = '\0';
    meta->stash = gv_stashpvn(role_pv, role_len, GV_ADD);
    
    /* Allocate slots array */
    if (items > 1) {
        Newx(meta->slots, items - 1, SlotSpec*);
        meta->slot_count = 0;
        
        for (i = 1; i < items; i++) {
            STRLEN spec_len;