Ancient

 view release on metacpan or  search on metacpan

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

        svp = av_fetch(av, idx, 0);
        if (svp && SvOK(*svp)) {
            return *svp;
        }

        /* Follow prototype chain (slot 0) */
        svp = av_fetch(av, 0, 0);
        if (!svp || !SvROK(*svp) || SvTYPE(SvRV(*svp)) != SVt_PVAV) {
            break;
        }
        av = (AV*)SvRV(*svp);
        depth++;
    }

    if (depth >= MAX_PROTOTYPE_DEPTH) {
        warn("Prototype chain too deep (max %d levels)", MAX_PROTOTYPE_DEPTH);
    }

    return &PL_sv_undef;
}

/* ============================================
   Custom OP: property accessor (get)
   ============================================ */

static OP* pp_object_get(pTHX) {
    dSP;
    SV *obj = TOPs;
    IV idx = PL_op->op_targ;
    AV *av;
    SV *result;

    if (!SvROK(obj) || SvTYPE(SvRV(obj)) != SVt_PVAV) {
        croak("Not an object");
    }

    av = (AV*)SvRV(obj);
    result = resolve_property_chain(aTHX_ av, idx);
    SETs(result);
    RETURN;
}

/* ============================================
   Custom OP: property accessor (set)
   ============================================ */

static OP* pp_object_set(pTHX) {
    dSP;
    SV *val = POPs;
    SV *obj = TOPs;
    IV idx = PL_op->op_targ;
    AV *av;
    MAGIC *mg;

    if (!SvROK(obj) || SvTYPE(SvRV(obj)) != SVt_PVAV) {
        croak("Not an object");
    }

    av = (AV*)SvRV(obj);

    /* Check frozen/locked */
    mg = get_object_magic(aTHX_ obj);
    if (mg && (mg->mg_private & OBJ_FLAG_FROZEN)) {
        croak("Cannot modify frozen object");
    }

    av_store(av, idx, newSVsv(val));
    SETs(val);
    RETURN;
}

/* ============================================
   Custom OP: property accessor (set) with type check
   Uses op_private to store type ID for inline check
   ============================================ */

/* Helper struct to pass both idx and meta through op */
typedef struct {
    IV slot_idx;
    ClassMeta *meta;
} SlotOpData;

/* Helper struct for function-style accessors (cross-class support) */
struct FuncAccessorData_s {
    IV slot_idx;
    ClassMeta *expected_class;  /* Class this accessor expects */
    IV registry_id;             /* ID in g_func_accessor_registry */
};

/* Register a FuncAccessorData and return its ID */
static IV register_func_accessor_data(pTHX_ FuncAccessorData *data) {
    if (g_func_accessor_count >= g_func_accessor_capacity) {
        IV new_capacity = g_func_accessor_capacity ? g_func_accessor_capacity * 2 : 64;
        Renew(g_func_accessor_registry, new_capacity, FuncAccessorData*);
        g_func_accessor_capacity = new_capacity;
    }
    data->registry_id = g_func_accessor_count;
    g_func_accessor_registry[g_func_accessor_count] = data;
    return g_func_accessor_count++;
}

/* Look up FuncAccessorData by ID */
static FuncAccessorData* get_func_accessor_data(IV id) {
    if (id < 0 || id >= g_func_accessor_count) return NULL;
    return g_func_accessor_registry[id];
}

