Affix
view release on metacpan or search on metacpan
## [v1.2.4] - 2026-08-15
Plugging leaks...
### Fixed
- Use `SAVEVPTR` and `SAVEDESTRUCTOR_X` to swap out arenas to fix leaky allocator in situations where tons of structs are passed in a list and need to be marshalled in only one direction
- Casting or binding an aggregate (`Affix::cast`, member pins) no longer leaks: member pins borrowed the freshly created parent hash/array as their lifeline, forming a strong reference cycle that Perl's refcounting cannot collect, so the whole pin tr...
- Passing a union to a wrapped call no longer segfaults: the argument sync read back *every* union member, and reading an inactive pointer/string member dereferenced the active member's float bytes as a C string pointer. Deep writes now skip members ...
- The library probe in `Affix::Platform::Unix` (`_findLib_gcc`) no longer prints linker errors (`undefined reference to WinMain`/`main`) while searching: it probes with `-shared`, which needs no entry point.
- Bitfields inside `Struct[...]` are no longer read or written out of bounds: `member->offset` now points at the storage unit base (with `bit_offset` relative to the unit) instead of the bitfield's own byte, so the unit-sized load/store in `push_stru...
- Reading and writing packed struct members (and pinned primitives) no longer uses unaligned native loads/stores: the dispatch vtables, bitfield vtables, pull handlers, and push handlers now round-trip through `memcpy`, which is safe on strict-alignm...
- Passing a wide string (`WString()`, i.e. `*wchar_t`) to a wrapped function now works on all platforms instead of croaking `Don't know how to handle this type of scalar as a pointer argument yet` on non-Windows systems, where the wide-string push op...
- Returning a `WString` no longer crashes: the wide-string pull handler called `SvGROW` on an uninitialized target SV, faulting before any buffer was allocated.
- [infix] Passing a 5-7 byte `Struct[...]` by value to a wrapped function no longer drops the trailing members on ARM64. The forward trampoline emitted a 32-bit register load unless the struct was exactly 8 bytes, so a `Struct[ arr => Array[2, UInt16...
## [v1.2.3] - 2026-08-08
### Fixed
### Fixed
- Optimized `Pointer` returns in the XSUB dispatcher for performance by inlining the marshalling path and caching the stash.
- Fixed several issues in `CLONE` where metadata, managed memory, and enum registries were not correctly duplicated across perl's ithreads.
- Improved `_get_pin_from_sv` and `is_pin` to safely handle both references to pins and direct magical scalars like those found in Unions.
- Fixed potential double-frees and leaks in `Affix_Lib_DESTROY` and `Affix_free_pin` by improving reference counting and ownership tracking.
- Symbols found via `find_symbol` now correctly track the parent `Affix::Lib` object to prevent the library from being unloaded while symbols are still in use.
- Corrected a memory corruption bug in `Affix_malloc` and `Affix_strdup` caused by uninitialized internal `Affix_Pin` structures.
- Fixed `dualvar` behavior for enums returned from C, ensuring they correctly function as both strings and integers in Perl.
- Fixed the `clean` action in `Affix::Builder` which was failing due to an undefined `rmtree` call.
- Fixed an issue where blessing a return value could prematurely trigger 'set' magic on the underlying SV.
- Fixed `typedef` parsing: Named types now return proper `Affix::Type::Reference` objects instead of strings, ensuring they are correctly resolved when nested in other aggregates.
- Fixed `cast` to correctly return blessed `Affix::Live` objects when the `+` hint is used for live struct views.
- Hardened pointer indexing: Added strict type checks to `$ptr->[$i]` to ensure indexing is only performed on `Array` types or `Void*` (byte-indexed).
## [v1.0.7] - 2026-02-15
Valgrind directed the work in Affix itself but infix got a lot of platform stability fixes which found their way into Affix by way of new Float16 support, bitfield width support, and SIMD improvements.
### Fixed
Based on infix v0.1.3
### Added
- Support for Variadic Functions (varargs):
- Implemented dynamic JIT compilation for C functions with variable arguments (e.g., `printf`).
- Added `variadic_cache` to cache trampolines for repeated calls, ensuring high performance.
- Implemented runtime type inference: Perl integers promote to `sint64`, floats to `double`, and strings to `*char`.
- Added `Affix::coerce($type, $value)` to explicitly hint types for variadic arguments. This allows passing structs by value or forcing specific integer widths where inference is insufficient.
- Cookbook: I'm putting together chapters on a wide range of topics at https://github.com/sanko/Affix.pm/discussions/categories/recipes
- `affix` and `wrap` functions now accept an address to bind to. This expects the library to be `undef` and jumps past the lib location and loading steps.
- Added `File` and `PerlIO` types.
- Allows passing Perl filehandles to C functions expecting standard C streams (`PerlIO*` => `Pointer[PerlIO]`).
- Allows receiving `FILE*` from C and using them as standard Perl filehandles (`FILE*` => `Pointer[File]`).
- A few new specialized pointer types:
- `StringList`: Automatically marshals an array ref of strings to a null-terminated `char**` array (and back). This is useful in instances where `argv` or a similar list is expected.
- `Buffer`: Allows passing a pre-allocated scalar as a mutable `char*` buffer to C (zero-copy write).
- `SockAddr`: Safe marshalling of Perl packed socket addresses to `struct sockaddr*`.
- Affix::Build: A polyglot shared library builder. Currently supports Ada, Assembly, C, C#, C++, Cobol, Crystal, Dlang, Eiffel, F#, Fortran, Futhark, Go, Haskell, Nim, OCaml, Odin, Pascal, Rust, Swift, Vlang, and Zig.
- Affix::Wrap: An experimental tool to introspect C header files and generate Affix bindings and documentation.
- Dual-Driver Architecture:
- Correctly implemented array decay for function arguments on ARM and Win64. `Array[...]` types are now marshalled into temporary C arrays and passed as pointers, matching standard C behavior. Previously, they were incorrectly passed by value, caus...
- Fixed binary safety for `Array[Char/UChar]`. Reading these arrays now respects the explicit length rather than stopping at the first null byte.
- The write-back mechanism no longer attempts to overwrite the read-only ArrayRef scalar with the pointer address.
- `Pointer[SV]` is now handled properly as args, return values, and in callbacks. Reference counting is automatic to prevent premature garbage collection of passed scalars.
- Shared libs written in Go spin up background threads (for GC and scheduling) that do not shut down cleanly when a shared library is unloaded. This often causes access violations on Windows during program exit. We attempt to work around this by de...
## [v1.0.2] - 2025-12-14
### Changed
- In an attempt to debug mystery failures in SDL3.pm, Affix.pm will warn and return `undef` instead of `croak`ing.
- Improved error reporting: if the internal error message is empty, the numeric error code is now included in the warning.
### Fixed
- [[infix]] Fixed a critical file descriptor leak on POSIX platforms (Linux/FreeBSD) where the file descriptor returned by `shm_open` was kept open for the lifetime of the trampoline, eventually hitting the process file descriptor limit (EMFILE). T...
- Fixed memory leaks that occurred when trampoline creation failed midway (cleaning up partial arenas, strings, and backend structures).
## [v1.0.1] - 2025-12-13
### Changed
- Rust (legacy)
- Expose dcNewCallVM( ... ) size variable
## [0.10] - 2023-03-11
### Changed
- Support for ArrayRef[] with dynamic size
- Support for empty Stuct[]
- Coerce Enum[] types with sv2ptr(...)
- Explicit undef values are turned into NULL in Pointer[], ArrayRef[], etc.
- Provide default values in Struct[]
- Ignore perl's PTRSIZE which might be different than the system's actual pointer size
- Cleanup VM on Affix::END()
- Simplify API around named subs
- Support for WStr (wchar_t *, PWSTR, etc.)
## [0.09] - 2023-01-26
### Added
# CORE API
Bind functions to Perl subroutines and define custom types. These are the primary entry points for interacting with
foreign libraries.
## `affix( $lib, $symbol, $params, $return )`
Attaches a symbol from a library to a named Perl subroutine in the current namespace.
- **`$lib`**: A library handle returned by `load_library`, a string name, or `undef` to search the currently running process/executable.
- **`$symbol`**: The name of the C function. To install it under a different name in Perl, pass an array reference: `['c_name', 'perl_alias']`. To bind a raw memory address, pass it directly: `[$ptr, 'perl_alias']`.
- **`$params`**: An `ArrayRef` of Affix Type objects representing the function's arguments.
- **`$return`**: A single Affix Type object representing the return value.
```perl
# Standard: Load from library
affix $lib, 'pow', [ Double, Double ] => Double;
# Rename: Load 'pow', install as 'power' in Perl
affix $lib, [ pow => 'power' ], [ Double, Double ] => Double;
# Raw pointer: Bind a specific memory address (e.g., from dlsym or JIT)
affix undef,[ $ptr => 'my_func' ], [Int] => Void;
```
On success, installs the subroutine and returns the generated code reference.
## `wrap( $lib, $symbol, $params, $return )`
Creates a wrapper around a given symbol and returns it as an anonymous `CODE` reference. Arguments are identical to
`affix` except you cannot provide an alias.
```perl
To take a deep copy (snapshot), dereference into an anonymous array ref:
```perl
my $snapshot = [@$arr];
$snapshot->[0] = 100; # Modifying snapshot does NOT affect C memory
```
#### Void Pointers
If `$type` is `Void`, the pointer is "terminal." Dereferencing it will return `undef`. In this case, use `cast()`
or `address()` to work with the raw memory address.
### Specialized Pointers
- **`File`** / **`PerlIO`**: Maps Perl filehandles (Globs or IO objects) to `FILE*` or `PerlIO*`. **Must** be wrapped in a pointer: `Pointer[File]`.
- **`SockAddr`**: Specialized marshalling for packed socket strings (e.g., from `Socket::pack_sockaddr_in`) to `struct sockaddr*`.
- **`SV`**: Direct, low-level access to Perl's internal Interpreter Object (`SV*`). **Must** be wrapped in a pointer: `Pointer[SV]`.
## Aggregate Types
# Raw Memory Operations
Classic C memory functions (memcpy, memset, etc.) available directly from Perl for high-performance byte manipulation.
These functions accept either Pins or raw integer addresses.
- `memcpy( $dest, $src, $bytes )`: Copies exactly `$bytes` from `$src` to `$dest`.
- `memmove( $dest, $src, $bytes )`: Copies `$bytes` from `$src` to `$dest`. Safe to use if the memory regions overlap.
- `memset( $ptr, $byte_val, $bytes )`: Fills the first `$bytes` of the memory block with the value `$byte_val`.
- `memcmp( $ptr1, $ptr2, $bytes )`: Compares the first `$bytes` of two memory blocks. Returns an integer less than, equal to, or greater than zero.
- `memchr( $ptr, $byte_val, $bytes )`: Locates the first occurrence of `$byte_val` within the first `$bytes` of the memory block. Returns a new Pin pointing to the match, or `undef`.
# `Const` & Readonly Memory
Enforce C's const contract at the Perl level. Affix intercepts writes to read-only memory and throws a fatal exception:
`Modification of a read-only C value attempted`.
## Declarative Const: `Const[ $type ]`
You can wrap any type in `Const[ ... ]` within a signature.
typedef Task => Struct[ id => Int, name => String ];
affix $lib, 'get_tasks', [] => Pointer[ Array[ Task(), 10 ] ];
my $tasks = get_tasks();
$tasks->[5]{id} = 404; # Writes directly to C memory!
```
### Deep Null Safety
Traversing a \`NULL\` pointer in C causes a segfault. Affix wraps C memory in Perl safety rails. If you try to traverse a
\`NULL\` pointer inside a struct, Affix intercepts it and throws a standard Perl exception (`Can't use an undefined
value as a HASH reference`).
# LIBRARIES & SYMBOLS
Load and inspect dynamic libraries across platforms. Affix's smart discovery engine handles varying extensions,
prefixes, and search paths automatically.
## Library Discovery
When you provide a bare library name (e.g., `'z'`, `'ssl'`, `'user32'`) rather than an absolute path, Affix
Locates and loads a dynamic library into memory, returning an opaque `Affix::Lib` handle.
```perl
my $lib = load_library('sqlite3');
```
**Lifecycle:** Library handles are thread-safe and internally reference-counted. The underlying OS library is only
closed (e.g., via `dlclose` or `FreeLibrary`) when all Affix wrappers and pins relying on it are destroyed.
_Note:_ When using `affix()` or `wrap()`, you can safely pass the string name directly (e.g., `affix('sqlite3',
...)`) and Affix will call `load_library` for you internally. If you pass `undef` instead of a library name, Affix
will search the currently running executable process.
### `locate_lib( $name, [$version] )`
Searches for a library using Affix's discovery engine and returns its absolute file path as a string. It **does not**
load the library into memory. This is useful if you need to pass the library path to another tool or check for its
existence.
```perl
# Find libssl.so.1.1 or libssl.1.1.dylib
my $lib = load_library('m');
# Get the raw memory address of the 'pow' function
my $pow_ptr = find_symbol($lib, 'pow');
if ($pow_ptr) {
say sprintf("pow() is located at: 0x%X", address($pow_ptr));
}
```
Returns `undef` if the symbol cannot be found.
### `libc()` and `libm()`
Helper functions that locate and return the file paths to the standard C library and the standard math library for the
current platform. Because platform implementations differ wildly (e.g., MSVCRT on Windows, glibc on Linux, libSystem on
macOS), using these helpers guarantees you get the correct library.
```perl
# Bind 'puts' from the standard C library
affix libc(), 'puts', [String] => Int;
next => Pointer[ Node() ]
];
# Create a list: 1 -> 2 -> 3
my $list = {
value => 1,
next => {
value => 2,
next => {
value => 3,
next => undef # NULL
}
}
};
# Passing to a function that processes the head
affix $lib, 'sum_list', [ Pointer[Node()] ] => Int;
say sum_list($list);
```
## Interacting with C++ Classes (vtable)
```perl
# Manual call to a vtable entry
# Suppose $obj_ptr is a pointer to a C++ object
my $vtable = cast($obj_ptr, Pointer[ Pointer[Void] ]);
my $func_ptr = $vtable->[0]; # Get first method address
# Bind and call
my $method = wrap undef, $func_ptr, [Pointer[Void], Int] => Void;
$method->($obj_ptr, 42);
```
# SEE ALSO
[FFI::Platypus](https://metacpan.org/pod/FFI%3A%3APlatypus), [C::DynaLib](https://metacpan.org/pod/C%3A%3ADynaLib), [XS::TCC](https://metacpan.org/pod/XS%3A%3ATCC), [C::Blocks](https://metacpan.org/pod/C%3A%3ABlocks)
All the heavy lifting is done by [infix](https://github.com/sanko/infix), my JIT compiler and type introspection
engine.
infix/src/arch/x64/abi_x64_emitters.c view on Meta::CPAN
uint8_t rex = 0;
if (reg >= R8_REG)
rex = 0x40 | REX_B;
if (rex)
emit_byte(buf, rex);
emit_byte(buf, 0xFF);
emit_modrm(buf, 3, 4, reg % 8); // mod=11 (register), reg=/4 for JMP
}
/**
* @internal
* @brief Emits `ud2`, an undefined instruction that causes an invalid opcode exception.
* @details Opcode format: 0F 0B
*/
INFIX_INTERNAL void emit_ud2(code_buffer * buf) { EMIT_BYTES(buf, 0x0F, 0x0B); }
/**
* @internal
* @brief Emits the two-byte `syscall` instruction.
* @details Opcode: 0F 05
*/
INFIX_INTERNAL void emit_syscall(code_buffer * buf) { EMIT_BYTES(buf, 0x0F, 0x05); }
/**
infix/src/arch/x64/abi_x64_emitters.h view on Meta::CPAN
/** @internal @brief Emits `test r64, r64` to test if a register is zero. */
INFIX_INTERNAL void emit_test_reg_reg(code_buffer * buf, x64_gpr reg1, x64_gpr reg2);
/** @internal @brief Emits `cmp r64, r64` to compare two registers. */
INFIX_INTERNAL void emit_cmp_reg_reg(code_buffer * buf, x64_gpr reg1, x64_gpr reg2);
/** @internal @brief Emits `jnz rel8` for a short conditional jump if not zero. */
INFIX_INTERNAL void emit_jnz_short(code_buffer * buf, int8_t offset);
/** @internal @brief Emits `je rel8` for a short conditional jump if equal. */
INFIX_INTERNAL void emit_je_short(code_buffer * buf, int8_t offset);
/** @internal @brief Emits `jmp r64` to jump to an address in a register. */
INFIX_INTERNAL void emit_jmp_reg(code_buffer * buf, x64_gpr reg);
/** @internal @brief Emits `ud2`, an undefined instruction that causes an invalid opcode exception. */
INFIX_INTERNAL void emit_ud2(code_buffer * buf);
// Stack Operation Emitters
/** @internal @brief Emits `pop r64` to pop a 64-bit value from the stack into a register. */
INFIX_INTERNAL void emit_pop_reg(code_buffer * buf, x64_gpr reg);
// Instruction Encoding Helpers
/** @internal @brief Emits an x86-64 ModR/M byte, used to encode operands. */
INFIX_INTERNAL void emit_modrm(code_buffer * buf, uint8_t mod, uint8_t reg_opcode, uint8_t rm);
/** @internal @brief Emits an x86-64 REX prefix byte for 64-bit operations and extended registers. */
INFIX_INTERNAL void emit_rex_prefix(code_buffer * buf, bool w, bool r, bool x, bool b);
infix/src/core/error.c view on Meta::CPAN
return "Type definition is too deeply nested";
case INFIX_CODE_EMPTY_MEMBER_NAME:
return "Named type was declared with empty angle brackets";
case INFIX_CODE_EMPTY_SIGNATURE:
return "The provided signature string was empty";
case INFIX_CODE_UNSUPPORTED_ABI:
return "The current platform ABI is not supported";
case INFIX_CODE_TYPE_TOO_LARGE:
return "A data type was too large to be handled by the ABI";
case INFIX_CODE_UNRESOLVED_NAMED_TYPE:
return "Named type not found in registry or is an undefined forward declaration";
case INFIX_CODE_INVALID_MEMBER_TYPE:
return "Aggregate contains an illegal member type (e.g., a struct with a void member)";
case INFIX_CODE_LIBRARY_NOT_FOUND:
return "The requested dynamic library could not be found";
case INFIX_CODE_SYMBOL_NOT_FOUND:
return "The requested symbol was not found in the library";
case INFIX_CODE_LIBRARY_LOAD_FAILED:
return "Loading the dynamic library failed";
default:
return "An unknown or unspecified error occurred";
lib/Affix.c view on Meta::CPAN
XSRETURN_NO;
}
// Handles UTF-16LE (Windows) and UTF-32 (Linux/Mac) conversion to UTF-8 SV
static void pull_pointer_as_wstring(pTHX_ Affix * affix, SV * sv, const infix_type * type, void * p, bool readonly) {
PERL_UNUSED_VAR(affix);
PERL_UNUSED_VAR(type);
wchar_t * wstr = *(wchar_t **)p;
if (wstr == nullptr) {
sv_setsv(sv, &PL_sv_undef);
return;
}
// Calculate length (like wcslen)
size_t wlen = 0;
while (wstr[wlen])
wlen++;
// Pre-allocate SV buffer.
// Worst case UTF-8 expansion: 1 wchar (4 bytes) -> 4 UTF-8 bytes.
lib/Affix.c view on Meta::CPAN
else {
Newxz(ret_buffer, ret_size, char);
SAVEFREEPV(ret_buffer);
}
SV ** perl_stack_frame = &ST(0);
backend->cif(ret_buffer, (void **)perl_stack_frame);
switch (backend->ret_opcode) {
case OP_RET_VOID:
sv_setsv(TARG, &PL_sv_undef);
break;
case OP_RET_BOOL:
sv_setbool(TARG, *(bool *)ret_buffer);
break;
case OP_RET_SINT8:
sv_setiv(TARG, *(int8_t *)ret_buffer);
break;
case OP_RET_UINT8:
sv_setuv(TARG, *(uint8_t *)ret_buffer);
break;
lib/Affix.c view on Meta::CPAN
break;
case OP_RET_DOUBLE:
sv_setnv(TARG, *(double *)ret_buffer);
break;
case OP_RET_PTR_CHAR:
{
char * p = *(char **)ret_buffer;
if (p)
sv_setpv(TARG, p);
else
sv_setsv(TARG, &PL_sv_undef);
break;
}
case OP_RET_PTR_WCHAR:
pull_pointer_as_pin(aTHX_ nullptr, TARG, backend->ret_type, ret_buffer, backend->ret_readonly);
break;
case OP_RET_SV:
{
SV * s = *(SV **)ret_buffer;
if (s)
sv_setsv(TARG, s);
else
sv_setsv(TARG, &PL_sv_undef);
break;
}
case OP_RET_CUSTOM:
default:
backend->pull_handler(aTHX_ nullptr, TARG, backend->ret_type, ret_buffer, backend->ret_readonly);
break;
}
ST(0) = TARG;
PL_stack_sp = PL_stack_base + ax;
lib/Affix.c view on Meta::CPAN
void * c_arg_ptr) {
PERL_UNUSED_VAR(affix);
PERL_UNUSED_VAR(info);
if (UNLIKELY(SvTYPE(perl_sv) >= SVt_PVAV))
return;
char ** p = *(char ***)c_arg_ptr;
if (p && *p)
sv_setpv(perl_sv, *p);
else
sv_setsv(perl_sv, &PL_sv_undef);
}
static void writeback_pointer_generic(pTHX_ Affix * affix, const OutParamInfo * info, SV * perl_sv, void * c_arg_ptr) {
void * inner_ptr = *(void **)c_arg_ptr;
// If the function didn't touch the output slot, inner_ptr might be a nullptr
// But inner_ptr is the address of our temp_slot if it's an lvalue
if (!inner_ptr)
return;
// Direct AV check
if (SvTYPE(perl_sv) == SVt_PVAV) {
lib/Affix.c view on Meta::CPAN
step->executor(aTHX_ affix, step, &ST(0), args_buffer, c_args, ret_buffer); \
DISPATCH(); \
} \
CASE_OP_DONE: \
DISPATCH_END(); \
\
affix->cif(ret_buffer, c_args); \
\
switch (affix->ret_opcode) { \
case OP_RET_VOID: \
sv_setsv(TARG, &PL_sv_undef); \
break; \
case OP_RET_BOOL: \
sv_setbool(TARG, *(bool *)ret_buffer); \
break; \
case OP_RET_SINT8: \
sv_setiv(TARG, *(int8_t *)ret_buffer); \
break; \
case OP_RET_UINT8: \
sv_setuv(TARG, *(uint8_t *)ret_buffer); \
break; \
lib/Affix.c view on Meta::CPAN
case OP_RET_FLOAT16: \
sv_setnv(TARG, (double)half_to_float(*(infix_float16_t *)ret_buffer)); \
break; \
case OP_RET_DOUBLE: \
sv_setnv(TARG, *(double *)ret_buffer); \
break; \
case OP_RET_PTR: \
{ \
void * c_ptr = *(void **)ret_buffer; \
if (c_ptr == nullptr) \
sv_setsv(TARG, &PL_sv_undef); \
else \
pull_pointer_as_pin(aTHX_ nullptr, TARG, affix->ret_type, ret_buffer, affix->ret_readonly); \
break; \
} \
case OP_RET_PTR_CHAR: \
{ \
char * p = *(char **)ret_buffer; \
if (p) \
sv_setpv(TARG, p); \
else \
sv_setsv(TARG, &PL_sv_undef); \
break; \
} \
case OP_RET_PTR_WCHAR: \
pull_pointer_as_wstring(aTHX_ affix, TARG, affix->ret_type, ret_buffer, affix->ret_readonly); \
break; \
case OP_RET_SV: \
{ \
SV * s = *(SV **)ret_buffer; \
if (s) \
sv_setsv(TARG, s); \
else \
sv_setsv(TARG, &PL_sv_undef); \
break; \
} \
case OP_RET_CUSTOM: \
default: \
if (affix->ret_pull_handler) \
affix->ret_pull_handler(aTHX_ affix, TARG, affix->ret_type, ret_buffer, affix->ret_readonly); \
break; \
} \
if (UNLIKELY(affix->num_out_params > 0)) { \
for (size_t i = 0; i < affix->num_out_params; ++i) { \
lib/Affix.c view on Meta::CPAN
SV ** sym_sv = av_fetch(name_av, 0, 0);
SV ** alias_sv = av_fetch(name_av, 1, 0);
if (!sym_sv || !alias_sv)
croak("Invalid name spec");
rename_str = SvPV_nolen(*alias_sv);
// Is the symbol inside the array a raw pointer?
// affix(undef, [$ptr, 'name'], ...)
symbol = get_address_v2(aTHX_ * sym_sv);
if (symbol)
;
else if (SvIOK(*sym_sv))
symbol = INT2PTR(void *, SvUV(*sym_sv));
else
symbol_name_str = SvPV_nolen(*sym_sv);
}
else {
// Name a Scalar? (string or raw pointer)
// wrap(undef, $ptr, ...)
symbol = get_address_v2(aTHX_ name_sv);
if (symbol)
;
else if (SvIOK(name_sv))
symbol = INT2PTR(void *, SvUV(name_sv));
else {
// It's a string name
symbol_name_str = SvPV_nolen(name_sv);
rename_str = symbol_name_str;
}
lib/Affix.c view on Meta::CPAN
}
static void pull_long_double(pTHX_ Affix * affix, SV * sv, const infix_type * t, void * p, bool readonly) {
long double val;
memcpy(&val, p, sizeof val);
sv_setnv(sv, (double)val);
}
static void pull_bool(pTHX_ Affix * affix, SV * sv, const infix_type * t, void * p, bool readonly) {
sv_setbool(sv, *(bool *)p);
}
static void pull_void(pTHX_ Affix * affix, SV * sv, const infix_type * t, void * p, bool readonly) {
sv_setsv(sv, &PL_sv_undef);
}
#if !defined(INFIX_COMPILER_MSVC)
static void pull_sint128(pTHX_ Affix * affix, SV * sv, const infix_type * t, void * p, bool readonly) {
sv_from_int128_safe(sv, p);
}
static void pull_uint128(pTHX_ Affix * affix, SV * sv, const infix_type * t, void * p, bool readonly) {
sv_from_uint128_safe(sv, p);
}
#endif
lib/Affix.c view on Meta::CPAN
h(aTHX_ affix, element_sv, element_type, element_ptr, readonly);
if (!existing_sv_ptr) {
if (!av_store(av, i, element_sv))
SvREFCNT_dec(element_sv);
}
}
}
static void pull_pointer_as_string(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);
else
sv_setpv(sv, (const char *)c_ptr);
}
static void pull_pointer_as_struct(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);
else {
const infix_type * pointee_type = type->meta.pointer_info.pointee_type;
pull_struct(aTHX_ affix, sv, pointee_type, c_ptr, readonly);
}
}
#if 0
static void pull_struct_as_live(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 = type->meta.pointer_info.pointee_type;
HV * hv = newHV();
SV * rv = newRV_noinc(MUTABLE_SV(hv));
//~ sv_bless(rv, gv_stashpv("Affix::Live", GV_ADD));
_populate_hv_from_c_struct(aTHX_ affix, hv, pointee_type, c_ptr, true, nullptr, readonly);
sv_setsv(sv, rv);
SvREFCNT_dec(rv);
}
#endif
static void pull_pointer_as_array(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);
else {
const infix_type * pointee_type = type->meta.pointer_info.pointee_type;
pull_array(aTHX_ affix, sv, pointee_type, c_ptr, readonly);
}
}
void pull_pointer_as_pin(pTHX_ Affix * affix, SV * sv, const infix_type * type, void * p, bool readonly) {
/* p is the address of the pointer variable in the C stack frame */
void * c_ptr = *(void **)p;
if (c_ptr == nullptr) {
sv_setsv(sv, &PL_sv_undef);
return;
}
const infix_type * pointee = _unwrap_pin_type(type);
const infix_type * res_pointee = resolve_type(aTHX_ pointee);
infix_type_category cat = infix_type_get_category(res_pointee);
if (cat == INFIX_TYPE_STRUCT || cat == INFIX_TYPE_UNION || cat == INFIX_TYPE_ARRAY || cat == INFIX_TYPE_VECTOR) {
/* Return HashRef or ArrayRef for complex types */
SV * rv = bind_aggregate(aTHX_ c_ptr, pointee, NULL, readonly);
lib/Affix.c view on Meta::CPAN
SV * rv = newRV_noinc(magic_scalar);
sv_setsv(sv, rv);
SvREFCNT_dec(rv);
}
}
static void pull_sv(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);
else
sv_setsv(sv, (SV *)c_ptr);
}
static void pull_file(pTHX_ Affix * affix, SV * sv, const infix_type * type, void * p, bool readonly) {
PERL_UNUSED_VAR(affix);
PERL_UNUSED_VAR(type);
FILE * fp = *(FILE **)p;
if (!fp) {
sv_setsv(sv, &PL_sv_undef);
return;
}
// Duplicate FD to avoid double-close issues
int fd =
#ifdef _WIN32
_fileno
#else
fileno
#endif
(fp);
if (fd < 0) {
sv_setsv(sv, &PL_sv_undef);
return;
}
int new_fd = PerlLIO_dup(fd);
if (new_fd < 0) {
sv_setsv(sv, &PL_sv_undef);
return;
}
PerlIO * new_pio = PerlIO_fdopen(new_fd, "r+"); // Assuming R/W safe
if (!new_pio) {
PerlLIO_close(new_fd);
sv_setsv(sv, &PL_sv_undef);
return;
}
GV * gv = newGVgen("Affix::FileHandle");
if (do_open(gv, "+<&", 3, FALSE, 0, 0, new_pio))
sv_setsv(sv, sv_2mortal(newRV((SV *)gv)));
else {
PerlIO_close(new_pio);
sv_setsv(sv, &PL_sv_undef);
}
}
static void pull_perlio(pTHX_ Affix * affix, SV * sv, const infix_type * type, void * p, bool readonly) {
PERL_UNUSED_VAR(affix);
PERL_UNUSED_VAR(type);
PerlIO * pio = *(PerlIO **)p;
if (!pio) {
sv_setsv(sv, &PL_sv_undef);
return;
}
int fd = PerlIO_fileno(pio);
if (fd < 0) {
sv_setsv(sv, &PL_sv_undef);
return;
}
int new_fd = PerlLIO_dup(fd);
if (new_fd < 0) {
sv_setsv(sv, &PL_sv_undef);
return;
}
PerlIO * new_pio = PerlIO_fdopen(new_fd, "r+");
if (!new_pio) {
PerlLIO_close(new_fd);
sv_setsv(sv, &PL_sv_undef);
return;
}
GV * gv = newGVgen("Affix::FileHandle");
if (do_open(gv, "+<&", 3, FALSE, 0, 0, new_pio))
sv_setsv(sv, sv_2mortal(newRV((SV *)gv)));
else {
PerlIO_close(new_pio);
sv_setsv(sv, &PL_sv_undef);
}
}
static void push_stringlist(pTHX_ Affix * affix, SV * sv, void * c_arg_ptr) {
if (!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVAV) {
*(void **)c_arg_ptr = nullptr;
return;
}
AV * av = (AV *)SvRV(sv);
lib/Affix.c view on Meta::CPAN
Implicit_Callback_Magic * magic_data;
Newxz(magic_data, 1, Implicit_Callback_Magic);
magic_data->reverse_ctx = reverse_ctx;
hv_store(MY_CXT.callback_registry, key, strlen(key), newSViv(PTR2IV(magic_data)), 0);
*(void **)p = infix_reverse_get_code(reverse_ctx);
}
}
else if (!SvOK(sv))
*(void **)p = nullptr;
else
croak("Argument for a callback must be a code reference or undef.");
}
static SV * _format_parse_error(pTHX_ const char * context_msg, const char * signature, infix_error_details_t err) {
STRLEN sig_len = strlen(signature);
int radius = 20;
size_t start = (err.position > radius) ? (err.position - radius) : 0;
size_t end = (err.position + radius < sig_len) ? (err.position + radius) : sig_len;
const char * start_indicator = (start > 0) ? "... " : "";
const char * end_indicator = (end < sig_len) ? " ..." : "";
int start_indicator_len = (start > 0) ? 4 : 0;
char snippet[128];
lib/Affix.c view on Meta::CPAN
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_EVAL |*/ G_KEEPERR | ((ret_type->category == INFIX_TYPE_VOID) ? G_VOID : G_SCALAR);
size_t count = call_sv(cb_data->coderef_rv, call_flags);
if (SvTRUE(ERRSV)) {
Perl_warn(aTHX_ "Perl callback died: %" SVf, ERRSV);
sv_setsv(ERRSV, &PL_sv_undef);
if (retval && !(call_flags & G_VOID))
memset(retval, 0, infix_type_get_size(ret_type));
}
else if (call_flags & G_SCALAR) {
SPAGAIN;
SV * return_sv = (count == 1) ? POPs : &PL_sv_undef;
sv2ptr(aTHX_ nullptr, return_sv, retval, ret_type);
PUTBACK;
}
FREETMPS;
LEAVE;
}
XS_INTERNAL(Affix_as_string) {
dVAR;
dXSARGS;
lib/Affix.c view on Meta::CPAN
if (entry->lib
#ifdef _WIN32
&& infix_library_get_symbol(entry->lib, "_cgo_dummy_export") == nullptr
#endif
)
infix_library_close(entry->lib);
#endif
safefree(entry);
}
}
hv_undef(MY_CXT.lib_registry);
MY_CXT.lib_registry = nullptr;
}
if (MY_CXT.callback_registry) {
hv_iterinit(MY_CXT.callback_registry);
HE * he;
while ((he = hv_iternext(MY_CXT.callback_registry))) {
SV * entry_sv = HeVAL(he);
Implicit_Callback_Magic * magic_data = INT2PTR(Implicit_Callback_Magic *, SvIV(entry_sv));
if (magic_data) {
infix_reverse_t * ctx = magic_data->reverse_ctx;
lib/Affix.c view on Meta::CPAN
Affix_Callback_Data * cb_data = (Affix_Callback_Data *)infix_reverse_get_user_data(ctx);
if (cb_data) {
SvREFCNT_dec(cb_data->coderef_rv);
safefree(cb_data);
}
infix_reverse_destroy(ctx);
}
safefree(magic_data);
}
}
hv_undef(MY_CXT.callback_registry);
MY_CXT.callback_registry = nullptr;
}
if (MY_CXT.registry) {
infix_registry_destroy(MY_CXT.registry);
MY_CXT.registry = nullptr;
}
_infix_cache_clear();
if (MY_CXT.enum_registry) {
// Values are HVs, we need to dec ref them?
// hv_undef decreases refcounts of values automatically.
hv_undef(MY_CXT.enum_registry);
MY_CXT.enum_registry = nullptr;
}
if (MY_CXT.coercion_cache) {
hv_undef(MY_CXT.coercion_cache);
MY_CXT.coercion_cache = nullptr;
}
MY_CXT.stash_pointer = nullptr;
XSRETURN_EMPTY;
}
XS_INTERNAL(Affix_register_enum_values) {
dXSARGS;
dMY_CXT;
if (items != 3)
lib/Affix.c view on Meta::CPAN
dMY_CXT;
infix_type * new_type = nullptr;
infix_arena_t * local_arena = nullptr;
if (infix_type_from_signature(&new_type, &local_arena, "*void", MY_CXT.registry) == INFIX_SUCCESS) {
bind_placeholder(aTHX_ sv, res, new_type, 0, 0, false, owner, local_arena, false, true);
ST(0) = sv_2mortal(newRV_noinc(sv));
}
else {
if (local_arena)
infix_arena_destroy(local_arena);
ST(0) = &PL_sv_undef;
}
XSRETURN(1);
}
XSRETURN_UNDEF;
}
XS_INTERNAL(Affix_ptr_add) {
dXSARGS;
if (items != 2)
croak_xs_usage(cv, "ptr, offset_bytes");
lib/Affix.c view on Meta::CPAN
(void)newXSproto_portable("main::test_invoke_callback", XS_main_test_invoke_callback, __FILE__, "$$$");
(void)newXSproto_portable("main::test_invoke_callback_128", XS_main_test_invoke_callback_128, __FILE__, "$$");
(void)newXSproto_portable("main::get_file_ptr", XS_main_get_file_ptr, __FILE__, "$");
(void)newXSproto_portable("main::verify_marshalling_128", XS_main_verify_marshalling_128, __FILE__, "$");
(void)newXSproto_portable("main::mock_cxx_new", XS_main_mock_cxx_new, __FILE__, "$");
(void)newXSproto_portable("main::mock_cxx_delete", XS_main_mock_cxx_delete, __FILE__, "$");
(void)newXSproto_portable("main::get_mock_cxx_dtor", XS_main_get_mock_cxx_dtor, __FILE__, "");
(void)newXSproto_portable("main::get_mock_cxx_dtor_calls", XS_main_get_mock_cxx_dtor_calls, __FILE__, "");
//(void)newXSproto_portable("::is_pin", XS_main_is_pin, __FILE__, nullptr);
}
#undef XSUB_EXPORT
Perl_xs_boot_epilog(aTHX_ ax);
}
lib/Affix.pod view on Meta::CPAN
Bind functions to Perl subroutines and define custom types. These are the primary entry points for interacting with
foreign libraries.
=head2 C<affix( $lib, $symbol, $params, $return )>
Attaches a symbol from a library to a named Perl subroutine in the current namespace.
=over
=item * B<C<$lib>>: A library handle returned by C<load_library>, a string name, or C<undef> to search the currently running process/executable.
=item * B<C<$symbol>>: The name of the C function. To install it under a different name in Perl, pass an array reference: C<['c_name', 'perl_alias']>. To bind a raw memory address, pass it directly: C<[$ptr, 'perl_alias']>.
=item * B<C<$params>>: An C<ArrayRef> of Affix Type objects representing the function's arguments.
=item * B<C<$return>>: A single Affix Type object representing the return value.
=back
# Standard: Load from library
affix $lib, 'pow', [ Double, Double ] => Double;
# Rename: Load 'pow', install as 'power' in Perl
affix $lib, [ pow => 'power' ], [ Double, Double ] => Double;
# Raw pointer: Bind a specific memory address (e.g., from dlsym or JIT)
affix undef,[ $ptr => 'my_func' ], [Int] => Void;
On success, installs the subroutine and returns the generated code reference.
=head2 C<wrap( $lib, $symbol, $params, $return )>
Creates a wrapper around a given symbol and returns it as an anonymous C<CODE> reference. Arguments are identical to
C<affix> except you cannot provide an alias.
my $pow = wrap $lib, 'pow', [ Double, Double ] => Double;
my $result = $pow->( 2, 5 );
lib/Affix.pod view on Meta::CPAN
say $arr->[0]; # Read first element from C memory
$arr->[2] = 99; # Write third element in C memory
To take a deep copy (snapshot), dereference into an anonymous array ref:
my $snapshot = [@$arr];
$snapshot->[0] = 100; # Modifying snapshot does NOT affect C memory
=head4 Void Pointers
If C<$type> is C<Void>, the pointer is "terminal." Dereferencing it will return C<undef>. In this case, use C<cast()>
or C<address()> to work with the raw memory address.
=head3 Specialized Pointers
=over
=item * B<C<File>> / B<C<PerlIO>>: Maps Perl filehandles (Globs or IO objects) to C<FILE*> or C<PerlIO*>. B<Must> be wrapped in a pointer: C<Pointer[File]>.
=item * B<C<SockAddr>>: Specialized marshalling for packed socket strings (e.g., from C<Socket::pack_sockaddr_in>) to C<struct sockaddr*>.
lib/Affix.pod view on Meta::CPAN
=over
=item * C<memcpy( $dest, $src, $bytes )>: Copies exactly C<$bytes> from C<$src> to C<$dest>.
=item * C<memmove( $dest, $src, $bytes )>: Copies C<$bytes> from C<$src> to C<$dest>. Safe to use if the memory regions overlap.
=item * C<memset( $ptr, $byte_val, $bytes )>: Fills the first C<$bytes> of the memory block with the value C<$byte_val>.
=item * C<memcmp( $ptr1, $ptr2, $bytes )>: Compares the first C<$bytes> of two memory blocks. Returns an integer less than, equal to, or greater than zero.
=item * C<memchr( $ptr, $byte_val, $bytes )>: Locates the first occurrence of C<$byte_val> within the first C<$bytes> of the memory block. Returns a new Pin pointing to the match, or C<undef>.
=back
=head1 C<Const> & Readonly Memory
Enforce C's const contract at the Perl level. Affix intercepts writes to read-only memory and throws a fatal exception:
C<Modification of a read-only C value attempted>.
=head2 Declarative Const: C<Const[ $type ]>
lib/Affix.pod view on Meta::CPAN
typedef Task => Struct[ id => Int, name => String ];
affix $lib, 'get_tasks', [] => Pointer[ Array[ Task(), 10 ] ];
my $tasks = get_tasks();
$tasks->[5]{id} = 404; # Writes directly to C memory!
=head3 Deep Null Safety
Traversing a `NULL` pointer in C causes a segfault. Affix wraps C memory in Perl safety rails. If you try to traverse a
`NULL` pointer inside a struct, Affix intercepts it and throws a standard Perl exception (C<Can't use an undefined
value as a HASH reference>).
=head1 LIBRARIES & SYMBOLS
Load and inspect dynamic libraries across platforms. Affix's smart discovery engine handles varying extensions,
prefixes, and search paths automatically.
=head2 Library Discovery
When you provide a bare library name (e.g., C<'z'>, C<'ssl'>, C<'user32'>) rather than an absolute path, Affix
lib/Affix.pod view on Meta::CPAN
=head3 C<load_library( $path_or_name )>
Locates and loads a dynamic library into memory, returning an opaque C<Affix::Lib> handle.
my $lib = load_library('sqlite3');
B<Lifecycle:> Library handles are thread-safe and internally reference-counted. The underlying OS library is only
closed (e.g., via C<dlclose> or C<FreeLibrary>) when all Affix wrappers and pins relying on it are destroyed.
I<Note:> When using C<affix()> or C<wrap()>, you can safely pass the string name directly (e.g., C<affix('sqlite3',
...)>) and Affix will call C<load_library> for you internally. If you pass C<undef> instead of a library name, Affix
will search the currently running executable process.
=head3 C<locate_lib( $name, [$version] )>
Searches for a library using Affix's discovery engine and returns its absolute file path as a string. It B<does not>
load the library into memory. This is useful if you need to pass the library path to another tool or check for its
existence.
# Find libssl.so.1.1 or libssl.1.1.dylib
my $path = locate_lib('ssl', '1.1');
lib/Affix.pod view on Meta::CPAN
my $lib = load_library('m');
# Get the raw memory address of the 'pow' function
my $pow_ptr = find_symbol($lib, 'pow');
if ($pow_ptr) {
say sprintf("pow() is located at: 0x%X", address($pow_ptr));
}
Returns C<undef> if the symbol cannot be found.
=head3 C<libc()> and C<libm()>
Helper functions that locate and return the file paths to the standard C library and the standard math library for the
current platform. Because platform implementations differ wildly (e.g., MSVCRT on Windows, glibc on Linux, libSystem on
macOS), using these helpers guarantees you get the correct library.
# Bind 'puts' from the standard C library
affix libc(), 'puts', [String] => Int;
lib/Affix.pod view on Meta::CPAN
next => Pointer[ Node() ]
];
# Create a list: 1 -> 2 -> 3
my $list = {
value => 1,
next => {
value => 2,
next => {
value => 3,
next => undef # NULL
}
}
};
# Passing to a function that processes the head
affix $lib, 'sum_list', [ Pointer[Node()] ] => Int;
say sum_list($list);
=head2 Interacting with C++ Classes (vtable)
# Manual call to a vtable entry
# Suppose $obj_ptr is a pointer to a C++ object
my $vtable = cast($obj_ptr, Pointer[ Pointer[Void] ]);
my $func_ptr = $vtable->[0]; # Get first method address
# Bind and call
my $method = wrap undef, $func_ptr, [Pointer[Void], Int] => Void;
$method->($obj_ptr, 42);
=head1 SEE ALSO
L<FFI::Platypus>, L<C::DynaLib>, L<XS::TCC>, L<C::Blocks>
All the heavy lifting is done by L<infix|https://github.com/sanko/infix>, my JIT compiler and type introspection
engine.
The Affix Cookbook: L<https://github.com/sanko/Affix.pm/discussions/54>
lib/Affix/Build.pm view on Meta::CPAN
}
# Used when mixing languages (e.g. C + Rust). We compile everything to
# static artifacts (.o or .a) and then use the system linker to combine them.
method _strategy_polyglot () {
my ( @files, @libs );
foreach my $src (@sources) {
my $handler = $self->_resolve_handler( $src->{lang} );
# Request 'static' output from the handler
my $res = $self->$handler( $src, undef, 'static' );
push @files, $res->{file};
push @libs, @{ $res->{libs} } if $res->{libs};
}
# Link step
my @cmd = ($linker);
push @cmd, $os eq 'MSWin32' ? ('-shared') : ( '-shared', '-fPIC' );
push @cmd, '-Wl,--export-all-symbols' if $os eq 'MSWin32' && $linker =~ /gcc|g\+\+|clang/;
push @cmd, '-o', $libname->stringify;
lib/Affix/Build.pm view on Meta::CPAN
}
method _can_run (@cmd) {
for my $c (@cmd) {
return $c if MM->maybe_command($c);
for my $dir ( File::Spec->path ) {
my $abs = File::Spec->catfile( $dir, $c );
return $abs if MM->maybe_command($abs);
}
}
return undef;
}
method _base ($file) { return $file->basename(qr/\.[^.]+$/); }
#
method _build_c ( $src, $out, $mode ) {
my $file = $src->{path};
my @local = @{ $src->{flags} };
my $cc = $Config{cc} // 'cc';
if ( $mode eq 'dynamic' ) {
# Combine Global CFLAGS + Local Flags + Global LDFLAGS
lib/Affix/Build.pm view on Meta::CPAN
method _build_v ( $src, $out, $mode ) {
my $file = $src->{path};
my $v = $self->_can_run('v') // croak "V not found";
if ( $mode eq 'dynamic' ) {
$self->_run( $v, '-shared', '-o', "$out", "$file" );
return $out;
}
else {
my $c_file = $build_dir->child( $self->_base($file) . '.c' );
$self->_run( $v, '-o', "$c_file", "$file" );
return $self->_build_c( { path => $c_file }, undef, 'static' );
}
}
#~ swiftc point.swift -emit-module -emit-library
#~ https://forums.swift.org/t/creating-a-c-accessible-shared-library-in-swift/45329/5
#~ https://theswiftdev.com/building-static-and-dynamic-swift-libraries-using-the-swift-compiler/#should-i-choose-dynamic-or-static-linking
method _build_swift ( $src, $out, $mode ) {
my $file = $src->{path};
my $sc = $self->_can_run('swiftc') // croak "Swiftc not found";
lib/Affix/Platform/Unix.pm view on Meta::CPAN
close $fh;
return $cc if defined $line;
}
}
return 'gcc';
}
->();
my $trace;
{
use File::Temp qw[tempfile];
my ( undef, $temp_file ) = tempfile();
if ( open( my $fh, '-|', $compiler, '-shared', '-Wl,-t', '-o', $temp_file, "-l$name" ) ) {
$trace = do { local $/; <$fh> };
close $fh;
}
if ( !defined $trace || !length $trace ) {
if ( open( my $fh2, '-|', $compiler, '--print-file-name', "lib$name.$so" ) ) {
$trace = do { local $/; <$fh2> };
close $fh2;
}
}
lib/Affix/Platform/Unix.pm view on Meta::CPAN
for my $lib ( map { path($_)->realpath } @ret ) {
next unless $lib =~ /^.*?\/lib\Q$name\E.*\.\Q$so\E(?:\.([\d\.\-]+))?$/;
$version = $1 if defined $1 && $version eq '';
$cache->{$name}{$version} //= $lib;
}
}
$cache->{$name}{$version} // ();
}
sub _get_soname ($file) { # assuming GNU binutils / ELF
return undef unless $file && -f $file;
open( my $fh, '-|', 'objdump', '-p', '-j', '.dynamic', $file ) or return;
my $dump = do { local $/; <$fh> };
close $fh;
return unless defined $dump;
$dump =~ /\sSONAME\s+([^\s]+)/ ? $1 : ();
}
}
1;
lib/Affix/Platform/Windows.pm view on Meta::CPAN
}
my $clibname;
if ( $version <= 6 ) {
$clibname = 'msvcrt';
}
elsif ( $version <= 13 ) {
$clibname = sprintf( 'msvcr%d', $version * 10 );
}
else {
# CRT not directly loadable (see python/cpython#23606)
return undef;
}
# Check for debug build
my $debug_suffix = '_d'; # Assuming debug suffix is '_d'
my $suffixes = join '|', map quotemeta, @DynaLoader::dl_extensions;
if ( $debug_suffix =~ /$suffixes/ ) {
$clibname .= $debug_suffix;
}
return "$clibname.dll";
}
lib/Affix/Wrap.pm view on Meta::CPAN
class #
Affix::Wrap::Entity {
field $name : reader : param //= '';
field $doc : reader : param //= ();
field $file : reader : param //= '';
field $line : reader : param //= 0;
field $end_line : reader : param //= 0;
field $start_offset : reader : param //= 0;
field $end_offset : reader : param //= 0;
field $is_merged : reader = 0;
field $doc_data = undef;
method mark_merged { $is_merged = 1 }
method _base($p) { return '' unless defined $p; $p =~ s{^.*[/\\]}{}; return $p }
method describe {
return sprintf '[%s] %s (%s:%d)', __CLASS__ =~ s/^Affix::Wrap:://r, $name, $self->_base($file), $line;
}
# Helper to convert Doxygen/Markdown to POD
method _format_pod($text) {
$text =~ s/^\s+|\s+$//g;
lib/Affix/Wrap.pm view on Meta::CPAN
$text =~ s/\[([^\]]+)\]\(([^)]+)\)/L<$1|$2>/g; # Links: [foo](bar) -> L<foo|bar>
return $text;
}
method parse_doc () {
return $doc_data if defined $doc_data;
my $raw = $doc // '';
my $data = { brief => '', desc => '', params => {}, return => '', };
my @lines = split /\n/, $raw;
my $current_tag = 'desc';
my $current_param = undef;
foreach my $line (@lines) {
$line =~ s/^\s+|\s+$//g;
next unless length $line;
if ( $line =~ /^[@\\]brief\s+(.*)/ ) {
$data->{brief} = $1;
$current_tag = 'brief';
}
elsif ( $line =~ /^[@\\]param(?:\[.*?\])?\s+(\w+)\s+(.*)/ ) {
$data->{params}{$1} = $2;
$current_param = $1;
lib/Affix/Wrap.pm view on Meta::CPAN
}
$out .= "=back\n\n";
}
# Format return value
if ( length $d->{return} ) {
$out .= "B<Returns:> " . $self->_format_pod( $d->{return} ) . "\n\n";
}
$out;
}
method affix( $lib //= (), $pkg //= () ) { return undef }
}
class #
Affix::Wrap::Member {
use Affix qw[Void];
field $name : reader : param //= '';
field $type : reader : param //= '';
field $doc : reader : param //= ();
field $definition : reader : param //= ();
method affix_type {
lib/Affix/Wrap.pm view on Meta::CPAN
[ map { $_->affix } @$args ]
}
} class #
Affix::Wrap::Driver::Clang {
use Config;
field $project_files : param : reader;
field $allowed_files = {};
field $project_dirs = [];
field $paths_seen = {};
field $file_cache = {};
field $last_seen_file = undef;
field $clang //= 'clang';
method _basename ($path) { return '' unless defined $path; $path =~ s{^.*[/\\]}{}; return lc($path); }
method _normalize ($path) {
return '' unless defined $path && length $path;
my $abs = Path::Tiny::path($path)->absolute->stringify;
$abs =~ s{\\}{/}g;
return $abs;
}
ADJUST {
lib/Affix/Wrap.pm view on Meta::CPAN
return 0 if $f =~ m{^/System/Library};
return 1 if $allowed_files->{$f};
for my $dir (@$project_dirs) {
return 1 if index( $f, $dir ) == 0 && ( length($f) == length($dir) || substr( $f, length($dir), 1 ) eq '/' );
}
return 0;
}
method _get_node_file($node) {
my $loc = $node->{loc};
return undef unless $loc;
my $f;
if ( ref($loc) eq 'HASH' ) {
$f = $loc->{presumedLoc}{file} || $loc->{expansionLoc}{file} || $loc->{spellingLoc}{file} || $loc->{file};
}
if ( !$f && $node->{range} && $node->{range}{begin} ) {
my $b = $node->{range}{begin};
$f = $b->{presumedLoc}{file} || $b->{expansionLoc}{file} || $b->{spellingLoc}{file} || $b->{file};
}
return undef unless $f;
$f =~ s{\\}{/}g;
$paths_seen->{$f}++;
return $f;
}
method _meta($n) {
my $s = $n->{range}{begin}{offset} // 0;
my $e = $n->{range}{end}{offset} // 0;
my $line = 0;
my $end_line = 0;
lib/Affix/Wrap.pm view on Meta::CPAN
my $kind = $child->{kind} // '';
if ( $kind eq 'RecordDecl' || $kind eq 'CXXRecordDecl' ) {
my $sub_members = $self->_extract_members( $child, $f );
my $rec = Affix::Wrap::Struct->new(
name => $child->{name} // '',
tag => $child->{tagUsed} // 'struct',
file => $f,
line => $child->{loc}{line} // 0,
end_line => $child->{loc}{line} // 0,
members => $sub_members,
doc => undef
);
my $name = $child->{name} // '';
if ( $name eq '' ) { push @pending_anonymous_records, $rec; }
}
elsif ( $kind eq 'FieldDecl' ) {
my $name = $child->{name} // '';
my $raw_type = $child->{type}{qualType};
my $type_obj = Affix::Wrap::Type->parse($raw_type);
my $def = undef;
if (@pending_anonymous_records) { $def = pop @pending_anonymous_records; }
my $f_offset = $child->{range}{begin}{offset};
my $f_end = $child->{range}{end}{offset};
my $f_doc = $self->_doc_w_trail( $f, $f_offset, $f_end );
push @members, Affix::Wrap::Member->new( name => $name, type => $type_obj, doc => $f_doc, definition => $def );
}
}
return \@members;
}
method _enum( $n, $acc, $f ) {
my ( $s, $e, $l, $el ) = $self->_meta($n);
my @c;
my $cnt = 0;
my $src = $self->_get_content($f);
for my $ch ( @{ $n->{inner} } ) {
if ( ( $ch->{kind} // '' ) eq 'EnumConstantDecl' ) {
my $name = $ch->{name};
my $val = undef;
my $off = $ch->{range}{begin}{offset};
if ( defined $off ) {
my $chunk = substr( $src, $off );
if ( $chunk =~ /^\s*\Q$name\E\s*(?:=\s*(.*?))?\s*(?:,|}|$)/s ) {
$val = $1;
if ( defined $val ) {
$val =~ s/\/\/.*$//mg;
$val =~ s/\/\*.*?\*\///sg;
$val =~ s/^\s+|\s+$//g;
}
lib/Affix/Wrap.pm view on Meta::CPAN
}
method _get_content($f) {
my $abs = $self->_normalize($f);
return $file_cache->{$abs} if exists $file_cache->{$abs};
if ( -e $abs ) { return $file_cache->{$abs} = Path::Tiny::path($abs)->slurp_utf8; }
return '';
}
method _extract_doc( $f, $off ) {
return undef unless defined $off;
my $content = $self->_get_content($f);
return undef unless length($content);
my $pre = substr( $content, 0, $off );
my @lines = split /\n/, $pre;
my @d;
my $cap = 0;
while ( my $line = pop @lines ) {
next if !$cap && $line =~ /^\s*$/;
if ( $line =~ /\*\/\s*$/ ) { $cap = 1; }
elsif ( $line =~ /^\s*\/\// ) { $cap = 1; }
if ($cap) {
unshift @d, $line;
last if $line =~ /^\s*\/\*/;
if ( $line =~ /^\s*\/\// && ( !@lines || $lines[-1] !~ /^\s*\/\// ) ) { last; }
}
else { last; }
}
return undef unless @d;
my $t = join( "\n", @d );
$t =~ s/^\s*\/\*\*?//mg;
$t =~ s/\s*\*\/$//mg;
$t =~ s/^\s*\*\s?//mg;
$t =~ s/^\s*\/\/\s?//mg;
$t =~ s/^\s+|\s+$//g;
return $t;
}
method _extract_trailing( $f, $off ) {
lib/Affix/Wrap.pm view on Meta::CPAN
my $s = $-[0];
my $e = $+[0];
my $mem = $self->_mem( substr( $1, 1, -1 ) );
my $struct = Affix::Wrap::Struct->new(
name => '',
tag => 'struct',
members => $mem,
file => $f,
line => $self->_ln( $c, $s ),
end_line => $self->_ln( $c, $e ),
doc => undef,
start_offset => $s,
end_offset => $e
);
push @$acc,
Affix::Wrap::Typedef->new(
name => $2,
underlying => $struct,
file => $f,
line => $self->_ln( $c, $s ),
end_line => $self->_ln( $c, $e ),
lib/Affix/Wrap.pm view on Meta::CPAN
# Enums (typedef)
while ( $c =~ /typedef\s+enum\s*(?:\w+\s*)?(\{(?:[^{}]++|(?1))*\})\s*(\w+)\s*;/gs ) {
my $s = $-[0];
my $e = $+[0];
my $enum = Affix::Wrap::Enum->new(
name => '',
constants => $self->_enum_consts( substr( $1, 1, -1 ) ),
file => $f,
line => $self->_ln( $c, $s ),
end_line => $self->_ln( $c, $e ),
doc => undef,
start_offset => $s,
end_offset => $e
);
push @$acc,
Affix::Wrap::Typedef->new(
name => $2,
underlying => $enum,
file => $f,
line => $self->_ln( $c, $s ),
end_line => $self->_ln( $c, $e ),
lib/Affix/Wrap.pm view on Meta::CPAN
method _enum_consts($body) {
my @cs;
my $v = 0;
for ( split /,/, $body ) {
s/\/\/.*$//;
s/\/\*.*?\*\///s;
s/^\s+|\s+$//g;
next unless length;
if (/^(\w+)\s*(?:=\s*(.+?))?$/) {
my $name = $1;
my $val = $2; # Capture string or undef
# Safe hex handling without string eval
if ( defined $val && $val =~ /^(-?)0x([\da-fA-F]+)$/ ) {
my $sign = $1 || '';
my $num = hex($2);
$val = $sign eq '-' ? -$num : $num;
}
push @cs, { name => $name, value => $val };
}
}
lib/Affix/Wrap.pm view on Meta::CPAN
method _mem($b) {
my @m;
my $pending_doc = '';
my $clean = sub ($t) {
$t =~ s/^\s*\/\*\*?//mg;
$t =~ s/\s*\*\/$//mg;
$t =~ s/^\s*\*\s?//mg;
$t =~ s/^\s*\/\/\s?//mg;
$t =~ s/^\s+|\s+$//g;
return length($t) ? $t : undef;
};
while ( length($b) > 0 ) {
if ( $b =~ s/^(\s+)// ) { next; }
if ( $b =~ s|^(\s*/\*(.*?)\*/)||s ) { $pending_doc .= $2; next; }
if ( $b =~ s|^(//(.*?)\n)|| ) { $pending_doc .= "$2\n"; next; }
if ( $b =~ s/^\s*(union|struct)\s*(\{(?:[^{}]++|(?2))*\})\s*(\w+)\s*;// ) {
my $tag = $1;
my $d = Affix::Wrap::Struct->new( name => '', tag => $tag, members => $self->_mem( substr( $2, 1, -1 ) ) );
push @m, Affix::Wrap::Member->new( name => $3, definition => $d, doc => $clean->($pending_doc) );
$pending_doc = '';
lib/Affix/Wrap.pm view on Meta::CPAN
next;
}
substr( $b, 0, 1 ) = '';
$pending_doc = '';
}
return \@m;
}
method _ln( $c, $o ) { ( substr( $c, 0, $o ) =~ tr/\n// ) + 1 }
method _doc( $c, $o ) {
return undef if $o == 0;
my @l = split /\n/, substr( $c, 0, $o );
my @d;
my $cap = 0;
while ( my $l = pop @l ) {
next if !$cap && $l =~ /^\s*$/;
if ( $l =~ s/\s*\*\/\s*$// ) { $cap = 1; }
elsif ( $l =~ m{^\s*//} ) { $cap = 1; }
if ($cap) {
unshift @d, $l;
last if $l =~ /^\s*\/\*/;
last if $l =~ m{^\s*//} && ( !@l || $l[-1] !~ m{^\s*//} );
}
else {last}
}
return undef unless @d;
my $t = join "\n", @d;
$t =~ s/^\s*(\/\*+|\*+\/|\*|\/\/)\s?//mg;
$t =~ s/^\s+|\s+$//g;
return $t;
}
}
class Affix::Wrap {
field $driver : param //= ();
field $project_files : param //= $driver->project_files;
lib/Affix/Wrap.pm view on Meta::CPAN
if ( $node isa Affix::Wrap::Macro ) {
my $val = $node->value // '';
$val =~ s/(?<=\d)[Uu][Ll]{0,2}//g; # Strip C suffixes like 100ULL
$macros{ $node->name } = $val;
}
}
my %cache;
my $resolve;
$resolve = sub {
my ($token) = @_;
return undef unless defined $token;
$token =~ s/^\s+|\s+$//g;
return oct($token) if $token =~ /^0x[\da-fA-F]+$/i;
return $token + 0 if $token =~ /^-?\d+(?:\.\d+)?$/;
return $cache{$token} if exists $cache{$token};
local $cache{$token} = undef;
my $expr = $macros{$token};
return undef unless defined $expr;
1 while $expr =~ s/^\((.*)\)$/$1/; # Strip outer parens
# Resolve bitwise and arithmetic expressions
if ( $expr =~ /[|&<>+\-*\/]/ ) {
my $evaluable = $expr;
# Using {} delimiters so the // operator doesn't break the regex parser
$evaluable =~ s{\b([a-zA-Z_]\w*)\b}{ $resolve->($1) // $1 }ge;
# Clean up any C-style suffixes that might have survived
lib/Affix/Wrap.pod view on Meta::CPAN
=back
=head2 Affix::Wrap::Macro
A preprocessor C<#define>. Only simple value macros are captured.
=over
=item * C<affix_type>: Returns string C<use constant Name =E<gt> Value>. Expressions (e.g., C<A + B>) are quoted as strings, while literals are preserved.
=item * C<affix( undef, $pkg )>: Installs the constant into C<$pkg>.
=back
=head1 Tutorials
Two workflows: use headers at runtime or generate distributable Perl modules.
=head2 Runtime Library Wrappers
If you want to use a C library immediately without creating a separate Perl module file, use the C<wrap> method.
lib/Affix/marshal.c view on Meta::CPAN
}
#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; \
lib/Affix/marshal.c view on Meta::CPAN
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) {
lib/Affix/marshal.c view on Meta::CPAN
}
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;
lib/Affix/marshal.c view on Meta::CPAN
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");
lib/Affix/marshal.c view on Meta::CPAN
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);
}
lib/Affix/marshal.c view on Meta::CPAN
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)
lib/Affix/marshal.c view on Meta::CPAN
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);
lib/Affix/marshal.c view on Meta::CPAN
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 {
lib/Affix/marshal.c view on Meta::CPAN
/**
* @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;
lib/Affix/marshal.c view on Meta::CPAN
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) {
lib/Affix/marshal.c view on Meta::CPAN
/**
* @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);
lib/Test2/Tools/Affix.pm view on Meta::CPAN
}
$hash->{$tag}
= defined $content ?
(
defined $hash->{$tag} ?
ref $hash->{$tag} eq 'ARRAY' ?
[ @{ $hash->{$tag} }, $content ] :
[ $hash->{$tag}, $content ] :
$tag =~ m/^(error|stack)$/ ? [$content] :
dec_ent($content) ) :
undef;
}
$hash;
}
# Function to run anonymous sub in a new process with valgrind
sub leaks( $name, $code_ref ) {
init_valgrind();
#
require B::Deparse;
CORE::state $deparse //= B::Deparse->new(qw[-l]);
t/001_affix.t view on Meta::CPAN
my $lib = compile_ok(<<~'');
#include "std.h"
//ext: .c
DLLEXPORT int add(int a, int b) { return a + b; }
# Get address via find_symbol (simulating getting it from vtable or dlsym)
my $ptr = find_symbol( load_library($lib), 'add' );
ok $ptr, 'Got function pointer';
# Test wrap(undef, $ptr, ...)
subtest 'wrap(undef, $ptr, ...)' => sub {
my $fn = wrap( undef, $ptr, [ Int, Int ] => Int );
is $fn->( 10, 20 ), 30, 'Wrapped raw function pointer works';
};
# Test affix(undef, [$ptr => 'name'], ...)
subtest 'affix(undef, [$ptr => name], ...)' => sub {
affix( undef, [ $ptr => 'my_add' ], [ Int, Int ] => Int );
is my_add( 5, 5 ), 10, 'Affixed raw function pointer works';
};
# Test wrap with explicit raw integer (simulating cast)
subtest 'wrap(undef, int_addr, ...)' => sub {
my $addr = address($ptr); # Convert Pin to UV
my $fn = wrap( undef, $addr, [ Int, Int ] => Int );
is $fn->( 3, 4 ), 7, 'Wrapped raw integer address works';
};
};
#
done_testing;
t/006_out_params.t view on Meta::CPAN
#
subtest 'pass by value (might be a terrible over-optimization...)' => sub {
# This might (and probably should) go away in the future
my $thing;
create_thing($thing);
is $thing, D(), 'Direct scalar argument populated';
is Affix::cast( $thing, String ), 'LValue Test', 'Pointer content correct';
free_thing($thing);
};
subtest 'explicit undef (NULL)' => sub {
create_thing(undef);
pass 'Explicit undef passed as NULL (no crash)';
};
done_testing;
t/007_pointers.t view on Meta::CPAN
$arr_ptr->[0] = 10;
$arr_ptr->[7] = 80;
# Visual evidence that the memory has actually been updated
#~ Affix::dump( $arr_ptr, 32 );
# sum_int_array takes *int, so passing [8:int] (array ref) works as pointer
ok affix( $lib_path, 'sum_int_array', [ Pointer [Int], Int ], Int ), 'affix ... "sum_int_array", ...';
is sum_int_array( $arr_ptr, 8 ), 90, 'realloc successfully resized memory';
#
isa_ok my $check_is_null = wrap( $lib_path, 'check_is_null', '(*void)->bool' ), ['Affix'];
ok $check_is_null->(undef), 'Passing undef to a *void argument is received as NULL';
subtest 'char*' => sub {
isa_ok my $get_string = wrap( $lib_path, 'get_hello_string', '()->*char' ), ['Affix'];
is $get_string->(), 'Hello from C', 'Correctly returned a C string';
isa_ok my $set_string = wrap( $lib_path, 'set_hello_string', '(*char)->bool' ), ['Affix'];
ok $set_string->('Hello from Perl'), 'Correctly passed a string to C';
};
subtest 'int32*' => sub {
isa_ok my $deref = wrap( $lib_path, 'deref_and_add', '(*int32)->int32' ), ['Affix'];
isa_ok my $modify = wrap( $lib_path, 'modify_int_ptr', '(*int32, int32)->void' ), ['Affix'];
my $int_var = 50;
t/007_pointers.t view on Meta::CPAN
isa_ok my $get_ptr = wrap( $lib_path, 'get_static_struct_ptr', '()->*@My::Struct' ), ['Affix'];
my $struct_ptr = $get_ptr->();
# Struct pointer now returns a HashRef bound to C memory
is $struct_ptr, { id => 99, value => float(-1.0), label => 'Global' }, 'Returned struct pointer works';
};
subtest 'Function Pointers (*(int->int))' => sub {
isa_ok my $harness = wrap( $lib_path, 'call_int_cb', '(*((int32)->int32), int32)->int32' ), ['Affix'];
my $result = $harness->( sub { $_[0] * 10 }, 7 );
is $result, 70, 'Correctly passed a simple coderef as a function pointer';
ok $check_is_null->(undef), 'Passing undef as a function pointer is received as NULL';
};
subtest 'Memory Management (malloc, calloc, free)' => sub {
my $ptr = malloc(32);
ok $ptr, 'malloc returns a pinned SV*';
#~ use Data::Printer;
#~ p $ptr;
#~ diag length $ptr;
#~ diag Affix::dump( $ptr, 32 );
ok my $array_ptr = calloc( 4, sizeof Int ), 'calloc returns an array';
t/007_pointers.t view on Meta::CPAN
pass 'Freed C memory';
};
subtest 'Custom Destructors' => sub {
# Get library object for libc
my $libc = load_library( libc() );
my $malloc_ptr = find_symbol( $libc, 'malloc' );
my $free_ptr = find_symbol( $libc, 'free' );
{
# Allocate memory using libc's malloc, not Affix's managed malloc
my $malloc = wrap( undef, $malloc_ptr, [Size_t] => Pointer [Void] );
my $p = $malloc->(16);
# Attaching free() as a destructor.
# When $p goes out of scope, Affix will call free($p).
attach_destructor( $p, $free_ptr, $libc );
}
pass 'Pin with custom destructor went out of scope without crashing';
};
#
done_testing;
t/012_enum.t view on Meta::CPAN
my $raw_lib = compile_ok(<<'END_RAW');
#include "std.h"
//ext: .c
DLLEXPORT int get_unknown() { return 555; }
END_RAW
my $get_unknown = wrap( $raw_lib, 'get_unknown', [] => MachineState() );
my $val = $get_unknown->();
is 0 + $val, 555, 'Unknown integer value preserved';
# Behavior for unknown strings depends on impl, usually just the number as string
# or undef string slot. Usually sv_setiv sets the IV, sv_setpv is skipped.
# So "$val" should be "555".
is "$val", '555', 'Stringification of unknown enum value falls back to number';
};
};
{
package Other::Scope;
use Affix;
use Test2::V0 qw[ok is];
t/015_library.t view on Meta::CPAN
#
my $lib_path = compile_ok($C_CODE);
ok( $lib_path && -e $lib_path, 'Compiled a test shared library successfully' );
subtest 'Library Loading and Lifecycle' => sub {
note 'Testing load_library(), Affix::Lib objects, and reference counting.';
my $lib1 = load_library($lib_path);
isa_ok $lib1, ['Affix::Lib'], 'load_library returns an Affix::Lib object';
my $lib2 = load_library($lib_path);
is int $lib1, int $lib2, 'Loading the same library returns a handle to the same underlying object (singleton behavior)';
my $bad_lib = load_library('non_existent_library_12345.so');
is $bad_lib, undef, 'load_library returns undef for a non-existent library';
is get_last_error_message(), D(), 'get_last_error_message provides a useful error on failed load';
};
subtest 'Symbol Finding' => sub {
ok my $lib = load_library($lib_path), 'load_library returns a pointer';
ok my $symbol = find_symbol( $lib, 'just_something_to_export' ), 'find_symbol returns a pointer';
is find_symbol( $lib, 'non_existent_symbol_12345' ), U(), 'find_symbol returns undef for a non-existent symbol';
};
#
done_testing;
t/017_affix_build.t view on Meta::CPAN
return $bin if -x $bin && !-d $bin; # Check absolute
for my $dir ( File::Spec->path ) { # Check PATH
my $full = File::Spec->catfile( $dir, $bin );
return $full if -x $full && !-d $full;
if ( $^O eq 'MSWin32' ) {
return "$full.exe" if -x "$full.exe";
return "$full.cmd" if -x "$full.cmd";
return "$full.bat" if -x "$full.bat";
}
}
return undef;
}
sub check_dotnet () {
return 0 unless bin_path('dotnet');
my $out = `dotnet --list-sdks 2>&1`;
return ( $out =~ /^8\./m );
}
sub check_rust_gnu () {
return 0 unless bin_path('rustc');
t/018_sv_type.t view on Meta::CPAN
#~ $Config{useshrplib} eq 'true' || exit skip_all 'Cannot embed perl in a shared lib without building a shared libperl.';
eval {
# See https://metacpan.org/release/RJBS/perl-5.36.0/view/INSTALL#Building-a-shared-Perl-library
#
# Compile C Library 1 (Basic Operations)
my $cflags = ccopts(); #$Config{ccflags} . ' -I' . $Config{archlib} . '\CORE';
my $ldflags = '';
if ( $^O eq 'MSWin32' ) {
$ldflags .= ' "' . $Config{archlib} . '/CORE/' . $Config{libperl} . '"';
}
elsif ( $^O eq 'darwin' ) { # macOS/ARM64 requires ignoring undefined symbols from the host Perl
$ldflags .= ' -Wl,-undefined,dynamic_lookup';
}
else {
if ( $Config{useshrplib} && $Config{useshrplib} ne 'false' ) {
$ldflags .= '-L"' . $Config{archlib} . '/CORE" -l' . ( $Config{libperl} =~ s/^(?:lib)?([^.]+).*$/$1/r );
}
}
diag $cflags;
diag $ldflags;
my $lib = compile_ok( <<~'END', { cflags => $cflags, ldflags => $ldflags } );
#include "std.h"
//ext: .c
#undef warn
#include <EXTERN.h>
#include <perl.h>
#define NO_XSLOCKS
#include <XSUB.h>
// Takes an SV*, increments it if it's an integer
DLLEXPORT void inc_sv(SV* sv) { dTHX;
if (SvIOK(sv)) {
int val = SvIV(sv);
t/018_sv_type.t view on Meta::CPAN
is $res, 42, 'Received SV from C';
# Test within Callbacks
# Define a callback type that accepts and returns an SV*
typedef CallbackSV => Callback [ [ Pointer [SV] ] => Pointer [SV] ];
# We need a C function that takes this callback
my $lib2 = compile_ok( <<~'END', { cflags => $cflags, ldflags => $ldflags } );
#include "std.h"
//ext: .c
#undef warn
#include <EXTERN.h>
#include <perl.h>
#define NO_XSLOCKS
#include <XSUB.h>
// Define a C function pointer type that matches the signature:
// Pointer[SV] -> Pointer[SV] == SV* (*)(SV*)
typedef SV* (*cb_t)(SV*);
t/019_fileio.t view on Meta::CPAN
# Affix returns a Glob reference for files
is ref($fh), 'GLOB', 'Returned handle is a Glob reference';
my $line = <$fh>;
is $line, 'Content from C', 'Perl can read from the C-created FILE*';
# C-created tmpfiles usually disappear on close, simply ensure no crash
close $fh;
};
subtest 'Passing invalid handles' => sub {
# Passing undef/closed handle should result in NULL on C side
is c_is_null_file(undef), 1, 'Passing undef results in NULL FILE*';
}
};
subtest 'PerlIO* Streams (Affix::PerlIO)' => sub {
# Bind the identity function using PerlIO type
affix $lib, 'c_perlio_identity', [ Pointer [PerlIO] ] => Pointer [PerlIO];
# Test Roundtrip
# Note: PerlIO* handles are generally strictly tied to the Perl layer.
# When passed to C, we extract the PerlIO*, pass it, and wrap it in a new Glob on return.
t/019_fileio.t view on Meta::CPAN
# Pass filehandle to C to store in struct
init_logger( $logger, $fh );
# Verify via C function
log_message( $logger, 'First message' );
log_message( $logger, 'Second message' );
# Verify Perl side struct access
# Note: Pulling a File handle usually creates a new GLOB wrapper around the FILE*
# Since we own $fh, let's verify checking against undef works
my $logger_struct = cast( $logger, Logger() ); # View as struct
my $retrieved_fh = $logger_struct->{log_file};
ok $retrieved_fh, 'Retrieved filehandle from struct';
is ref($retrieved_fh), 'GLOB', 'It is a glob';
# Write from Perl using retrieved handle
# print {$retrieved_fh} "From Perl"; # Careful, might double-close if not careful
# Check file content
open my $check, '<', $filename;
my @lines = <$check>;
t/019_fileio.t view on Meta::CPAN
is $logger_hash->{counter}, 100, 'Counter is correct';
ok $logger_hash->{log_file}, 'Got filehandle back';
is ref( $logger_hash->{log_file} ), 'GLOB', 'It is a glob';
# Write using the returned handle to verify it works
# Note: $logger_hash->{log_file} wraps the same FILE* as $fh.
ok syswrite( $logger_hash->{log_file}, "Direct write from Perl" ), 'syswrite to the handle from Perl';
# To avoid double-close warnings, we let Perl handle cleanup of the glob
# but be careful about explicit closes.
undef $logger_hash;
# Check
open my $check, '<', $filename;
my $content = <$check>;
close $check;
is $content, "Direct write from Perl", 'Handle returned in struct is usable';
close $fh;
};
subtest 'File in Array' => sub {
my $lib2 = compile_ok(<<~'END_C2');
t/020_deep_types.t view on Meta::CPAN
};
subtest 'Unions, Arrays, and Recursive Linked Lists' => sub {
# Construct a linked list in Perl: Node1 -> Node2 -> Node3 -> NULL
# Node 3: Char type (value 10), Matrix diag (1, 1) = sum 12
my $node3 = {
id => 3,
type_flag => 2, # char
data => { as_char => 10 },
matrix => [ [ 1, 0 ], [ 0, 1 ] ],
next => undef
};
# Node 2: Double type (value 5.5), Matrix diag (2, 2) = sum 9.5
my $node2 = {
id => 2,
type_flag => 1, # double
data => { as_double => 5.5 },
matrix => [ [ 2, 0 ], [ 0, 2 ] ],
next => $node3 # Link to node 3
};
t/021_shakedown.t view on Meta::CPAN
is $r->{top_left}{x}, 5, 'Nested struct write-back (x)';
is $r->{top_left}{y}, 5, 'Nested struct write-back (y)';
like $r->{label}, qr/Moved/, 'Char array in struct write-back';
#
isa_ok my $mk_pt = wrap( $lib, 'return_struct_val', [ Int, Int ] => Point() ), ['Affix'];
my $p = $mk_pt->( 100, 200 );
is $p, { x => 100, y => 200 }, 'Struct returned by value';
};
subtest 'Recursive Data Structures (Linked List)' => sub {
isa_ok my $sum_nodes = wrap( $lib, 'sum_list', [ Pointer [ Node() ] ] => Int ), ['Affix'];
my $head = { value => 10, next => { value => 20, next => { value => 30, next => undef } } };
is $sum_nodes->($head), 60, 'Recursive linked list marshalled correctly';
};
#
done_testing;
t/022_stringlist.t view on Meta::CPAN
# Strip nulls for comparison
$buf =~ s/\0.*$//;
is $buf, 'HelloWorldfromAffix', 'Strings concatenated correctly';
};
subtest 'Return Value' => sub {
my $ret = get_static_list();
is $ret, [qw[Foo Bar Baz]], 'Received StringList from C';
};
subtest 'Edge Cases' => sub {
is count_args(undef), -1, 'Undef passed as NULL';
is count_args( [] ), 0, 'Empty array passed as empty list (contains only NULL terminator)';
};
done_testing;
t/025_affix_wrap.t view on Meta::CPAN
use blib;
use Affix::Wrap;
use Test2::Tools::Affix qw[:all];
use Test2::V0 -no_srand => 1;
use Path::Tiny;
use Capture::Tiny qw[capture];
$|++;
# Determine if Clang is available
my $CLANG_AVAIL = do {
my ( undef, undef, $exit ) = capture { system 'clang', '--version' };
$exit == 0;
};
sub spew_files ( $dir, %files ) {
$dir->child($_)->spew_utf8( $files{$_} ) for keys %files;
$dir;
}
sub run_tests_for_driver ( $driver_class, $label ) {
subtest 'Driver: ' . $label => sub {
t/025_affix_wrap.t view on Meta::CPAN
my ($calc) = grep { $_->name eq 'CALC_VAL' } @objs;
ok( $calc, 'Found CALC_VAL' );
# affix_type should quote expressions: '(10 + 20)' -> "'(10 + 20)'" or similar
like( $calc->affix_type, qr/'?\(10 \+ 20\)'?/, 'Expression quoted in affix_type' );
# Test bitwise OR resolution in wrap()
my $wrap = Affix::Wrap->new( driver => $parser );
my $target = "Test::Macro::" . $label;
$target =~ s/\W+/_/g;
$wrap->wrap( undef, $target );
is( $target->can('FLAGS_AB')->(), 3, 'FLAGS_AB resolved to 3' );
};
subtest 'Records (Structs & Unions)' => sub {
my $dir = Path::Tiny->tempdir;
spew_files(
$dir,
'structs.h' => <<'EOF',
/** @brief A Point */
typedef struct {
int x;
t/025_affix_wrap.t view on Meta::CPAN
);
my $parser = $driver_class->new( project_files => [ $dir->child('enums.h')->stringify ] );
my @objs = $parser->parse( $dir->child('main.c')->stringify, [ $dir->stringify ] );
my ($st) = grep { $_->name eq 'State' } @objs;
ok( $st, 'Found State enum' );
my $c = $st->underlying->constants;
is( $c->[0]{name}, 'IDLE', 'IDLE' );
is( $c->[1]{name}, 'RUNNING', 'RUNNING' );
is( $c->[1]{value}, 5, 'RUNNING=5' );
# STOPPED should be 6 (implicit) or undefined depending on driver logic,
# but current logic calculates it or leaves it to C.
# Let's check the affix_type string generation
my $sig = $st->affix_type;
like( $sig, qr/IDLE/, 'IDLE in sig' );
like( $sig, qr/RUNNING => 5/, 'RUNNING in sig' );
};
subtest 'Functions & Variables' => sub {
my $dir = Path::Tiny->tempdir;
spew_files(
$dir,
t/025_affix_wrap.t view on Meta::CPAN
my $pm_file = $dir->child('StaticLib.pm');
$binder->generate( 'dummy_lib', 'StaticLib', $pm_file->stringify );
ok -e $pm_file, 'Generated .pm file';
my $content = $pm_file->slurp_utf8;
like $content, qr/package\s+StaticLib\s*{/, 'Package decl';
like $content, qr/use constant STATIC_VAL => 42;/, 'Constant generated';
like $content, qr/typedef StaticStruct => Struct\[ x => Int \];/, 'Struct typedef generated';
like $content, qr/affix \$lib, ('static_func'|\[_static_func => 'static_func'\]) => \[Int\], Int;/, 'Function affix generated';
# Syntax check
my ( undef, undef, $exit ) = capture { system $^X, '-Ilib', '-c', $pm_file->stringify };
is $exit >> 8, 0, 'Generated code syntax check OK';
};
subtest 'Security: _generate_code injection prevention (C1)' => sub {
my $dir = Path::Tiny->tempdir;
spew_files(
$dir,
'simple.h' => <<'EOF',
int simple_func(int x);
EOF
'main.c' => '#include "simple.h"'
t/025_affix_wrap.t view on Meta::CPAN
ok -e $pm_file, 'Generated .pm file despite malicious lib';
my $content = $pm_file->slurp_utf8;
# Package declaration must be clean
like $content, qr/package\s+Safe::Lib\s*\{/, 'Package declaration is safe';
# The ] in the payload must be escaped inside q[...] so it doesn't break out
like $content, qr/q\[.*\\\].*\]/, 'Closing bracket escaped inside q[...]';
# The entire file must compile — proves the payload is inert
my ( undef, undef, $exit ) = capture { system $^X, '-Ilib', '-c', $pm_file->stringify };
is $exit >> 8, 0, 'Generated code compiles despite malicious lib';
};
# Malicious $pkg names must be rejected with a croak
subtest 'Malicious pkg names rejected' => sub {
my @bad_pkgs = (
[ 'Evil::pkg; system("echo PWNED")', 'semicolon injection' ],
[ 'Evil::pkg { system("echo PWNED") }', 'block injection' ],
[ '123bad', 'starts with digit' ],
[ 'Evil::pkg::', 'trailing ::' ],
t/025_affix_wrap.t view on Meta::CPAN
# $lib with backslashes (Windows paths) must be handled
subtest 'Windows-style lib paths' => sub {
my $win_lib = 'C:\Users\Test\lib.dll';
my $pm_file = $dir->child('winpath.pm');
lives { $binder->generate( $win_lib, 'WinPathTest', $pm_file->stringify ) }
or bail_out 'generate() died on Windows path';
my $content = $pm_file->slurp_utf8;
# Backslashes are doubled when escaped for q[...] (\\ -> \\\\)
like $content, qr/q\[.*C:\\\\Users\\\\Test\\\\lib\.dll\]/, 'Windows path safely quoted';
my ( undef, undef, $exit ) = capture { system $^X, '-Ilib', '-c', $pm_file->stringify };
is $exit >> 8, 0, 'Generated code compiles with Windows path';
};
# wrap() must also reject bad $pkg
subtest 'wrap() rejects malicious pkg' => sub {
ok dies { $binder->wrap( 'good_lib', 'Evil; system("echo PWNED")' ) }, 'wrap() rejects malicious pkg name';
};
};
};
}
t/026_context.t view on Meta::CPAN
# Convert void* back to Perl CodeRef
# Affix should now automatically unwrap the SV* from the Pointer[SV]
return $code_ref->($ctx_ref);
};
# Define Linear Logic
my $step3 = sub ($ctx) {
$ctx->{count}++;
pass 'Step 3 executed';
undef; # Finish
};
my $step2 = sub ($ctx) {
$ctx->{count}++;
pass 'Step 2 executed';
$step3;
};
my $step1 = sub ($ctx) {
$ctx->{count} = 1;
pass 'Step 1 executed';
$step2;
t/060_platform_unix_security.t view on Meta::CPAN
my @ret = eval { Affix::Platform::Unix::_findLib_gcc($evil) };
ok !@ret, "Malicious gcc input rejected safely: $evil";
}
# lib prefix is stripped
my @stripped = eval { Affix::Platform::Unix::_findLib_gcc('libfoo') };
is ref \@stripped, 'ARRAY', 'lib prefix stripped without error';
};
subtest '_get_soname: safe command execution (C4)' => sub {
# Nonexistent file returns undef
my $result = eval { Affix::Platform::Unix::_get_soname('/nonexistent/file.so') };
is $result, undef, '_get_soname returns undef for nonexistent file';
# undef input returns undef
$result = eval { Affix::Platform::Unix::_get_soname(undef) };
is $result, undef, '_get_soname returns undef for undef input';
# Empty string returns undef
$result = eval { Affix::Platform::Unix::_get_soname('') };
is $result, undef, '_get_soname returns undef for empty string';
# Malicious input must not execute shell commands
for my $evil ( '/tmp/fake; echo INJECTED', '/tmp/fake && touch /tmp/pwned', '/tmp/fake | cat /etc/passwd', '/tmp/fake $(id)', '/tmp/fake`id`', ) {
$result = eval { Affix::Platform::Unix::_get_soname($evil) };
is $result, undef, "Malicious soname input rejected safely: $evil";
}
};
subtest 'find_library: graceful handling' => sub {
# find_library with normal names must not die (returns undef on error)
my $result = eval { find_library('m') };
ok !defined $result || -f $result, 'find_library(m) returns undef or valid path';
$result = eval { find_library('nonexistent_lib_xyz_12345') };
is $result, undef, 'find_library returns undef for unknown lib';
# Malicious input must not execute shell commands
for my $evil ( 'm; echo INJECTED', 'm && touch /tmp/pwned', 'm | cat /etc/passwd', ) {
$result = eval { find_library($evil) };
is $result, undef, "Malicious find_library input rejected safely: $evil";
}
};
subtest 'is_elf: binary detection' => sub {
skip_all 'No /tmp on Windows' if $^O eq 'MSWin32';
# Create a fake ELF file
my $fake_elf = '/tmp/_test_fake_elf_' . $$;
open( my $fh, '>', $fake_elf ) or die "Cannot create temp file: $!";
print $fh "\x7fELF" . "\x00" x 20;
close $fh;
t/070_security_fixes.t view on Meta::CPAN
my $safe_name = 'm';
my $safe_regex = qr[-l\Q$safe_name\E\.[^\s]+.+\s*=>\s*(.+)$];
like '-lm.1 => /lib/libm.so.1', $safe_regex, 'Safe name matches ldconfig output format';
};
#
subtest 'H7/H8: Macro name validation prevents symbol table injection' => sub {
use Affix::Wrap;
# Valid macro
my $valid = Affix::Wrap::Macro->new( name => 'SAFE_CONST', value => '42' );
my $result = $valid->affix( undef, 'Test::H7Valid' );
ok defined $result, 'affix() returns for valid name';
# The generated constant should work via use constant
my $code = $valid->affix_type;
ok eval "package Test::H7Valid; $code; 1", 'Generated constant compiles' or diag "eval error: $@";
# Evil macro name — should NOT install into symbol table
my $evil = Affix::Wrap::Macro->new( name => 'EVIL; system("echo PWNED")', value => '1', );
$result = $evil->affix( undef, 'Test::H7Evil' );
ok defined $result, 'affix() returns for evil name (no crash)';
# The evil name must NOT be accessible as a subroutine in the target package
ok !defined $Test::H7Evil::{'EVIL; system("echo PWNED")'}, 'Evil name NOT installed in symbol table';
};
#
subtest 'H7/H8: Enum constant name validation' => sub {
use Affix qw[Enum];
my $type = Enum [ [ RED => 0 ], [ GREEN => 1 ], [ BLUE => 2 ], ];
ok defined $type, 'Enum type created';
t/075_error_negative.t view on Meta::CPAN
like dies { $fn->( 1, 2, 3 ) }, qr/too many|arg/i, 'Too many args dies';
};
#
subtest 'Wrong argument types' => sub {
my $fn = wrap( $lib, 'add_ints', [ Int, Int ], Int );
# Pass a string where int expected
my $result = $fn->( "hello", 1 );
isnt $result, 42, 'String arg does not produce expected numeric result';
# Pass undef where int expected (treated as 0 or NULL)
$result = $fn->( undef, 5 );
is $result, 5, 'undef as first arg treated as 0';
};
#
subtest 'NULL pointer handling' => sub {
my $get_null = wrap( $lib, 'return_null', [], Pointer [Int] );
my $null_ptr = $get_null->();
ok !defined $null_ptr, 'return_null returns undef';
my $read_ptr = wrap( $lib, 'read_ptr', [ Pointer [Int] ], Int );
# NULL pointer passed via FFI may resolve to 0
my $val = $read_ptr->($null_ptr);
ok defined $val, 'Reading from NULL pointer returns a value (does not crash)';
ok $val == -1 || $val == 0, 'NULL pointer read returns -1 or 0';
# Pass undef as pointer arg
$val = $read_ptr->(undef);
ok defined $val, 'undef pointer returns a value';
};
#
subtest 'wrap() on non-existent symbol' => sub {
my $fn = wrap( $lib, 'nonexistent_function_xyz', [Int], Int );
ok !defined $fn, 'wrap() returns undef for missing symbol';
};
#
subtest 'wrap() with malformed signatures' => sub {
# Empty args array is valid for void functions
my $fn = wrap( $lib, 'noop', [], Void );
ok defined $fn, 'Empty args array accepted for void function';
ok lives { $fn->() }, 'Void function with empty args runs';
# Non-arrayref args should die
( run in 2.293 seconds using v1.01-cache-2.11-cpan-d80b1682f3f )