view release on metacpan or  search on metacpan

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

            }
            else if (pointee->category == INFIX_TYPE_PRIMITIVE && pointee->size == sizeof(wchar_t) &&
                     (pointee->meta.primitive_id == INFIX_PRIMITIVE_UINT16 ||
                      pointee->meta.primitive_id == INFIX_PRIMITIVE_UINT32)) {
                /* WString (wchar_t*): convert the Perl UTF-8 string to UTF-16/32.
                   Mirror CASE_OP_PUSH_PTR_WCHAR. Buffer lifetime matches the pin's
                   arena (struct liveness) when available, mirroring StringList. */
                STRLEN wlen;
                U8 * s = (U8 *)SvPVutf8(sv, wlen);
                U8 * e = s + wlen;
                size_t el_sz = pointee->size;
                wchar_t * wbuf = (wchar_t *)(im->arena ? infix_arena_alloc(im->arena, (wlen + 1) * el_sz, el_sz)
                                                       : safemalloc((wlen + 1) * el_sz));
                wchar_t * d = wbuf;
                while (s < e) {
                    UV uv = utf8_to_uvchr_buf(s, e, nullptr);
                    if (el_sz == 2 && uv > 0xFFFF) {
                        uv -= 0x10000;
                        *d++ = (wchar_t)((uv >> 10) + 0xD800);
                        *d++ = (wchar_t)((uv & 0x3FF) + 0xDC00);
                    }
                    else
                        *d++ = (wchar_t)uv;
                    s += UTF8SKIP(s);
                }
                *d = 0;
                new_addr = wbuf;
            }
            else {
                new_addr = INT2PTR(void *, SvUV(sv));
            }
        }
        else {
            new_addr = INT2PTR(void *, SvUV(sv));
        }
    }

    /* Priority 5: Existing Pins/Addresses */
    else {
        void * extracted = _extract_pointer_value(aTHX_ sv, mg);
        new_addr = extracted ? extracted : (SvIOK(sv) ? INT2PTR(void *, SvUV(sv)) : nullptr);
    }

    *(void **)im->ptr = new_addr;

    SvGMAGICAL_on(sv);
    return 0;
}

MGVTBL vtbl_pointer = {get_ptr, set_ptr, nullptr, nullptr, free_v2_pin};

int array_mg_fetch(pTHX_ SV * sv, MAGIC * mg) {
    /* This is triggered when someone does $array[i] */
    /* However, for MAGIC_ext on AVs, Perl doesn't call svt_get for indices. */
    /* To truly protect indices, we'd need to hook into the AV's vtable. */
    /* For now, we will focus on the bind_aggregate logic to prevent creation of OOB pins. */
    return 0;
}

/**
 * @brief Returns the length of an Infix C array so Perl's `scalar(@arr)` works.
 */
U32 array_mg_len(pTHX_ SV * sv, MAGIC * mg) {
    Affix_Pin_2_Point_Oh * im = (Affix_Pin_2_Point_Oh *)mg->mg_ptr;
    if (!im->ptr)
        return 0;
    const infix_type * t = resolve_type(aTHX_ im->type);
    size_t len = (t->category == INFIX_TYPE_ARRAY) ? t->meta.array_info.num_elements : t->meta.vector_info.num_elements;
    return (U32)(len > 0 ? len - 1 : 0);
}

MGVTBL vtbl_array = {nullptr, nullptr, (U32 (*)(pTHX_ SV *, MAGIC *))array_mg_len, nullptr, free_v2_pin};

/**
 * @brief Lazy-loads child structures from memory when a Perl user tries to interact with a struct.
 */
int lazy_agg_get(pTHX_ SV * sv, MAGIC * mg) {
    Affix_Pin_2_Point_Oh * im = (Affix_Pin_2_Point_Oh *)mg->mg_ptr;
    if (SvROK(sv) || SvTYPE(sv) >= SVt_PVAV)
        return 0;

    SvSMAGICAL_off(sv);
    if (!im->ptr) {
        SV * rv = _bind_aggregate_internal(aTHX_ nullptr, im->type, mg->mg_obj, im->arena, true, im->readonly);
        sv_setsv(sv, rv);
        SvREFCNT_dec(rv);
        im->arena = nullptr;
    }
    else {
        SV * rv = _bind_aggregate_internal(aTHX_ im->ptr, im->type, mg->mg_obj, im->arena, true, im->readonly);
        if (SvROK(sv))
            sv_unref(sv);
        im->arena = nullptr;
        sv_setsv(sv, rv);
        SvREFCNT_dec(rv);
    }
    SvSMAGICAL_on(sv);
    return 0;
}

/**
 * @brief True if the SV is a pin still bound to the given C slot.
 * @details During a deep write (lazy_agg_set) the members/elements we placed at
 * bind time are read back and written out again, which is a no-op for the C
 * memory. Worse, reading a *union* member's pin back can dereference a garbage
 * pointer (e.g. an inactive String/pointer member such as SDL_Event's
 * `drop.file`, whose slot overlaps the active member's float data) and crash.
 * Untouched pins are skipped instead.
 */
