Ancient

 view release on metacpan or  search on metacpan

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

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


    /* Validate object is of expected class (stash pointer comparison) */
    if (data->expected_class) {
        if (SvSTASH(SvRV(obj)) != data->expected_class->stash) {
            croak("Expected object of class '%s', got '%s'",
                  data->expected_class->class_name,
                  HvNAME(SvSTASH(SvRV(obj))));
        }
    }

    /* Bounds check */
    if (idx > av_len(av)) {
        SETs(&PL_sv_undef);
        RETURN;
    }

    svp = av_fetch(av, idx, 0);
    SETs((svp && SvOK(*svp)) ? *svp : &PL_sv_undef);
    RETURN;
}

static OP* pp_object_func_set(pTHX) {
    dSP;
    SV *val = POPs;  /* Pop value first */
    SV *obj = TOPs;  /* Object left on stack */
    FuncAccessorData *data = get_func_accessor_data(PL_op->op_targ);
    IV idx;
    AV *av;

    if (!data) {
        croak("Internal error: invalid accessor data");
    }
    idx = data->slot_idx;

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

    /* Validate object is of expected class (stash pointer comparison) */
    if (data->expected_class && SvSTASH(SvRV(obj)) != data->expected_class->stash) {
        croak("Expected object of class '%s', got '%s'",
              data->expected_class->class_name,
              HvNAME(SvSTASH(SvRV(obj))));
    }

    av_store(av, idx, newSVsv(val));

    SETs(val);  /* Replace object with value */
    RETURN;
}

/* Check if an op is "simple" (can be safely used in optimized accessor) */
OBJECT_INLINE bool is_simple_op(OP *op) {
    if (!op) return false;
    /* Simple ops: pad variables, constants, global variables */
    switch (op->op_type) {
        case OP_PADSV:    /* $lexical */
        case OP_CONST:    /* literal value */
        case OP_GV:       /* *glob */
        case OP_GVSV:     /* $global */
        case OP_AELEMFAST:/* $array[const] */
#if defined(OP_AELEMFAST_LEX) && OP_AELEMFAST_LEX != OP_AELEMFAST
        case OP_AELEMFAST_LEX:
#endif
        case OP_NULL:     /* Often wraps simple ops */
            return true;
        default:
            return false;
    }
}

/* Call checker for function-style accessor: name($obj) or name($obj, $val) */
static OP* func_accessor_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
    IV registry_id = SvIV(ckobj);
    FuncAccessorData *data = get_func_accessor_data(registry_id);
    OP *pushop, *cvop, *objop, *argop, *valop;
    OP *newop;

    PERL_UNUSED_ARG(namegv);

    if (!data) {
        return entersubop;  /* Fallback if data not found */
    }

    pushop = cUNOPx(entersubop)->op_first;
    if (!OpHAS_SIBLING(pushop)) {
        pushop = cUNOPx(pushop)->op_first;
    }

    /* Walk the op tree like the method-style accessor checker */
    objop = OpSIBLING(pushop);
    cvop = objop;
    argop = objop;
    while (OpHAS_SIBLING(cvop)) {
        argop = cvop;
        cvop = OpSIBLING(cvop);
    }

    /* Check if there's an argument after obj (setter call) */
    if (argop != objop) {
        /* Setter: name($obj, $val) - let XS fallback handle all setters
         * Force scalar context to prevent void context optimization */
        return op_contextualize(entersubop, G_SCALAR);
    }

    /* Getter: name($obj) - optimize only if objop is simple */
    if (!is_simple_op(objop)) {
        return entersubop;
    }

    OpMORESIB_set(pushop, cvop);
    OpLASTSIB_set(objop, NULL);

    newop = newUNOP(OP_CUSTOM, 0, objop);
    newop->op_ppaddr = pp_object_func_get;
    newop->op_targ = data->registry_id;  /* Store registry ID, not pointer */

    op_free(entersubop);
    return newop;
}

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

        XSRETURN_UNDEF;
    }

    /* Look up property index - O(1) hash lookup */
    idx_svp = hv_fetch(meta->prop_to_idx, prop_pv, prop_len, 0);
    if (!idx_svp) {
        XSRETURN_UNDEF;
    }
    idx = SvIV(*idx_svp);

    /* Build result hashref */
    info = newHV();

    /* Basic info always present */
    hv_store(info, "name", 4, newSVpv(prop_pv, prop_len), 0);
    hv_store(info, "index", 5, newSViv(idx), 0);

    /* Get slot spec if available */
    spec = (meta->slots && idx < meta->slot_count) ? meta->slots[idx] : NULL;

    if (spec && spec->has_type) {
        const char *type_name;
        if (spec->type_id == TYPE_CUSTOM && spec->registered) {
            type_name = spec->registered->name;
        } else {
            type_name = type_id_to_name(spec->type_id);
        }
        hv_store(info, "type", 4, newSVpv(type_name, 0), 0);
    }

    /* Boolean flags */
    hv_store(info, "is_required", 11, newSViv(spec ? spec->is_required : 0), 0);
    hv_store(info, "is_readonly", 11, newSViv(spec ? spec->is_readonly : 0), 0);
    hv_store(info, "is_lazy", 7, newSViv(spec ? spec->is_lazy : 0), 0);
    hv_store(info, "has_default", 11, newSViv(spec ? spec->has_default : 0), 0);
    hv_store(info, "has_trigger", 11, newSViv(spec ? spec->has_trigger : 0), 0);
    hv_store(info, "has_coerce", 10, newSViv(spec ? spec->has_coerce : 0), 0);
    hv_store(info, "has_builder", 11, newSViv(spec ? spec->has_builder : 0), 0);
    hv_store(info, "has_clearer", 11, newSViv(spec ? spec->has_clearer : 0), 0);
    hv_store(info, "has_predicate", 13, newSViv(spec ? spec->has_predicate : 0), 0);
    hv_store(info, "has_type", 8, newSViv(spec ? spec->has_type : 0), 0);

    /* Default value (if present) */
    if (spec && spec->has_default && spec->default_sv) {
        hv_store(info, "default", 7, newSVsv(spec->default_sv), 0);
    }

    /* Builder method name */
    if (spec && spec->has_builder && spec->builder_name) {
        hv_store(info, "builder", 7, newSVsv(spec->builder_name), 0);
    }

    ST(0) = sv_2mortal(newRV_noinc((SV*)info));
    XSRETURN(1);
}