static OP* pp_object_set_typed(pTHX) {
    dSP;
    SV *val = POPs;
    SV *obj = TOPs;
    SlotOpData *data = INT2PTR(SlotOpData*, PL_op->op_targ);
    IV idx = data->slot_idx;
    ClassMeta *meta = data->meta;
    SlotSpec *spec = meta->slots[idx];
    AV *av;
    MAGIC *mg;

    if (!SvROK(obj) || SvTYPE(SvRV(obj)) != SVt_PVAV) {
        croak("Not an object");
    }

    av = (AV*)SvRV(obj);

    /* Check frozen/locked */
    mg = get_object_magic(aTHX_ obj);
    if (mg && (mg->mg_private & OBJ_FLAG_FROZEN)) {
        croak("Cannot modify frozen object");
    }

    /* Readonly check */
    if (spec->is_readonly) {
        croak("Cannot modify readonly slot '%s'", spec->name);
    }

    /* Coercion (if callback exists) */
    if (spec->has_coerce && spec->coerce_cb) {
        dSP;
        PUSHMARK(SP);
        XPUSHs(val);
        PUTBACK;
        call_sv(spec->coerce_cb, G_SCALAR);
        SPAGAIN;
        val = POPs;
        PUTBACK;
    }

    /* External XS type coercion (C function - fast path) */
    if (spec->type_id == TYPE_CUSTOM && spec->registered && spec->registered->coerce) {
        val = spec->registered->coerce(aTHX_ val);
    }

    /* Type check using helper (handles both C and Perl callbacks) */
    if (spec->has_type) {
        if (!check_slot_type(aTHX_ val, spec)) {
            const char *type_name = (spec->type_id == TYPE_CUSTOM && spec->registered)
                ? spec->registered->name
                : type_id_to_name(spec->type_id);
            croak("Type constraint failed for '%s': expected %s",
                  spec->name, type_name);
        }
    }

    /* Trigger callback (old, new) */
    if (spec->has_trigger && spec->trigger_cb) {
        SV *oldval = *av_fetch(av, idx, 0);
        dSP;
        PUSHMARK(SP);
        XPUSHs(obj);
        XPUSHs(oldval);
        XPUSHs(val);
        PUTBACK;
        call_sv(spec->trigger_cb, G_DISCARD);
    }

    av_store(av, idx, newSVsv(val));
    SETs(val);
    RETURN;
}

/* ============================================
   Call checker for accessor
   ============================================ */

static OP* accessor_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {

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

done:
    XSRETURN_IV(depth);
}

static XS(xs_lock) {
    dXSARGS;
    MAGIC *mg;
    
    if (items < 1) croak("Usage: object::lock($obj)");
    
    mg = get_object_magic(aTHX_ ST(0));
    if (!mg) mg = add_object_magic(aTHX_ ST(0));
    if (mg->mg_private & OBJ_FLAG_FROZEN) {
        croak("Object is frozen");
    }
    mg->mg_private |= OBJ_FLAG_LOCKED;
    XSRETURN_EMPTY;
}

static XS(xs_unlock) {
    dXSARGS;
    MAGIC *mg;
    
    if (items < 1) croak("Usage: object::unlock($obj)");
    
    mg = get_object_magic(aTHX_ ST(0));
    if (mg) {
        if (mg->mg_private & OBJ_FLAG_FROZEN) {
            croak("Cannot unlock frozen object");
        }
        mg->mg_private &= ~OBJ_FLAG_LOCKED;
    }
    XSRETURN_EMPTY;
}

static XS(xs_freeze) {
    dXSARGS;
    MAGIC *mg;
    
    if (items < 1) croak("Usage: object::freeze($obj)");
    
    mg = get_object_magic(aTHX_ ST(0));
    if (!mg) mg = add_object_magic(aTHX_ ST(0));
    mg->mg_private |= (OBJ_FLAG_FROZEN | OBJ_FLAG_LOCKED);
    XSRETURN_EMPTY;
}

static XS(xs_is_frozen) {
    dXSARGS;
    MAGIC *mg;
    
    if (items < 1) croak("Usage: object::is_frozen($obj)");
    
    mg = get_object_magic(aTHX_ ST(0));
    if (mg && (mg->mg_private & OBJ_FLAG_FROZEN)) {
        XSRETURN_YES;
    }
    XSRETURN_NO;
}

