view release on metacpan or  search on metacpan

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

/**
 * @brief Registers multiple types into the global Infix Type Registry.
 * @param defs The Infix type definition string.
 */
void define_types(pTHX_ const char * defs) {
    dMY_CXT;
    if (infix_register_types(MY_CXT.registry, defs) != INFIX_SUCCESS)
        croak("Parse Error");
}

/**
 * @brief Returns the layout size of a type by name.
 * @param name Type name or AST signature.
 * @return Size in bytes.
 */
IV sizeof_type(pTHX_ const char * name) {
    dMY_CXT;
    const infix_type * t = infix_registry_lookup_type(MY_CXT.registry, name);
    if (!t) {
        infix_arena_t * ta;
        infix_type * tt;
        if (infix_type_from_signature(&tt, &ta, name, MY_CXT.registry) == INFIX_SUCCESS) {
            size_t s = tt->size;
            infix_arena_destroy(ta);
            return s;
        }
    }
    return t ? t->size : 0;
}

/**
 * @brief Returns the byte offset of a member in a struct/union.
 * @param type_name The aggregate type name.
 * @param member_name The member field name.
 * @return Offset in bytes, or -1 if not found.
 */
IV offsetof_member(pTHX_ const char * type_name, const char * member_name) {
    dMY_CXT;
    const infix_type * t = resolve_type(aTHX_ infix_registry_lookup_type(MY_CXT.registry, type_name));
    if (!t || (t->category != INFIX_TYPE_STRUCT && t->category != INFIX_TYPE_UNION))
        return -1;
    for (size_t i = 0; i < t->meta.aggregate_info.num_members; i++)
        if (strEQ(t->meta.aggregate_info.members[i].name, member_name))
            return (IV)t->meta.aggregate_info.members[i].offset;
    return -1;
}

/**
 * @brief Casts a raw pointer (or memory block) to a magic-bound Perl variable mapping its layout.
 * @param in The input SV (integer address or Affix::Memory managed object).
 * @param name The struct or primitive type name to cast the memory into.
 * @return A magic-bound SV tracking the memory block natively.
 */
SV * cast(pTHX_ SV * in, const char * name) {
    dMY_CXT;
    void * addr = get_address_v2(aTHX_ in);
    if (!addr)
        return &PL_sv_undef;

    /* Keep the blessed Affix::Memory object itself as the lifeline so the pin
       holds a strong reference to it. This keeps the memory alive for as long as
       any derived pin exists and lets free()/DESTROY locate the owner. */
    SV * owner = (SvROK(in) && sv_derived_from(in, "Affix::Memory")) ? in : nullptr;
    infix_type * new_type = nullptr;
    infix_arena_t * local_arena = nullptr;

    if (infix_type_from_signature(&new_type, &local_arena, name, MY_CXT.registry) != INFIX_SUCCESS)
        croak("Type not found: %s", name);

    const infix_type * resolved = resolve_type(aTHX_ new_type);
    infix_type_category cat = infix_type_get_category(resolved);

    /* AGGREGATES: Return a Reference (HashRef, ArrayRef, or ScalarRef for strings) */
    if (cat == INFIX_TYPE_STRUCT || cat == INFIX_TYPE_UNION || cat == INFIX_TYPE_ARRAY || cat == INFIX_TYPE_VECTOR ||
        cat == INFIX_TYPE_COMPLEX) {
        return bind_aggregate_anon(aTHX_ addr, new_type, owner, local_arena, false);
    }

    /* PRIMITIVES: Return a scalar reference ($$ptr) to allow writes back to C */
    SV * sv = newSV(0);
    bind_placeholder(aTHX_ sv, addr, new_type, 0, 0, true, owner, local_arena, false, true);
    return newRV_noinc(sv);
}

/**
 * @brief Wraps an existing C pointer with a custom destructor callback into an object payload.
 * @param ptr_iv The raw pointer (as integer).
 * @param dtor_iv The destructor callback pointer (as integer).
 * @return An Affix::Memory object representing the mapped block.
 */