/* ============================================
   Global cleanup
   ============================================ */

/* Cleanup during global destruction */
static void object_cleanup_globals(pTHX_ void *data) {
    PERL_UNUSED_ARG(data);

    /* During global destruction, just NULL out pointers.
     * Perl handles SV cleanup. Trying to free them ourselves
     * can cause crashes due to destruction order. */
    if (PL_dirty) {
        g_type_registry = NULL;
        g_class_registry = NULL;
        g_func_accessor_registry = NULL;
        return;
    }

    /* Normal cleanup - not during global destruction */
    /* Note: Full cleanup omitted for simplicity; Perl handles SV refcounts */
    g_type_registry = NULL;
    g_class_registry = NULL;
    g_func_accessor_registry = NULL;
}

/* ============================================
   Type Registry API
   ============================================ */

/* C-level registration for external XS modules (called from BOOT)
   This is the fast path - no Perl callback overhead */
PERL_CALLCONV void object_register_type_xs(pTHX_ const char *name, 
                                           ObjectTypeCheckFunc check,
                                           ObjectTypeCoerceFunc coerce) {
    RegisteredType *type;
    STRLEN name_len = strlen(name);
    
    if (!g_type_registry) {
        g_type_registry = newHV();
    }
    
    /* Check if already registered */
    SV **existing = hv_fetch(g_type_registry, name, name_len, 0);
    if (existing) {
        croak("Type '%s' is already registered", name);
    }
    
    Newxz(type, 1, RegisteredType);
    Newx(type->name, name_len + 1, char);
    Copy(name, type->name, name_len, char);
    type->name[name_len] = '\0';
    
    type->check = check;    /* Direct C function pointer - no Perl overhead */
    type->coerce = coerce;  /* Direct C function pointer - no Perl overhead */
    type->perl_check = NULL;
    type->perl_coerce = NULL;
    
    hv_store(g_type_registry, name, name_len, newSViv(PTR2IV(type)), 0);
}

/* Getter for external modules to look up a registered type */
PERL_CALLCONV RegisteredType* object_get_registered_type(pTHX_ const char *name) {
    STRLEN name_len = strlen(name);
    if (!g_type_registry) return NULL;
    
    SV **svp = hv_fetch(g_type_registry, name, name_len, 0);
    if (svp && SvIOK(*svp)) {
        return INT2PTR(RegisteredType*, SvIV(*svp));
    }
    return NULL;
}

/* object::register_type($name, $check_cb [, $coerce_cb]) */
static XS(xs_register_type) {
    dXSARGS;
    STRLEN name_len;
    const char *name;
    RegisteredType *type;
    

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

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