static bool is_same_slot_pin(pTHX_ SV * sv, void * expected_ptr, const infix_type * expected_type) {
    if (!is_pin_v2(aTHX_ sv))
        return false;
    Affix_Pin_2_Point_Oh * im = get_pin_v2(aTHX_ sv);
    return im && im->ptr == expected_ptr && im->type == expected_type;
}

/**
 * @brief Performs deep writes to structs when a user assigns a hash (`$struct = { x => 1 }`).
 */
int lazy_agg_set(pTHX_ SV * sv, MAGIC * mg) {
    Affix_Pin_2_Point_Oh * im = (Affix_Pin_2_Point_Oh *)mg->mg_ptr;

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

    if (SvPOK(sv) && !SvIOK(sv)) {
        const char * type_name = infix_type_get_name(im->type);
        if (!type_name && im->type->category == INFIX_TYPE_NAMED_REFERENCE)
            type_name = im->type->meta.named_reference.name;
        if (!type_name) {
            const infix_type * resolved = resolve_type(aTHX_ im->type);
            type_name = infix_type_get_name(resolved);
        }

        if (type_name) {
            SV ** info_ptr = hv_fetch(MY_CXT.enum_registry, type_name, strlen(type_name), 0);
            if (info_ptr && SvROK(*info_ptr)) {
                HV * enum_info = (HV *)SvRV(*info_ptr);
                SV ** consts_ptr = hv_fetch(enum_info, "consts", 6, 0);
                if (consts_ptr && SvROK(*consts_ptr)) {
                    STRLEN len;
                    const char * name = SvPV(sv, len);
                    SV ** val_sv = hv_fetch((HV *)SvRV(*consts_ptr), name, len, 0);
                    if (val_sv) {
                        val = SvIV(*val_sv);
                        goto do_write;
                    }
                }
            }
        }
    }
    val = SvIV(sv);

do_write:
    {
        const infix_type * enum_type = resolve_type(aTHX_ im->type);
        const infix_type * underlying = resolve_type(aTHX_ enum_type->meta.enum_info.underlying_type);
        size_t sz = underlying->size;
        if (sz == 1)
            *(int8_t *)im->ptr = (int8_t)val;
        else if (sz == 2)
            *(int16_t *)im->ptr = (int16_t)val;
        else if (sz == 4)
            *(int32_t *)im->ptr = (int32_t)val;
        else
            *(int64_t *)im->ptr = (int64_t)val;
    }
    SvGMAGICAL_on(sv);
    return 0;
}

/* Register the VTable */
MGVTBL vtbl_enum = {get_enum, set_enum, nullptr, nullptr, free_v2_pin};

int buffer_mg_get(pTHX_ SV * sv, MAGIC * mg) {
    Affix_Pin_2_Point_Oh * im = (Affix_Pin_2_Point_Oh *)mg->mg_ptr;
    const infix_type * t = resolve_type(aTHX_ im->type);
    /* For arrays, num_elements is our buffer size */
    size_t max_len = t->meta.array_info.num_elements;

    SvSMAGICAL_off(sv);
    if (!im->ptr) {
        sv_setsv(sv, &PL_sv_undef);
    }
    else {
        /* FIX: Use sv_setpvn to copy the full length, nulls and all */
        sv_setpvn(sv, (char *)im->ptr, max_len);
    }
    SvSMAGICAL_on(sv);
    return 0;
}

int buffer_mg_set(pTHX_ SV * sv, MAGIC * mg) {
    Affix_Pin_2_Point_Oh * im = (Affix_Pin_2_Point_Oh *)mg->mg_ptr;
    if (im->readonly)
        croak("Modification of a read-only C value attempted");

    const infix_type * t = resolve_type(aTHX_ im->type);
    size_t max_len = t->meta.array_info.num_elements;

    if (!im->ptr || max_len == 0)
        return 0;

    SvGMAGICAL_off(sv);
    STRLEN len;
    char * str = SvPV(sv, len);

    /* Copy only what fits, but do NOT append a null terminator */
    size_t to_copy = (len < max_len) ? len : max_len;
    memcpy(im->ptr, str, to_copy);

    SvGMAGICAL_on(sv);
    return 0;
}

MGVTBL vtbl_buffer = {buffer_mg_get, buffer_mg_set, NULL, NULL, free_v2_pin};

/**
 * @brief Binds a single C value (primitive or placeholder) to a Perl SV with magic.
 * @param sv The Perl Scalar to bind.
 * @param ptr Pointer to the raw C memory.
 * @param type The infix_type definition.
 * @param bit_offset Offset in bits (for bitfields).
 * @param bit_width Width in bits (for bitfields).
 * @param prime If true, immediately synchronize the SV with C memory.
 * @param owner The "root" SV that owns the C memory (lifeline reference tracking).
 */
void bind_placeholder(pTHX_ SV * sv,
                      void * ptr,
                      const infix_type * type,
                      uint8_t bit_offset,
                      uint8_t bit_width,
                      bool prime,
                      SV * owner,
                      infix_arena_t * arena,
                      bool readonly,
                      bool absolute) {
    const infix_type * res = resolve_type(aTHX_ type);
    infix_type_category cat = infix_type_get_category(res);

    Affix_Pin_2_Point_Oh m = {.ptr = ptr,
                              .type = type,
                              .arena = arena,
                              .bit_offset = bit_offset,
                              .bit_width = bit_width,
                              .readonly = readonly,