SV * wrap_owned(pTHX_ UV ptr_uv, UV dtor_uv) {
    AV * av = newAV();
    av_push(av, newSVuv(ptr_uv));  /* Use UV */
    av_push(av, newSVuv(dtor_uv)); /* Use UV */
    SV * rv = newRV_noinc((SV *)av);
    sv_bless(rv, gv_stashpv("Affix::Memory", GV_ADD));
    return rv;
}
/**
 * @brief Allocates zeroed C memory and wraps it into a Perl Affix::Memory object.
 * @param size Memory allocation size in bytes.
 * @return An Affix::Memory object representation.
 */
SV * alloc_owned(pTHX_ UV size) {
    void * ptr = safecalloc(1, size);
    SV * sv = newSVuv(PTR2UV(ptr)); /* Use UV */
    SV * rv = newRV_noinc(sv);
    sv_bless(rv, gv_stashpv("Affix::Memory", GV_ADD));
    return rv;
}

/**
 * @brief Garbage Collector Hook: Frees C memory owned by an Affix::Memory object.
 * @details Can fall back to standard `safefree` or use a custom C++ destructor mapping if passed via `wrap_owned`.
 * @param rv The Affix::Memory reference triggered by DESTROY.
 */
void free_owned(pTHX_ SV * rv) {
    if (!rv || !SvROK(rv))
        return;
    SV * sv = SvRV(rv);
    if (SvTYPE(sv) == SVt_PVAV) {
        AV * av = (AV *)sv;
        SV ** r_ptr = av_fetch(av, 0, 0);
        SV ** r_dtor = av_fetch(av, 1, 0);
        if (r_ptr && *r_ptr && SvOK(*r_ptr)) {


            /* Use UV directly to bypass INT2PTR sign-extension bugs */
            UV raw_ptr = SvUV(*r_ptr);
            if (raw_ptr) {
                /* Zero the pointer immediately to prevent double-free or recursion */
                sv_setuv(*r_ptr, 0);

                if (r_dtor && *r_dtor && SvOK(*r_dtor)) {
                    UV raw_dtor = SvUV(*r_dtor);
                    if (raw_dtor) {
                        /* Explicit cast to function pointer */
                        typedef void (*dtor_t)(void *);
                        dtor_t custom_dtor = (dtor_t)raw_dtor;
                        custom_dtor((void *)raw_ptr);
                        return;
                    }
                }
                safefree((void *)raw_ptr);
            }
        }
    }
    /* Case 2: alloc_owned() stores ptr directly in a UV scalar */
    else if (SvOK(sv)) {
        UV raw_ptr = SvUV(sv);
        if (raw_ptr) {
            sv_setuv(sv, 0);
            safefree((void *)raw_ptr);
        }
    }
}

IV alloc_raw(pTHX_ IV sz) { return PTR2IV(safecalloc(1, sz)); }

void set_mem_u128(IV addr, IV l, IV h) {
    unsigned __int128 * p = (unsigned __int128 *)addr;
    *p = ((unsigned __int128)h << 64) | (unsigned __int128)l;
}

IV get_string_ptr() {
    static char * m = "Hello from C Pointer";
    return PTR2IV(m);
}

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

    }
    XSRETURN(1);
}

XS_INTERNAL(XS_main_mock_cxx_delete) {
    dVAR;
    dXSARGS;
    if (items != 1)
        croak_xs_usage(cv, "ptr");
    mock_cxx_delete(INT2PTR(void *, SvIV(ST(0))));
    XSRETURN_EMPTY;
}

XS_INTERNAL(XS_main_get_mock_cxx_dtor_calls) {
    dVAR;
    dXSARGS;
    if (items != 0)
        croak_xs_usage(cv, "");
    {
        int RETVAL;
        dXSTARG;
        RETVAL = get_mock_cxx_dtor_calls();
        TARGi((IV)RETVAL, 1);
        ST(0) = TARG;
    }
    XSRETURN(1);
}

/**
 * @brief Helper to verify if a VTable belongs to the Affix system (v1 or v2).
 */