static XS(xs_is_locked) {
    dXSARGS;
    MAGIC *mg;

    if (items < 1) croak("Usage: object::is_locked($obj)");

    mg = get_object_magic(aTHX_ ST(0));
    if (mg && (mg->mg_private & OBJ_FLAG_LOCKED)) {
        XSRETURN_YES;
    }
    XSRETURN_NO;
}

/* ============================================
   Introspection API
   ============================================ */

/* object::clone($obj) - create shallow copy of object */
static XS(xs_clone) {
    dXSARGS;
    AV *src_av, *dst_av;
    SV *src_obj, *dst_obj;
    const char *class_name;
    ClassMeta *meta;
    IV i, len;

    if (items < 1) croak("Usage: object::clone($obj) or $obj->clone()");

    src_obj = ST(0);

    if (!SvROK(src_obj) || SvTYPE(SvRV(src_obj)) != SVt_PVAV || !SvOBJECT(SvRV(src_obj))) {
        croak("object::clone: argument is not an object");
    }

    src_av = (AV*)SvRV(src_obj);

    /* Get class metadata from the blessed stash */
    class_name = HvNAME(SvSTASH(SvRV(src_obj)));
    meta = get_class_meta(aTHX_ class_name, strlen(class_name));

    /* Create new AV with same size */
    len = av_len(src_av);
    dst_av = newAV();
    av_extend(dst_av, len);

    /* Shallow copy all slots */
    for (i = 0; i <= len; i++) {
        SV **svp = av_fetch(src_av, i, 0);
        if (svp && SvOK(*svp)) {
            av_store(dst_av, i, newSVsv(*svp));
        } else {
            av_store(dst_av, i, newSV(0));
        }
    }

    /* Create blessed reference to same class (clone is NOT frozen/locked) */
    dst_obj = newRV_noinc((SV*)dst_av);
    sv_bless(dst_obj, meta ? meta->stash : SvSTASH(SvRV(src_obj)));

    ST(0) = sv_2mortal(dst_obj);
    XSRETURN(1);
}

/* object::properties($class) - return property names for a class */
static XS(xs_properties) {
    dXSARGS;
    STRLEN class_len;
    const char *class_pv;
    ClassMeta *meta;
    IV i;

    if (items < 1) croak("Usage: object::properties($class)");

    class_pv = SvPV(ST(0), class_len);

    meta = get_class_meta(aTHX_ class_pv, class_len);
    if (!meta) {
        /* Non-existent class: return empty list / 0 */
        if (GIMME_V == G_ARRAY) {
            XSRETURN_EMPTY;
        } else {
            XSRETURN_IV(0);
        }
    }

    if (GIMME_V == G_ARRAY) {
        /* List context: return property names */
        IV count = meta->slot_count - 1;  /* -1 because slot 0 is prototype */
        SP -= items;
        EXTEND(SP, count);

        for (i = 1; i < meta->slot_count; i++) {
            if (meta->idx_to_prop[i]) {
                PUSHs(sv_2mortal(newSVpv(meta->idx_to_prop[i], 0)));
            }
        }
        XSRETURN(count);
    } else {
        /* Scalar context: return count */
        XSRETURN_IV(meta->slot_count - 1);
    }
}

/* object::slot_info($class, $property) - return hashref with slot metadata */
static XS(xs_slot_info) {
    dXSARGS;
    STRLEN class_len, prop_len;
    const char *class_pv, *prop_pv;
    ClassMeta *meta;
    SV **idx_svp;
    IV idx;
    SlotSpec *spec;
    HV *info;

    if (items < 2) croak("Usage: object::slot_info($class, $property)");

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

    meta->singleton_instance = NULL;

    /* Install instance() class method */
    snprintf(full_name, sizeof(full_name), "%s::instance", class_pv);
    instance_cv = newXS(full_name, xs_singleton_instance, __FILE__);
    CvXSUBANY(instance_cv).any_iv = PTR2IV(meta);

    XSRETURN_EMPTY;
}

