view release on metacpan or  search on metacpan

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

            /* 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;
        SAVETMPS;
        PUSHMARK(SP);
        XPUSHs(val);
        PUTBACK;
        count = call_sv(spec->registered->perl_check, G_SCALAR);
        SPAGAIN;
        if (count > 0) {
            result_sv = POPs;
            result = SvTRUE(result_sv);
        }
        PUTBACK;
        FREETMPS;
        LEAVE;
        return result;
    }
    
    return true;
}

/* ============================================
   Slot spec parser: "name:Type:default(val)"
   ============================================ */

static SlotSpec* parse_slot_spec(pTHX_ const char *spec_str, STRLEN len) {
    SlotSpec *spec;
    const char *p = spec_str;
    const char *end = spec_str + len;
    const char *name_start, *name_end;
    STRLEN name_len;

    Newxz(spec, 1, SlotSpec);

    /* Parse property name (before first ':') */
    name_start = p;
    while (p < end && *p != ':') p++;
    name_end = p;

    name_len = name_end - name_start;
    Newx(spec->name, name_len + 1, char);

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

        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) {
    IV idx = SvIV(ckobj);
    OP *pushop, *cvop, *selfop, *argop;
    OP *newop;

    PERL_UNUSED_ARG(namegv);

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

    selfop = OpSIBLING(pushop);
    cvop = selfop;
    argop = selfop;
    while (OpHAS_SIBLING(cvop)) {
        argop = cvop;
        cvop = OpSIBLING(cvop);
    }

    /* Check if there's an argument after self (setter call) */
    if (argop != selfop) {
        /* Setter: $obj->name($value) */
        OP *valop = OpSIBLING(selfop);
        
        /* Detach self and val */
        OpMORESIB_set(pushop, cvop);
        OpLASTSIB_set(valop, NULL);
        OpLASTSIB_set(selfop, NULL);