Affix
view release on metacpan or search on metacpan
lib/Affix/marshal.c view on Meta::CPAN
if (out_wide)
*out_wide = 0;
return 1;
}
// Check explicitly named types (e.g. char16_t, WChar, wchar_t, etc.)
const char * n = infix_type_get_name(el_raw);
if (!n && el_raw->category == INFIX_TYPE_NAMED_REFERENCE)
n = el_raw->meta.named_reference.name;
if (!n) {
n = infix_type_get_name(el_res);
if (!n && el_res->category == INFIX_TYPE_NAMED_REFERENCE)
n = el_res->meta.named_reference.name;
}
if (n) {
/* Use a robust substring check to catch all variations of "char" / "WChar" */
if (strstr(n, "char") || strstr(n, "Char") || strstr(n, "CHAR") || strEQ(n, "WChar") || strEQ(n, "wchar_t")) {
if (el_res->size == 2 || el_res->size == 4) {
if (out_wide)
*out_wide = 1;
return 1;
}
}
}
return 0;
}
/**
* @brief Recursively resolves named references and enums to their underlying AST types.
* @param type The infix_type definition to resolve.
* @return The resolved infix_type.
*/
const infix_type * resolve_type(pTHX_ const infix_type * type) {
dMY_CXT;
while (type) {
if (type->category == INFIX_TYPE_NAMED_REFERENCE) {
if (!MY_CXT.registry)
break;
const infix_type * resolved = infix_registry_lookup_type(MY_CXT.registry, type->meta.named_reference.name);
if (resolved)
type = resolved;
else
break;
}
else
break;
}
return type;
}
#define MG_V2_TABLE(get, set, len) {get, set, len, nullptr, free_v2_pin, nullptr, dup_v2_pin}
/*
FAST DISPATCH VTABLES:
These Virtual Tables hook into Perl's SV read/write events. Instead of
allocating a new SV on every read, they intercept reads and map them directly
from the underlying C memory, creating zero-copy bindings.
*/
#undef MAKE_PRIMITIVE_DISPATCH
#define MAKE_PRIMITIVE_DISPATCH(NAME, C_TYPE, SV_SET, SV_GET) \
int get_##NAME(pTHX_ SV * sv, MAGIC * mg) { \
Affix_Pin_2_Point_Oh * im = (Affix_Pin_2_Point_Oh *)mg->mg_ptr; \
SvSMAGICAL_off(sv); \
if (!im->ptr) \
sv_setsv(sv, &PL_sv_undef); \
else { \
C_TYPE val; \
memcpy(&val, im->ptr, sizeof(C_TYPE)); \
SV_SET(sv, val); \
} \
SvSMAGICAL_on(sv); \
return 0; \
} \
int set_##NAME(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; \
SvGMAGICAL_off(sv); \
C_TYPE val = (C_TYPE)SV_GET(sv); \
memcpy(im->ptr, &val, sizeof(C_TYPE)); \
SvGMAGICAL_on(sv); \
return 0; \
} \
MGVTBL vtbl_##NAME = MG_V2_TABLE(get_##NAME, set_##NAME, nullptr);
MAKE_PRIMITIVE_DISPATCH(sint8, int8_t, sv_setiv, SvIV)
MAKE_PRIMITIVE_DISPATCH(uint8, uint8_t, sv_setuv, SvUV)
MAKE_PRIMITIVE_DISPATCH(sint16, int16_t, sv_setiv, SvIV)
MAKE_PRIMITIVE_DISPATCH(uint16, uint16_t, sv_setuv, SvUV)
MAKE_PRIMITIVE_DISPATCH(sint32, int32_t, sv_setiv, SvIV)
MAKE_PRIMITIVE_DISPATCH(uint32, uint32_t, sv_setuv, SvUV)
MAKE_PRIMITIVE_DISPATCH(sint64, int64_t, sv_setiv, SvIV)
MAKE_PRIMITIVE_DISPATCH(uint64, uint64_t, sv_setuv, SvUV)
MAKE_PRIMITIVE_DISPATCH(float, float, sv_setnv, SvNV)
MAKE_PRIMITIVE_DISPATCH(double, double, sv_setnv, SvNV)
/**
* @brief VTable GET handler for half-precision floats.
*/
int get_float16(pTHX_ SV * sv, MAGIC * mg) {
Affix_Pin_2_Point_Oh * im = (Affix_Pin_2_Point_Oh *)mg->mg_ptr;
SvSMAGICAL_off(sv);
if (!im->ptr)
sv_setsv(sv, &PL_sv_undef);
else
sv_setnv(sv, (NV)float16_to_float32(*(float16_t *)im->ptr));
SvSMAGICAL_on(sv);
return 0;
}
/**
* @brief VTable SET handler for half-precision floats.
*/
int set_float16(pTHX_ SV * sv, MAGIC * mg) {
Affix_Pin_2_Point_Oh * im = (Affix_Pin_2_Point_Oh *)mg->mg_ptr;
if (!im->ptr)
return 0;
if (im->readonly)
croak("Modification of a read-only C value attempted");
SvGMAGICAL_off(sv);
*(float16_t *)im->ptr = float32_to_float16((float)SvNV(sv));
SvGMAGICAL_on(sv);
return 0;
}
MGVTBL vtbl_float16 = {get_float16, set_float16, nullptr, nullptr, free_v2_pin};
/**
* @brief VTable Handlers for Booleans
*/
int get_bool(pTHX_ SV * sv, MAGIC * mg) {
Affix_Pin_2_Point_Oh * im = (Affix_Pin_2_Point_Oh *)mg->mg_ptr;
SvSMAGICAL_off(sv);
if (!im->ptr)
sv_setsv(sv, &PL_sv_undef);
else
sv_setiv(sv, *(bool *)im->ptr ? 1 : 0);
SvSMAGICAL_on(sv);
return 0;
}
int set_bool(pTHX_ SV * sv, MAGIC * mg) {
Affix_Pin_2_Point_Oh * im = (Affix_Pin_2_Point_Oh *)mg->mg_ptr;
if (!im->ptr)
return 0;
if (im->readonly)
croak("Modification of a read-only C value attempted");
SvGMAGICAL_off(sv);
*(bool *)im->ptr = SvTRUE(sv);
SvGMAGICAL_on(sv);
return 0;
}
MGVTBL vtbl_bool = {get_bool, set_bool, nullptr, nullptr, free_v2_pin};
/**
* @brief Converts a native 128-bit unsigned integer to a base-10 string SV.
* @details Perl lacks internal 128-bit support, so it must be marshalled as a string.
* @param sv The destination Perl Scalar.
* @param val The native 128-bit value.
* @param is_signed If true, checks the sign bit and prepends '-'.
*/
void alt_int128_to_sv(pTHX_ SV * sv, unsigned __int128 val, bool is_signed) {
char buf[64];
char * p = buf + 63;
*p = '\0';
bool neg = false;
/* Safely evaluate 128-bit negative bounds via casting */
if (is_signed && (__int128)val < 0) {
neg = true;
val = -(__int128)val;
}
if (val == 0) {
*--p = '0';
}
else {
while (val > 0) {
*--p = (char)((val % 10) + '0');
val /= 10;
}
}
if (neg)
*--p = '-';
sv_setpv(sv, p);
}
/**
* @brief Parses a base-10 or base-16 Perl String into a native 128-bit integer.
* @param sv The source Perl string.
* @return The parsed native 128-bit value.
*/
unsigned __int128 _alt_sv_to_int128(pTHX_ SV * sv) {
STRLEN len;
char * p = SvPV(sv, len);
unsigned __int128 res = 0;
bool neg = false;
while (len > 0 && isSPACE(*p)) {
p++;
len--;
} /* Trim leading whitespace */
if (len > 0 && *p == '-') {
neg = true;
p++;
len--;
}
/* Support Hexadecimal 0x format natively */
if (len >= 2 && p[0] == '0' && (p[1] == 'x' || p[1] == 'X')) {
p += 2;
len -= 2;
while (len > 0) {
int v = (*p >= '0' && *p <= '9') ? (*p - '0')
: (*p >= 'a' && *p <= 'f') ? (*p - 'a' + 10)
: (*p >= 'A' && *p <= 'F') ? (*p - 'A' + 10)
: -1;
if (v == -1)
break;
if (res > (unsigned __int128)~(unsigned __int128)0 / 16)
croak("Overflow parsing 128-bit hex literal");
res = res * 16 + v;
p++;
len--;
}
}
else {
while (len > 0 && *p >= '0' && *p <= '9') {
if (res > (unsigned __int128)~(unsigned __int128)0 / 10)
croak("Overflow parsing 128-bit decimal literal");
res = res * 10 + (*p - '0');
p++;
len--;
}
}
return neg ? (unsigned __int128)(-(__int128)res) : res;
}
int get_128s(pTHX_ SV * sv, MAGIC * mg) {
Affix_Pin_2_Point_Oh * im = (Affix_Pin_2_Point_Oh *)mg->mg_ptr;
SvSMAGICAL_off(sv);
if (!im->ptr)
sv_setsv(sv, &PL_sv_undef);
else
alt_int128_to_sv(aTHX_ sv, *(unsigned __int128 *)im->ptr, true);
SvSMAGICAL_on(sv);
return 0;
}
int get_128u(pTHX_ SV * sv, MAGIC * mg) {
Affix_Pin_2_Point_Oh * im = (Affix_Pin_2_Point_Oh *)mg->mg_ptr;
SvSMAGICAL_off(sv);
if (!im->ptr)
sv_setsv(sv, &PL_sv_undef);
else
alt_int128_to_sv(aTHX_ sv, *(unsigned __int128 *)im->ptr, false);
SvSMAGICAL_on(sv);
return 0;
}
int set_128(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;
SvGMAGICAL_off(sv);
*(unsigned __int128 *)im->ptr = _alt_sv_to_int128(aTHX_ sv);
SvGMAGICAL_on(sv);
return 0;
}
MGVTBL vtbl_sint128 = {get_128s, set_128, nullptr, nullptr, free_v2_pin};
MGVTBL vtbl_uint128 = {get_128u, set_128, nullptr, nullptr, free_v2_pin};
/**
* @brief Dynamic lookup to associate an Infix Type AST with a Perl Magic VTable.
*/
MGVTBL * get_primitive_vtable(const infix_type * type) {
switch (type->meta.primitive_id) {
case INFIX_PRIMITIVE_SINT8:
return &vtbl_sint8;
case INFIX_PRIMITIVE_UINT8:
return &vtbl_uint8;
case INFIX_PRIMITIVE_SINT16:
return &vtbl_sint16;
case INFIX_PRIMITIVE_UINT16:
return &vtbl_uint16;
case INFIX_PRIMITIVE_SINT32:
return &vtbl_sint32;
case INFIX_PRIMITIVE_UINT32:
return &vtbl_uint32;
case INFIX_PRIMITIVE_SINT64:
return &vtbl_sint64;
case INFIX_PRIMITIVE_UINT64:
return &vtbl_uint64;
case INFIX_PRIMITIVE_FLOAT:
return &vtbl_float;
case INFIX_PRIMITIVE_DOUBLE:
return &vtbl_double;
case INFIX_PRIMITIVE_FLOAT16:
return &vtbl_float16;
case INFIX_PRIMITIVE_BOOL:
return &vtbl_bool;
case INFIX_PRIMITIVE_SINT128:
return &vtbl_sint128;
case INFIX_PRIMITIVE_UINT128:
return &vtbl_uint128;
default:
warn("Affix: unknown primitive type ID %d, falling back to sint32", type->meta.primitive_id);
return &vtbl_sint32;
}
}
int void_mg_get(pTHX_ SV * sv, MAGIC * mg) {
SvSMAGICAL_off(sv);
sv_setsv(sv, &PL_sv_undef);
SvSMAGICAL_on(sv);
return 0;
}
MGVTBL vtbl_void = {void_mg_get, nullptr, nullptr, nullptr, free_v2_pin};
int string_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;
SvSMAGICAL_off(sv);
char * target = (char *)im->ptr;
if (!target) {
sv_setsv(sv, &PL_sv_undef);
}
else if (max_len == 0) {
sv_setpvn(sv, "", 0);
}
else {
size_t actual = 0;
while (actual < max_len && target[actual] != '\0')
actual++;
sv_setpvn(sv, target, actual);
}
SvSMAGICAL_on(sv);
return 0;
}
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)
lib/Affix/marshal.c view on Meta::CPAN
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;
bool is_signed =
(type->meta.primitive_id == INFIX_PRIMITIVE_SINT8 || type->meta.primitive_id == INFIX_PRIMITIVE_SINT16 ||
type->meta.primitive_id == INFIX_PRIMITIVE_SINT32 || type->meta.primitive_id == INFIX_PRIMITIVE_SINT64 ||
type->meta.primitive_id == INFIX_PRIMITIVE_SINT128);
if (is_signed && (val & (1ULL << (im->bit_width - 1)))) {
val |= ~mask; /* Sign extend */
sv_setiv(sv, (IV)val);
}
else {
sv_setuv(sv, val);
}
SvSMAGICAL_on(sv);
return 0;
}
/**
* @brief VTable SET handler for Bitfields (With safe mask overflow bounding)
*/
int set_bitfield(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 * type = resolve_type(aTHX_ im->type);
SvGMAGICAL_off(sv);
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;
if (SvOK(wrapped))
sv_setsv(ret, wrapped);
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");
lib/Affix/marshal.c view on Meta::CPAN
hv_store(user_hv, "_active", 7, newSVpv(m->name, 0), 0);
}
}
}
}
else if ((cat == INFIX_TYPE_ARRAY || cat == INFIX_TYPE_VECTOR || cat == INFIX_TYPE_COMPLEX) &&
SvTYPE(rv) == SVt_PVAV) {
AV * user_av = (AV *)rv;
size_t max_len, step;
const infix_type * el_type;
if (cat == INFIX_TYPE_COMPLEX) {
max_len = 2;
el_type = type->meta.complex_info.base_type;
step = el_type->size;
}
else if (cat == INFIX_TYPE_ARRAY) {
max_len = type->meta.array_info.num_elements;
el_type = type->meta.array_info.element_type;
step = resolve_type(aTHX_ el_type)->size;
}
else {
max_len = type->meta.vector_info.num_elements;
el_type = type->meta.vector_info.element_type;
step = el_type->size;
}
SSize_t user_len = av_len(user_av) + 1;
size_t copy_len = ((size_t)user_len < max_len) ? (size_t)user_len : max_len;
for (size_t i = 0; i < copy_len; i++) {
SV ** val_ptr = av_fetch(user_av, i, 0);
if (val_ptr && *val_ptr) {
void * el_slot = (char *)im->ptr + (i * step);
if (is_same_slot_pin(aTHX_ * val_ptr, el_slot, el_type))
continue; /* untouched bound pin: C memory already reflects it */
SV * temp = newSV(0);
sv_setsv(temp, *val_ptr);
bind_placeholder(aTHX_ temp, el_slot, el_type, 0, 0, false, owner, nullptr, im->readonly, false);
SvGMAGICAL_off(temp);
MAGIC * cmg = mg_find(temp, PERL_MAGIC_ext);
if (cmg && cmg->mg_virtual && cmg->mg_virtual->svt_set)
cmg->mg_virtual->svt_set(aTHX_ temp, cmg);
SvREFCNT_dec(temp);
}
}
}
SvGMAGICAL_on(sv);
SvSMAGICAL_on(sv);
return 0;
}
MGVTBL vtbl_lazy_aggregate = {lazy_agg_get, lazy_agg_set, nullptr, nullptr, free_v2_pin};
/**
* @brief VTable GET handler for Enums (Dualvar creation)
*/
int get_enum(pTHX_ SV * sv, MAGIC * mg) {
Affix_Pin_2_Point_Oh * im = (Affix_Pin_2_Point_Oh *)mg->mg_ptr;
dMY_CXT;
SvSMAGICAL_off(sv);
if (!im->ptr) {
sv_setsv(sv, &PL_sv_undef);
}
else {
/* Resolve the Enum type itself */
const infix_type * enum_type = resolve_type(aTHX_ im->type);
/* Resolve the integer type inside the enum */
const infix_type * underlying = resolve_type(aTHX_ enum_type->meta.enum_info.underlying_type);
/* Read the raw integer value */
IV val = 0;
size_t sz = underlying->size;
if (sz == 1)
val = *(int8_t *)im->ptr;
else if (sz == 2)
val = *(int16_t *)im->ptr;
else if (sz == 4)
val = *(int32_t *)im->ptr;
else
val = *(int64_t *)im->ptr;
/* Look for the name in the registry */
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)
type_name = infix_type_get_name(enum_type);
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 ** vals_ptr = hv_fetch(enum_info, "vals", 4, 0);
if (vals_ptr && SvROK(*vals_ptr)) {
char key[32];
snprintf(key, sizeof(key), "%" IVdf, val);
SV ** name_sv = hv_fetch((HV *)SvRV(*vals_ptr), key, strlen(key), 0);
if (name_sv && SvPOK(*name_sv)) {
/* Create the Dualvar: Set String then force Integer bit */
sv_setpv(sv, SvPV_nolen(*name_sv));
SvUPGRADE(sv, SVt_PVIV);
SvIV_set(sv, val);
SvIOK_on(sv);
goto done;
}
}
}
}
/* Fallback: just a normal integer */
sv_setiv(sv, val);
}
done:
SvSMAGICAL_on(sv);
return 0;
}
/**
* @brief VTable SET handler for Enums (Accepts names or integers)
*/
int set_enum(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
SvGMAGICAL_off(sv);
IV val = 0;
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,
lib/Affix/marshal.c view on Meta::CPAN
return _bind_aggregate_internal(aTHX_ ptr, type, owner, arena, false, readonly);
}
/**
* @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))
( run in 0.626 second using v1.01-cache-2.11-cpan-d80b1682f3f )