view release on metacpan or  search on metacpan

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

/* Global class registry */
static HV *g_class_registry = NULL;  /* class name -> ClassMeta* */

/* Global type registry for external plugins */
static HV *g_type_registry = NULL;   /* type name -> RegisteredType* */

/* Global role registry */
static HV *g_role_registry = NULL;   /* role name -> RoleMeta* */

/* Forward declaration for FuncAccessorData */
typedef struct FuncAccessorData_s FuncAccessorData;

/* Global registry for function accessor data (to avoid storing pointers in op_targ) */
static FuncAccessorData **g_func_accessor_registry = NULL;
static IV g_func_accessor_count = 0;
static IV g_func_accessor_capacity = 0;

/* Forward declarations */
static ClassMeta* get_class_meta(pTHX_ const char *class_name, STRLEN len);
static void install_constructor(pTHX_ const char *class_name, ClassMeta *meta);
static void install_accessor(pTHX_ const char *class_name, const char *prop_name, IV idx);
static void install_accessor_typed(pTHX_ const char *class_name, const char *prop_name, IV idx, ClassMeta *meta);
static void install_clearer(pTHX_ const char *class_name, const char *prop_name, IV idx, ClassMeta *meta);
static void install_predicate(pTHX_ const char *class_name, const char *prop_name, IV idx, ClassMeta *meta);
static void install_destroy_wrapper(pTHX_ const char *class_name, ClassMeta *meta);
static RoleMeta* get_role_meta(pTHX_ const char *role_name, STRLEN len);

/* ============================================
   Built-in type checking (inline)
   ============================================ */

OBJECT_INLINE BuiltinTypeID parse_builtin_type(const char *type_str, STRLEN len) {
    if (len == 3 && strEQ(type_str, "Str")) return TYPE_STR;
    if (len == 3 && strEQ(type_str, "Int")) return TYPE_INT;
    if (len == 3 && strEQ(type_str, "Num")) return TYPE_NUM;
    if (len == 3 && strEQ(type_str, "Any")) return TYPE_ANY;
    if (len == 4 && strEQ(type_str, "Bool")) return TYPE_BOOL;
    if (len == 6 && strEQ(type_str, "Object")) return TYPE_OBJECT;
    if (len == 7 && strEQ(type_str, "Defined")) return TYPE_DEFINED;
    if (len == 7 && strEQ(type_str, "CodeRef")) return TYPE_CODEREF;
    if (len == 7 && strEQ(type_str, "HashRef")) return TYPE_HASHREF;
    if (len == 8 && strEQ(type_str, "ArrayRef")) return TYPE_ARRAYREF;
    return TYPE_NONE;  /* Unknown - could be custom */
}

/* Inline type check - returns true if value passes check */
OBJECT_INLINE bool check_builtin_type(pTHX_ SV *val, BuiltinTypeID type_id) {
    switch (type_id) {
        case TYPE_ANY:
            return true;
        case TYPE_DEFINED:
            /* SvOK checks if defined, but be defensive for older Perls */
            /* where constant 0 might have edge cases */
            return SvOK(val) || SvIOK(val) || SvNOK(val) || SvPOK(val);
        case TYPE_STR:
            return SvOK(val) && !SvROK(val);  /* defined non-ref */
        case TYPE_INT:
            if (SvIOK(val)) return true;
            if (SvPOK(val)) {
                /* String that looks like integer */
                STRLEN len;
                const char *pv;
                const char *p;

                pv = SvPV(val, len);
                if (len == 0) return false;
                p = pv;
                if (*p == '-' || *p == '+') p++;
                while (*p && *p >= '0' && *p <= '9') p++;
                return p == pv + len;
            }
            return false;
        case TYPE_NUM:
            return SvNIOK(val) || (SvPOK(val) && looks_like_number(val));
        case TYPE_BOOL:
            /* Accept 0, 1, "", or boolean SVs */
            if (SvIOK(val)) {
                IV iv = SvIV(val);
                return iv == 0 || iv == 1;
            }
            return SvTRUE(val) || !SvOK(val) || (SvPOK(val) && SvCUR(val) == 0);
        case TYPE_ARRAYREF:
            return SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVAV;
        case TYPE_HASHREF:
            return SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVHV;
        case TYPE_CODEREF:
            return SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVCV;
        case TYPE_OBJECT:
            return SvROK(val) && sv_isobject(val);
        default:
            return true;  /* No check or unknown */
    }
}

/* Get type name for error messages */
static const char* type_id_to_name(BuiltinTypeID type_id) {
    switch (type_id) {
        case TYPE_ANY: return "Any";
        case TYPE_DEFINED: return "Defined";
        case TYPE_STR: return "Str";
        case TYPE_INT: return "Int";
        case TYPE_NUM: return "Num";
        case TYPE_BOOL: return "Bool";
        case TYPE_ARRAYREF: return "ArrayRef";
        case TYPE_HASHREF: return "HashRef";
        case TYPE_CODEREF: return "CodeRef";
        case TYPE_OBJECT: return "Object";
        case TYPE_CUSTOM: return "custom";
        default: return "unknown";
    }
}

/* Check a value against a slot's type constraint (handles both C and Perl callbacks) */
static bool check_slot_type(pTHX_ SV *val, SlotSpec *spec) {
    if (!spec || !spec->has_type) return true;
    
    if (spec->type_id != TYPE_CUSTOM) {
        return check_builtin_type(aTHX_ val, spec->type_id);
    }
    
    if (!spec->registered) return true;
    
    /* Try C function first (fast path - ~5 cycles) */
    if (spec->registered->check) {
        return spec->registered->check(aTHX_ val);
    }
    
    /* Fall back to Perl callback (~100 cycles) */
    if (spec->registered->perl_check) {
        dSP;
        int count;
        bool result = false;
        SV *result_sv;
        ENTER;