Affix
view release on metacpan or search on metacpan
lib/Affix/marshal.c view on Meta::CPAN
int string_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");
if (!im->ptr)
return 0;
const infix_type * t = resolve_type(aTHX_ im->type);
size_t max_len = t->meta.array_info.num_elements;
if (max_len == 0)
return 0;
SvGMAGICAL_off(sv);
STRLEN len;
const char * str = SvPV(sv, len);
size_t to_copy = (len < max_len) ? len : max_len - 1;
memcpy(im->ptr, str, to_copy);
((char *)im->ptr)[to_copy] = '\0';
SvGMAGICAL_on(sv);
return 0;
}
MGVTBL string_vtable = {string_mg_get, string_mg_set, nullptr, nullptr, free_v2_pin};
/**
* @brief Reads UTF-16/32 Wide Strings from C and converts them into a Perl UTF-8 String.
*/
int wstring_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);
size_t max_len = t->meta.array_info.num_elements;
size_t el_sz = t->meta.array_info.element_type->size;
SvSMAGICAL_off(sv);
size_t act = 0;
if (!im->ptr) {
sv_setpvn(sv, "", 0);
SvSMAGICAL_on(sv);
return 0;
}
/* Find null terminator */
for (; act < max_len; act++)
if (el_sz == 2 && ((uint16_t *)im->ptr)[act] == 0)
break;
else if (el_sz == 4 && ((uint32_t *)im->ptr)[act] == 0)
break;
/* Allocate temp buffer for UTF-8 (max 4 bytes per character) */
U8 * buf = (U8 *)safemalloc(act * UTF8_MAXBYTES + 1);
U8 * d = buf;
for (size_t i = 0; i < act; i++) {
UV cp = (el_sz == 2) ? ((uint16_t *)im->ptr)[i] : ((uint32_t *)im->ptr)[i];
/* Combine Surrogate Pairs for UTF-16 */
if (el_sz == 2 && cp >= 0xD800 && cp <= 0xDBFF && i + 1 < act) {
uint16_t low = ((uint16_t *)im->ptr)[i + 1];
if (low >= 0xDC00 && low <= 0xDFFF) {
cp = 0x10000 + (((cp - 0xD800) << 10) | (low - 0xDC00));
i++;
}
}
d = uvchr_to_utf8(d, cp);
}
*d = '\0';
sv_setpvn(sv, (char *)buf, d - buf);
SvUTF8_on(sv);
safefree(buf);
SvSMAGICAL_on(sv);
return 0;
}
/**
* @brief Converts a Perl UTF-8 string into a C UTF-16/32 Array.
*/
int wstring_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");
if (!im->ptr)
return 0;
const infix_type * t = resolve_type(aTHX_ im->type);
size_t max_len = t->meta.array_info.num_elements;
size_t el_sz = t->meta.array_info.element_type->size;
if (max_len == 0)
return 0;
SvGMAGICAL_off(sv);
STRLEN len;
char * str = SvPVutf8(sv, len);
U8 * p = (U8 *)str;
U8 * pend = p + len;
size_t i = 0;
while (p < pend && i < max_len - 1) {
STRLEN rlen;
UV cp = utf8_to_uvchr_buf(p, pend, &rlen);
if (rlen == 0)
break;
p += rlen;
if (cp == 0)
break;
/* Split UTF-8 back into UTF-16 Surrogate Pairs if applicable */
if (el_sz == 2 && cp > 0xFFFF) {
/* Truncation safety: Don't write half a pair if buffer is almost full */
if (i < max_len - 2) {
cp -= 0x10000;
((uint16_t *)im->ptr)[i++] = 0xD800 + (cp >> 10);
((uint16_t *)im->ptr)[i++] = 0xDC00 + (cp & 0x3FF);
}
else
break;
}
else {
if (el_sz == 2)
((uint16_t *)im->ptr)[i++] = (uint16_t)cp;
else
((uint32_t *)im->ptr)[i++] = (uint32_t)cp;
}
}
/* Terminate string */
if (el_sz == 2)
((uint16_t *)im->ptr)[i] = 0;
else
((uint32_t *)im->ptr)[i] = 0;
SvGMAGICAL_on(sv);
return 0;
}
MGVTBL wstring_vtable = {wstring_mg_get, wstring_mg_set, nullptr, nullptr, free_v2_pin};
/**
* @brief VTable GET handler for Bitfields
*/
int get_bitfield(pTHX_ SV * sv, MAGIC * mg) {
Affix_Pin_2_Point_Oh * im = (Affix_Pin_2_Point_Oh *)mg->mg_ptr;
const infix_type * type = resolve_type(aTHX_ im->type);
SvSMAGICAL_off(sv);
if (!im->ptr) {
sv_setsv(sv, &PL_sv_undef);
SvSMAGICAL_on(sv);
return 0;
}
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);
uint64_t mask = (im->bit_width == 64) ? ~0ULL : ((1ULL << im->bit_width) - 1);
val = (val >> im->bit_offset) & mask;
lib/Affix/marshal.c view on Meta::CPAN
else
sv_setuv(ret, PTR2UV(addr));
}
else {
sv_setuv(ret, PTR2UV(addr));
}
PUTBACK;
FREETMPS;
LEAVE;
return ret;
}
int get_ptr(pTHX_ SV * sv, MAGIC * mg) {
Affix_Pin_2_Point_Oh * im = (Affix_Pin_2_Point_Oh *)mg->mg_ptr;
SvSMAGICAL_off(sv);
/* If it's absolute (malloc/cast/pin), im->ptr is the memory address of the data.
If it's relative (struct member), im->ptr is the address of a pointer variable. */
void * addr = im->absolute ? im->ptr : (im->ptr ? *(void **)im->ptr : nullptr);
if (!addr) {
sv_setsv(sv, &PL_sv_undef);
}
else {
const infix_type * res = resolve_type(aTHX_ im->type);
/* Detect terminal pointers (String, StringList, Callback, etc.) */
Affix_Pull puller = get_pull_handler(aTHX_ res);
if (puller && puller != pull_pointer_as_pin) {
puller(aTHX_ nullptr, sv, res, &addr, im->readonly);
}
else {
/* If the type is a pointer, step down one level. */
const infix_type * pointee =
(res->category == INFIX_TYPE_POINTER) ? res->meta.pointer_info.pointee_type : res;
/* WString (wchar_t*): convert the wide string to a Perl UTF-8 string.
Only uint16/uint32 pointers whose width matches wchar_t are treated
as WString, mirroring the marshaling in get_opcode_for_type. */
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)) {
size_t el_sz = pointee->size;
wchar_t * ws = (wchar_t *)addr;
size_t act = 0;
while (el_sz == 2 ? ((uint16_t *)ws)[act] : ((uint32_t *)ws)[act])
act++;
U8 * buf = (U8 *)safemalloc(act * UTF8_MAXBYTES + 1);
U8 * d = buf;
for (size_t i = 0; i < act; i++) {
UV cp = (el_sz == 2) ? ((uint16_t *)ws)[i] : ((uint32_t *)ws)[i];
if (el_sz == 2 && cp >= 0xD800 && cp <= 0xDBFF && i + 1 < act) {
uint16_t low = ((uint16_t *)ws)[i + 1];
if (low >= 0xDC00 && low <= 0xDFFF) {
cp = 0x10000 + (((cp - 0xD800) << 10) | (low - 0xDC00));
i++;
}
}
d = uvchr_to_utf8(d, cp);
}
*d = '\0';
sv_setpvn(sv, (char *)buf, d - buf);
SvUTF8_on(sv);
safefree(buf);
}
else {
/* Unwrap terminal string/void protections for the inner pin if needed */
const infix_type * pin_type = _unwrap_pin_type(pointee);
pull_pointer_as_pin(aTHX_ nullptr, sv, pin_type, &addr, im->readonly);
}
}
}
SvSMAGICAL_on(sv);
return 0;
}
int set_ptr(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");
if (!im || !im->ptr)
return 0;
SvGMAGICAL_off(sv);
void * new_addr = nullptr;
/* Priority 1: Subroutines */
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
CV * cv = (CV *)SvRV(sv);
SvREFCNT_inc(cv);
infix_reverse_t * rc = nullptr;
const infix_type * ft = resolve_type(aTHX_ im->type);
while (ft && ft->category == INFIX_TYPE_POINTER)
ft = resolve_type(aTHX_ ft->meta.pointer_info.pointee_type);
size_t n = (ft && ft->category == INFIX_TYPE_REVERSE_TRAMPOLINE) ? ft->meta.func_ptr_info.num_args : 0;
if (ft && ft->category != INFIX_TYPE_REVERSE_TRAMPOLINE)
croak("Expected a callback type for struct member assignment");
infix_type ** at = n ? (infix_type **)safecalloc(n, sizeof(infix_type *)) : nullptr;
for (size_t i = 0; i < n; i++)
at[i] = ft->meta.func_ptr_info.args[i].type;
if (ft && ft->category == INFIX_TYPE_REVERSE_TRAMPOLINE &&
infix_reverse_create_closure_manual(&rc,
ft->meta.func_ptr_info.return_type,
at,
n,
ft->meta.func_ptr_info.num_fixed_args,
perl_universal_closure,
cv) == INFIX_SUCCESS) {
new_addr = infix_reverse_get_code(rc);
}
if (at)
safefree(at);
}
/* Priority 2: Null */
else if (!SvOK(sv)) {
new_addr = nullptr;
}
/* Priority 3: StringLists (char**) */
else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) {
if (is_string_list_type(aTHX_ im->type)) {
AV * av = (AV *)SvRV(sv);
size_t len = av_len(av) + 1;
/* If the pin has an arena (common in struct members), we use it.
Otherwise, we use safemalloc (leak risk if not managed). */
char ** list =
(char **)(im->arena ? infix_arena_alloc(im->arena, (len + 1) * sizeof(char *), _Alignof(char *))
: safecalloc(len + 1, sizeof(char *)));
for (size_t i = 0; i < len; ++i) {
SV ** elem = av_fetch(av, i, 0);
if (elem && SvPOK(*elem)) {
STRLEN slen;
const char * s = SvPV(*elem, slen);
if (im->arena) {
list[i] = (char *)infix_arena_alloc(im->arena, slen + 1, 1);
memcpy(list[i], s, slen + 1);
}
else {
list[i] = savepv(s);
}
}
else {
list[i] = nullptr;
}
}
list[len] = nullptr;
new_addr = list;
}
else {
/* Fallback: User passed an ArrayRef to a non-char** pointer.
Treat as raw integer address. */
new_addr = INT2PTR(void *, SvUV(sv));
}
}
/* Priority 4: Strings for char* */
else if (SvPOK(sv) && !SvROK(sv) && !sv_isobject(sv)) {
const infix_type * ft_raw = resolve_type(aTHX_ im->type);
if (ft_raw->category == INFIX_TYPE_POINTER) {
const infix_type * pointee = resolve_type(aTHX_ ft_raw->meta.pointer_info.pointee_type);
if (pointee->category == INFIX_TYPE_PRIMITIVE &&
(pointee->meta.primitive_id == INFIX_PRIMITIVE_SINT8 ||
pointee->meta.primitive_id == INFIX_PRIMITIVE_UINT8)) {
new_addr = (void *)SvPV_nolen(sv);
}
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.
*/
( run in 1.398 second using v1.01-cache-2.11-cpan-ad19def0cd9 )