int is_v2_vtable(MGVTBL * v) {
    if (!v)
        return 0;
    return (v == &vtbl_sint8 || v == &vtbl_uint8 || v == &vtbl_sint16 || v == &vtbl_uint16 || v == &vtbl_sint32 ||
            v == &vtbl_uint32 || v == &vtbl_sint64 || v == &vtbl_uint64 || v == &vtbl_sint128 || v == &vtbl_uint128 ||
            v == &vtbl_float || v == &vtbl_double || v == &vtbl_float16 || v == &vtbl_bool || v == &vtbl_void ||
            v == &vtbl_bitfield || v == &vtbl_pointer || v == &vtbl_array || v == &string_vtable ||
            v == &wstring_vtable || v == &vtbl_lazy_aggregate || v == &vtbl_enum || v == &vtbl_buffer);
}

/**
 * @brief Internal helper to safely extract a pointer address from a Perl scalar.
 * @details This function handles Affix::Memory objects, v2.0 magical Pins, and
 * raw integers. It includes logic to handle Pointer[Void] correctly by
 * suppressing the dereference that is normally required for typed pointers.
 *
 * @param sv The Perl Scalar to inspect.
 * @param ignore_mg A specific magic pointer to skip (prevents self-extraction during assignment).
 * @return The raw C pointer address, or NULL if extraction fails.
 */
void * _extract_pointer_value(pTHX_ SV * sv, MAGIC * ignore_mg) {
    if (!sv)
        return nullptr;

    // Use a secondary pointer for unwrapping to preserve the original SV (the potential object)
    SV * target = sv;
    if (SvROK(sv))
        target = SvRV(sv);

    /* Handle Magic Pins (even inside blessed objects) */
    if (SvMAGICAL(target)) {
        MAGIC * mg = mg_find(target, PERL_MAGIC_ext);
        while (mg) {
            if (is_v2_vtable(mg->mg_virtual) && mg != ignore_mg) {
                Affix_Pin_2_Point_Oh * im = (Affix_Pin_2_Point_Oh *)mg->mg_ptr;
                if (mg->mg_virtual == &vtbl_pointer)
                    return im->absolute ? im->ptr : (im->ptr ? *(void **)im->ptr : nullptr);
                return im->ptr;
            }
            mg = mg->mg_moremagic;
        }
    }

    /* Handle Affix::Memory Handles */
    if (sv_isobject(sv) && sv_derived_from(sv, "Affix::Memory")) {
        SV * rv = SvRV(sv);
        if (SvTYPE(rv) == SVt_PVAV) {
            SV ** p = av_fetch((AV *)rv, 0, 0);
            return (p && *p) ? INT2PTR(void *, SvUV(*p)) : nullptr;
        }
        return INT2PTR(void *, SvUV(rv));
    }

    /* Fallback: Raw Integers */
    if (SvIOK(sv))
        return INT2PTR(void *, SvUV(sv));

    return nullptr;
}

/**
 * @brief The internal C function to extract a pointer from the 2.0 memory system.
 * @param sv The SV to inspect (Handle or Magical Variable).
 * @return The raw C pointer, or nullptr if not found.
 */
void * get_address_v2(pTHX_ SV * sv) { return _extract_pointer_value(aTHX_ sv, nullptr); }

/**
 * @brief Determines the underlying type for a pointer pin.
 * @details Prevents unwrapping char* (which should remain a string) but unwraps others
 * so that $$ptr reads the correct data type.
 */
const infix_type * _unwrap_pin_type(const infix_type * type) {
    if (type->category == INFIX_TYPE_POINTER) {
        const infix_type * pointee = type->meta.pointer_info.pointee_type;
        /* Do not unwrap char*; it's handled as a terminal String */
        if (pointee->category == INFIX_TYPE_PRIMITIVE && (pointee->meta.primitive_id <= INFIX_PRIMITIVE_UINT8))
            return type;
        /* Do not unwrap Void; we want Pointer[Void] pins for raw addresses */
        if (pointee->category == INFIX_TYPE_VOID)
            return type;
        return pointee;
    }
    return type;
}

/**
 * @brief Checks if a Perl Scalar is managed by the new 2.0 memory system.
 * @details This identifies SVs that are directly mapped to C memory via the
 * Affix_Pin_2_Point_Oh struct and its associated VTables or an Affix::Memory handle.