/* ============================================
   Boot
   ============================================ */

XS_EXTERNAL(boot_object) {
    dXSBOOTARGSXSAPIVERCHK;
    PERL_UNUSED_VAR(items);

    /* Register custom ops */
    XopENTRY_set(&object_new_xop, xop_name, "object_new");
    XopENTRY_set(&object_new_xop, xop_desc, "object constructor");
    Perl_custom_op_register(aTHX_ pp_object_new, &object_new_xop);
    
    XopENTRY_set(&object_get_xop, xop_name, "object_get");
    XopENTRY_set(&object_get_xop, xop_desc, "object property get");
    Perl_custom_op_register(aTHX_ pp_object_get, &object_get_xop);
    
    XopENTRY_set(&object_set_xop, xop_name, "object_set");
    XopENTRY_set(&object_set_xop, xop_desc, "object property set");
    Perl_custom_op_register(aTHX_ pp_object_set, &object_set_xop);

    XopENTRY_set(&object_set_typed_xop, xop_name, "object_set_typed");
    XopENTRY_set(&object_set_typed_xop, xop_desc, "object property set with type check");
    Perl_custom_op_register(aTHX_ pp_object_set_typed, &object_set_typed_xop);

    XopENTRY_set(&object_func_get_xop, xop_name, "object_func_get");
    XopENTRY_set(&object_func_get_xop, xop_desc, "object function-style get");
    Perl_custom_op_register(aTHX_ pp_object_func_get, &object_func_get_xop);
    
    XopENTRY_set(&object_func_set_xop, xop_name, "object_func_set");
    XopENTRY_set(&object_func_set_xop, xop_desc, "object function-style set");
    Perl_custom_op_register(aTHX_ pp_object_func_set, &object_func_set_xop);

    /* Initialize registries */
    g_class_registry = newHV();
    g_type_registry = newHV();

    /* Install XS functions */
    newXS("object::define", xs_define, __FILE__);
    newXS("object::import_accessors", xs_import_accessors, __FILE__);
    newXS("object::import_accessor", xs_import_accessor, __FILE__);
    newXS("object::prototype", xs_prototype, __FILE__);
    newXS("object::set_prototype", xs_set_prototype, __FILE__);
    newXS("object::prototype_chain", xs_prototype_chain, __FILE__);
    newXS("object::has_own_property", xs_has_own_property, __FILE__);
    newXS("object::prototype_depth", xs_prototype_depth, __FILE__);
    newXS("object::lock", xs_lock, __FILE__);
    newXS("object::unlock", xs_unlock, __FILE__);
    newXS("object::freeze", xs_freeze, __FILE__);
    newXS("object::is_frozen", xs_is_frozen, __FILE__);
    newXS("object::is_locked", xs_is_locked, __FILE__);

    /* Introspection API */
    newXS("object::clone", xs_clone, __FILE__);
    newXS("object::properties", xs_properties, __FILE__);
    newXS("object::slot_info", xs_slot_info, __FILE__);

    /* Type registry API */
    newXS("object::register_type", xs_register_type, __FILE__);
    newXS("object::has_type", xs_has_type, __FILE__);
    newXS("object::list_types", xs_list_types, __FILE__);

    /* Singleton support */
    newXS("object::singleton", xs_singleton, __FILE__);
    
    /* Role API */
    newXS("object::role", xs_role, __FILE__);
    newXS("object::requires", xs_requires, __FILE__);
    newXS("object::with", xs_with, __FILE__);
    newXS("object::does", xs_does, __FILE__);
    
    /* Method modifier API */
    newXS("object::before", xs_before, __FILE__);
    newXS("object::after", xs_after, __FILE__);
    newXS("object::around", xs_around, __FILE__);

    /* Register cleanup for global destruction */
    Perl_call_atexit(aTHX_ object_cleanup_globals, NULL);

    Perl_xs_boot_epilog(aTHX_ ax);
}