view release on metacpan or  search on metacpan

lib/Affix/marshal.c  view on Meta::CPAN

    uint64_t val = 0;
    size_t sz = type->size;
    if (sz == 1)
        memcpy(&val, im->ptr, 1);
    else if (sz == 2)
        memcpy(&val, im->ptr, 2);
    else if (sz == 4)
        memcpy(&val, im->ptr, 4);
    else if (sz == 8)
        memcpy(&val, im->ptr, 8);
    /* Calculate bitmask and apply overflow protection */
    uint64_t wmask = (im->bit_width == 64) ? ~0ULL : ((1ULL << im->bit_width) - 1);
    uint64_t mask = wmask << im->bit_offset;
    uint64_t new_bits = (SvUV(sv) & wmask) << im->bit_offset;
    val = (val & ~mask) | new_bits;
    if (sz == 1)
        memcpy(im->ptr, &val, 1);
    else if (sz == 2)
        memcpy(im->ptr, &val, 2);
    else if (sz == 4)
        memcpy(im->ptr, &val, 4);
    else if (sz == 8)
        memcpy(im->ptr, &val, 8);
    SvGMAGICAL_on(sv);
    return 0;
}

MGVTBL vtbl_bitfield = {get_bitfield, set_bitfield, nullptr, nullptr, free_v2_pin};

/**
 * @brief Universal closure trampoline for FFI Perl callbacks attached to Structs.
 * @details This function is invoked from native C space when a callback fires. It converts
 * the raw C arguments back into Perl variables using VTable magic, executes
 * the Perl subroutine, and marshals the result back into the expected C return type.
 */
void perl_universal_closure(infix_context_t * ctx, void * ret, void ** args) {
    dTHX;
    dSP;
    CV * perl_sub = (CV *)infix_reverse_get_user_data(ctx);
    size_t n = infix_reverse_get_num_args(ctx);

    ENTER;
    SAVETMPS;
    PUSHMARK(SP);

    /* Push C arguments onto the Perl Stack using Affix 2.0 pull handlers */
    for (size_t i = 0; i < n; i++) {
        const infix_type * type = infix_reverse_get_arg_type(ctx, i);
        Affix_Pull puller = get_pull_handler(aTHX_ type);

        if (!puller)
            croak("Unsupported struct callback argument type");

        SV * arg_sv = newSV(0);
        puller(aTHX_ nullptr, arg_sv, type, args[i], false);
        mXPUSHs(arg_sv);
    }
    PUTBACK;

    const infix_type * ret_type = infix_reverse_get_return_type(ctx);
    U32 call_flags = G_KEEPERR | ((ret_type->category == INFIX_TYPE_VOID) ? G_VOID : G_SCALAR);

    size_t count = call_sv((SV *)perl_sub, call_flags);
    SPAGAIN;

    /* Retrieve Perl return value and pass it back to C using Affix 2.0 push handlers */
    if (SvTRUE(ERRSV)) {
        Perl_warn(aTHX_ "Perl struct callback died: %" SVf, ERRSV);
        sv_setsv(ERRSV, &PL_sv_undef);
        if (ret && !(call_flags & G_VOID))
            memset(ret, 0, infix_type_get_size(ret_type));
    }
    else if (call_flags & G_SCALAR) {
        SV * return_sv = (count == 1) ? POPs : &PL_sv_undef;
        sv2ptr(aTHX_ nullptr, return_sv, ret, ret_type);
    }

    PUTBACK;
    FREETMPS;
    LEAVE;
}

void pull_pointer_as_callable(pTHX_ Affix * affix, SV * sv, const infix_type * type, void * p, bool readonly) {
    void * c_ptr = *(void **)p;
    if (c_ptr == nullptr) {
        sv_setsv(sv, &PL_sv_undef);
        return;
    }

    const infix_type * pointee = type;
    if (type->category == INFIX_TYPE_POINTER)
        pointee = resolve_type(aTHX_ type->meta.pointer_info.pointee_type);

    SV * wrapper = wrap_callable_pointer(aTHX_ c_ptr, pointee);
    sv_setsv(sv, wrapper);
    SvREFCNT_dec(wrapper);
}

/**
 * @brief Dynamically wraps a C function pointer into a callable Perl Subroutine.
 */
SV * wrap_callable_pointer(pTHX_ void * addr, const infix_type * type) {
    if (!addr)
        return newSV(0);

    char sig[512];
    /* Serialize the AST back into a string signature */
    if (infix_type_print(sig, sizeof(sig), type, INFIX_DIALECT_SIGNATURE) != INFIX_SUCCESS) {
        warn("Affix: failed to serialize callback type signature, wrapping as raw pointer");
        return newSVuv(PTR2UV(addr));
    }

    /* Strip the callback indicator '!' so Affix::wrap treats it as a standard function */
    char * sig_ptr = sig;
    if (sig_ptr[0] == '!')
        sig_ptr++;

    dSP;
    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    EXTEND(SP, 2);
    /* Push arguments for Affix::wrap($address, $signature_string) */
    PUSHs(sv_2mortal(newSVuv(PTR2UV(addr))));
    PUSHs(sv_2mortal(newSVpv(sig_ptr, 0)));
    PUTBACK;

    int count = call_pv("Affix::wrap", G_SCALAR);
    SPAGAIN;

    SV * ret = newSV(0);
    if (count == 1) {
        SV * wrapped = POPs;