Affix
view release on metacpan or search on metacpan
### Changed
- `Array[Char]` function arguments now accept Perl strings directly, copying the string data into the temporary C array.
- `Affix::errno()` now returns a dualvar containing both the numeric error code (`errno`/`GetLastError`) and the system error string (`strerror`/`FormatMessage`).
### Fixed
- 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.
### `ptr_diff( $ptr1, $ptr2 )`
Returns the byte difference (`$ptr1 - $ptr2`) between two pointers as an integer.
### `is_null( $ptr )`
Returns true if the address is `NULL` (`0x0`).
### `strnlen( $ptr, $max )`
Safe string length calculation. Checks the pointer for a `NULL` terminator, scanning at most `$max` bytes.
# RAW MEMORY OPERATIONS
Affix exposes standard C memory operations for high-performance, raw 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.
- 2. **Structs:** Rust structs must be annotated with `#[repr(C)]` to guarantee their memory layout matches C (and thus Affix's `Struct`).
- 3. **Strings:** Rust strings are not null-terminated. You must receive `String` arguments as `*const std::os::raw::c_char` and convert them using `CStr::from_ptr`.
## Fortran
Fortran relies heavily on pass-by-reference.
- 1. **Pointers Everywhere:** Unless a parameter uses the modern Fortran `VALUE` attribute, you must pass everything as a pointer. If the function expects a Float, your Affix signature must be `Pointer[Float]`.
- 2. **Name Mangling:** Most Fortran compilers convert subroutine names to lowercase and append an underscore. A Fortran subroutine named `CALC_STRESS` will likely be exported as `calc_stress_`.
- 3. **Strings:** Fortran does not use null-terminated strings. When passing character arrays, Fortran compilers silently append hidden "length" parameters at the **end** of the argument list (passed by value as integers).
## Assembly
When writing raw Assembly (NASM/GAS), you must manually adhere to the calling convention of your target platform:
- **Linux/macOS (System V AMD64 ABI):** Arguments are passed in `rdi, rsi, rdx, rcx, r8, r9`, with the rest on the stack.
- **Windows (Microsoft x64):** Arguments are passed in `rcx, rdx, r8, r9`, with "shadow space" reserved on the stack.
## Go
Go libraries can be loaded if they are compiled with `-buildmode=c-shared`. Note that Go slices and strings contain
internal metadata (length/capacity) and do not map directly to C arrays or `char*`. Use the `C` package inside Go
(`import "C"`) and `*C.char` to bridge the boundary.
# ERROR HANDLING & DEBUGGING
Bridging two entirely different runtimes can lead to spectacular crashes if types or memory boundaries are mismatched.
Affix provides built-in tools to help you identify what went wrong.
## Error Handling
### `errno()`
say "Code 2 specifically triggered.";
}
}
```
**Note:** You must call `errno()` immediately after the C function invokes, as subsequent Perl operations (like
printing to STDOUT) might overwrite the system's error register.
## Memory Inspection
### `dump( $pin, $length_in_bytes )`
Prints a formatted hex dump of the memory pointed to by a Pin directly to `STDOUT`. This is an invaluable tool for
verifying that C structs or buffers contain the data you expect.
```perl
my $ptr = strdup("Affix Debugging");
dump($ptr, 16);
# Output:
# Dumping 16 bytes from 0x55E9A8A5 at script.pl line 42
infix/src/jit/executor.c view on Meta::CPAN
uint8_t OpInfo : 4;
} UNWIND_CODE;
typedef struct _UNWIND_INFO {
uint8_t Version : 3;
uint8_t Flags : 5;
uint8_t SizeOfPrologue;
uint8_t CountOfCodes;
uint8_t FrameRegister : 4;
uint8_t FrameOffset : 4;
UNWIND_CODE UnwindCode[1]; // Variable length array
} UNWIND_INFO;
// We reserve 512 bytes at the end of every JIT block for SEH metadata.
#define INFIX_SEH_METADATA_SIZE 256
#elif defined(INFIX_OS_WINDOWS) && defined(INFIX_ARCH_AARCH64)
#pragma pack(push, 1)
typedef struct _UNWIND_INFO_ARM64 {
uint32_t FunctionLength : 18;
uint32_t Version : 2;
uint32_t X : 1;
infix/src/jit/executor.c view on Meta::CPAN
uint8_t * eh = infix_malloc(total_size);
if (!eh)
return;
infix_memset(eh, 0, total_size);
uint8_t * p = eh;
// CIE (Common Information Entry)
*(uint32_t *)p = (uint32_t)(cie_size - 4);
p += 4; // length
*(uint32_t *)p = 0;
p += 4; // cie_id (0)
*p++ = 1; // version
*p++ = '\0'; // augmentation string ("")
*p++ = 4; // code_alignment_factor (AArch64 instructions are 4 bytes)
*p++ = 0x78; // data_alignment_factor (-8 in SLEB128)
*p++ = 30; // return_address_register (30 = lr on arm64)
// CIE Instructions: Initial state
// DW_CFA_def_cfa sp, 0
*p++ = 0x0c;
*p++ = 31;
*p++ = 0;
while ((size_t)(p - eh) < cie_size)
*p++ = 0;
// FDE (Frame Description Entry)
uint8_t * fde_start = eh + cie_size;
p = fde_start;
*(uint32_t *)p = (uint32_t)(fde_size - 4);
p += 4; // length
*(uint32_t *)p = (uint32_t)(p - eh);
p += 4; // cie_pointer (back-offset)
*(void **)p = exec->rx_ptr;
p += 8; // pc_begin (absolute)
*(uint64_t *)p = (uint64_t)exec->size;
p += 8; // pc_range (absolute)
*p++ = 0; // aug data len
// Instructions: match our trampoline prologue
infix/src/jit/trampoline.c view on Meta::CPAN
/**
* @internal
* @brief Appends data to a `code_buffer`, reallocating from its arena if necessary.
*
* @details If the buffer runs out of space, it doubles its capacity until the new data
* fits. All allocations happen within the temporary arena, so no manual `free` or
* `realloc` calls are needed; cleanup is automatic when the arena is destroyed.
*
* @param buf The code buffer.
* @param data A pointer to the data to append.
* @param len The length of the data in bytes.
*/
void code_buffer_append(code_buffer * buf, const void * data, size_t len) {
if (buf->error)
return;
if (len > SIZE_MAX - buf->size) { // Overflow check
buf->error = true;
_infix_set_error(INFIX_CATEGORY_ALLOCATION, INFIX_CODE_INTEGER_OVERFLOW, 0);
return;
}
if (buf->size + len > buf->capacity) {
lib/Affix.c view on Meta::CPAN
PERL_UNUSED_VAR(affix);
PERL_UNUSED_VAR(type);
wchar_t * wstr = *(wchar_t **)ptr;
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.
// +1 for null terminator.
SvGROW(sv, (wlen * sizeof(wchar_t)) + 1);
char * d = SvPVX(sv);
lib/Affix.c view on Meta::CPAN
}
static int Affix_cv_dup(pTHX_ MAGIC * mg, CLONE_PARAMS * param) {
Affix * old_affix = (Affix *)mg->mg_ptr;
Affix * new_affix;
Newxz(new_affix, 1, Affix);
//~ warn("Affix_cv_dup: old=%p -> new=%p", old_affix, new_affix);
/* Basic copy of metadata */
new_affix->num_args = old_affix->num_args;
new_affix->plan_length = old_affix->plan_length;
new_affix->total_args_size = old_affix->total_args_size;
new_affix->ret_opcode = old_affix->ret_opcode;
new_affix->num_out_params = old_affix->num_out_params;
new_affix->num_fixed_args = old_affix->num_fixed_args; // Copied too
/* Reconstruct strings */
if (old_affix->sig_str)
new_affix->sig_str = savepv(old_affix->sig_str);
if (old_affix->sym_name)
new_affix->sym_name = savepv(old_affix->sym_name);
lib/Affix.c view on Meta::CPAN
// Allocate arenas & SV
affix->args_arena = infix_arena_create(4096);
affix->ret_arena = infix_arena_create(1024);
affix->return_sv = newSV(0);
if (affix->num_args > 0)
Newx(affix->c_args, affix->num_args, void *);
affix->variadic_cache = newHV();
// Rebuild plan
Newxz(affix->plan, affix->plan_length + 1, Affix_Plan_Step);
size_t out_param_count = 0;
OutParamInfo * temp_out_info = safemalloc(sizeof(OutParamInfo) * (affix->num_args > 0 ? affix->num_args : 1));
size_t current_offset = 0;
for (size_t i = 0; i < affix->num_args; ++i) {
// Deep copy types from parse_arena to persistent args_arena
const infix_type * original_type = _copy_type_graph_to_arena(affix->args_arena, args[i].type);
// Recalculate offsets (logic duplication from Affix_affix, but necessary)
lib/Affix.c view on Meta::CPAN
if (affix->num_args > 0)
Newx(affix->c_args, affix->num_args, void *);
else
affix->c_args = nullptr;
affix->args_arena = infix_arena_create(4096);
affix->ret_arena = infix_arena_create(1024);
// Build execution plan
affix->plan_length = affix->num_args;
Newxz(affix->plan, affix->plan_length + 1, Affix_Plan_Step);
size_t current_offset = 0;
size_t out_param_count = 0;
OutParamInfo * temp_out_info = safemalloc(sizeof(OutParamInfo) * (affix->num_args > 0 ? affix->num_args : 1));
for (size_t i = 0; i < affix->num_args; ++i) {
// Deep copy from temporary parse_arena to persistent args_arena.
// We use the ORIGINAL types (args[i].type) so marshalling knows it's an Array.
const infix_type * original_type = _copy_type_graph_to_arena(affix->args_arena, args[i].type);
lib/Affix.c view on Meta::CPAN
// This satisfies typical C-string in struct usage (padded with nulls)
// AND binary usage where nulls are embedded (as long as not trailing).
size_t len = type->meta.array_info.num_elements;
const char * ptr = (const char *)p;
while (len > 0 && ptr[len - 1] == '\0')
len--;
sv_setpvn(sv, ptr, len);
return;
}
if (element_type->meta.primitive_id == INFIX_PRIMITIVE_UINT8) {
// uchar[] / uint8[]: Treat as raw binary blob, read full length.
sv_setpvn(sv, (const char *)p, type->meta.array_info.num_elements);
return;
}
}
// Standard array handling (ArrayRef of values)
AV * av;
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) {
av = (AV *)SvRV(sv);
av_clear(av);
lib/Affix.c view on Meta::CPAN
#endif
ST(0) = sv_2mortal(dual);
XSRETURN(1);
}
XS_INTERNAL(Affix_dump) {
dVAR;
dXSARGS;
if (items != 2)
croak_xs_usage(cv, "scalar, length_in_bytes");
Affix_Pin * pin = _get_pin_from_sv(aTHX_ ST(0));
if (!pin) {
warn("scalar is not a valid pointer");
XSRETURN_EMPTY;
}
if (!pin->pointer) {
warn("Cannot dump a nullptr pointer");
XSRETURN_EMPTY;
}
UV length = SvUV(ST(1));
if (length == 0) {
warn("Dump length cannot be zero");
XSRETURN_EMPTY;
}
// PL_curcop may be nullptr during thread destruction or callbacks?
const char * file = "Unknown";
int line = 0;
if (LIKELY(PL_curcop)) {
file = OutCopFILE(PL_curcop);
line = CopLINE(PL_curcop);
}
_DumpHex(aTHX_ pin->pointer, length, file, line);
ST(0) = ST(0);
XSRETURN(1);
}
static void * _resolve_writable_ptr(pTHX_ SV * sv) {
if (is_pin(aTHX_ sv)) {
Affix_Pin * p = _get_pin_from_sv(aTHX_ sv);
return p ? p->pointer : nullptr;
}
if (SvIOK(sv))
lib/Affix.h view on Meta::CPAN
/// Represents a forward FFI call (a Perl sub that calls a C function).
/// This struct holds the pre-compiled execution plan and is attached to the generated XS subroutine.
struct Affix {
infix_forward_t * infix; ///< Handle to the infix trampoline and type info.
infix_arena_t * args_arena; ///< Fast memory allocator for arguments during a call.
infix_arena_t * ret_arena; ///< Fast memory allocator for return value during a call.
infix_cif_func cif; ///< A direct function pointer to the JIT-compiled trampoline code.
infix_library_t * lib_handle; ///< If affix() loaded a library itself, stores the handle for cleanup.
SV * return_sv; ///< Pre-allocated, reusable SV to hold the return value.
Affix_Plan_Step * plan; ///< The linear array of operations (the "execution plan").
size_t plan_length; ///< The total number of steps in the plan.
size_t num_args; ///< Cached number of arguments for faster access.
size_t total_args_size; ///< Pre-calculated total size of the C arguments buffer.
// Pre-compiled plan for handling "out" parameters after the C call.
OutParamInfo * out_param_info;
size_t num_out_params;
const infix_type * ret_type;
const infix_type * unwrapped_ret_type; // Pre-unwrapped for OP_RET_PTR
Affix_Pull ret_pull_handler; ///< Cached handler for marshalling the return value.
Affix_Opcode ret_opcode; ///< Optimized return opcode.
void ** c_args;
lib/Affix.pod view on Meta::CPAN
=head3 C<ptr_diff( $ptr1, $ptr2 )>
Returns the byte difference (C<$ptr1 - $ptr2>) between two pointers as an integer.
=head3 C<is_null( $ptr )>
Returns true if the address is C<NULL> (C<0x0>).
=head3 C<strnlen( $ptr, $max )>
Safe string length calculation. Checks the pointer for a C<NULL> terminator, scanning at most C<$max> bytes.
=head1 RAW MEMORY OPERATIONS
Affix exposes standard C memory operations for high-performance, raw byte manipulation. These functions accept either
Pins or raw integer addresses.
=over
=item * C<memcpy( $dest, $src, $bytes )>: Copies exactly C<$bytes> from C<$src> to C<$dest>.
lib/Affix.pod view on Meta::CPAN
=head2 Fortran
Fortran relies heavily on pass-by-reference.
=over
=item 1. B<Pointers Everywhere:> Unless a parameter uses the modern Fortran C<VALUE> attribute, you must pass everything as a pointer. If the function expects a Float, your Affix signature must be C<Pointer[Float]>.
=item 2. B<Name Mangling:> Most Fortran compilers convert subroutine names to lowercase and append an underscore. A Fortran subroutine named C<CALC_STRESS> will likely be exported as C<calc_stress_>.
=item 3. B<Strings:> Fortran does not use null-terminated strings. When passing character arrays, Fortran compilers silently append hidden "length" parameters at the B<end> of the argument list (passed by value as integers).
=back
=head2 Assembly
When writing raw Assembly (NASM/GAS), you must manually adhere to the calling convention of your target platform:
=over
=item * B<Linux/macOS (System V AMD64 ABI):> Arguments are passed in C<rdi, rsi, rdx, rcx, r8, r9>, with the rest on the stack.
=item * B<Windows (Microsoft x64):> Arguments are passed in C<rcx, rdx, r8, r9>, with "shadow space" reserved on the stack.
=back
=head2 Go
Go libraries can be loaded if they are compiled with C<-buildmode=c-shared>. Note that Go slices and strings contain
internal metadata (length/capacity) and do not map directly to C arrays or C<char*>. Use the C<C> package inside Go
(C<import "C">) and C<*C.char> to bridge the boundary.
=head1 ERROR HANDLING & DEBUGGING
Bridging two entirely different runtimes can lead to spectacular crashes if types or memory boundaries are mismatched.
Affix provides built-in tools to help you identify what went wrong.
=head2 Error Handling
=head3 C<errno()>
lib/Affix.pod view on Meta::CPAN
if (int($err) == 2) {
say "Code 2 specifically triggered.";
}
}
B<Note:> You must call C<errno()> immediately after the C function invokes, as subsequent Perl operations (like
printing to STDOUT) might overwrite the system's error register.
=head2 Memory Inspection
=head3 C<dump( $pin, $length_in_bytes )>
Prints a formatted hex dump of the memory pointed to by a Pin directly to C<STDOUT>. This is an invaluable tool for
verifying that C structs or buffers contain the data you expect.
my $ptr = strdup("Affix Debugging");
dump($ptr, 16);
# Output:
# Dumping 16 bytes from 0x55E9A8A5 at script.pl line 42
# 000 41 66 66 69 78 20 44 65 62 75 67 67 69 6e 67 00 | Affix Debugging.
lib/Affix/Build.pm view on Meta::CPAN
# Standard convention: Windows DLLs don't need 'lib' prefix, Unix SOs do.
my $prefix = ( $os eq 'MSWin32' || $name =~ /^lib/ ) ? '' : 'lib';
my $suffix = defined $version ? ".$version" : '';
$libname = $build_dir->child("$prefix$name.$so_ext$suffix")->absolute;
# We prefer C++ drivers (g++, clang++) to handle standard libraries for mixed code (C+Rust, C+C++)
$linker = $self->_can_run(qw[g++ clang++ c++ icpx]) || $self->_can_run(qw[cc gcc clang icx cl]) || 'c++';
# Parse global flags...
@cflags = map { chomp; $_ } grep { defined && length } Text::ParseWords::parse_line( q/ /, 1, $flags->{cflags} // '' );
@cxxflags = map { chomp; $_ } grep { defined && length } Text::ParseWords::parse_line( q/ /, 1, $flags->{cxxflags} // '' );
@ldflags = map { chomp; $_ } grep { defined && length } Text::ParseWords::parse_line( q/ /, 1, $flags->{ldflags} // '' );
}
method add ( $input, %args ) {
$_lib = (); # Reset cached library handle
my ( $path, $lang );
if ( ref $input eq 'SCALAR' ) { # Inline source code
$args{lang} // croak q[Parameter 'lang' (extension) is required for inline source];
$lang = lc $args{lang};
# Generate a unique filename in the build dir
lib/Affix/Wrap.pm view on Meta::CPAN
}
method affix {
Callback [ [ map { $_->affix } @$params ], $ret->affix ];
}
};
class #
Affix::Wrap::Argument {
field $type : reader : param;
field $name : reader : param //= '';
method to_string { length($name) ? $type->to_string . ' ' . $name : $type->to_string }
use overload '""' => 'to_string', fallback => 1;
method affix_type { $type->affix_type }
method affix { $type->affix }
}
class #
Affix::Wrap::Entity {
field $name : reader : param //= '';
field $doc : reader : param //= ();
field $file : reader : param //= '';
field $line : reader : param //= 0;
lib/Affix/Wrap.pm view on Meta::CPAN
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;
$current_tag = 'param';
}
elsif ( $line =~ /^[@\\]returns?\s+(.*)/ ) {
lib/Affix/Wrap.pm view on Meta::CPAN
}
elsif ( $line =~ /^[@\\](\w+)\s*(.*)/ ) {
my $tag = ucfirst($1);
$data->{desc} .= "\n\nB<$tag:> $2";
$current_tag = 'desc';
}
else {
if ( $current_tag eq 'brief' ) { $data->{brief} .= ' ' . $line; }
elsif ( $current_tag eq 'param' && defined $current_param ) { $data->{params}{$current_param} .= ' ' . $line; }
elsif ( $current_tag eq 'return' ) { $data->{return} .= ' ' . $line; }
else { $data->{desc} .= ( length( $data->{desc} ) ? "\n" : '' ) . $line; }
}
}
if ( length( $data->{brief} ) == 0 && length( $data->{desc} ) > 0 ) {
if ( $data->{desc} =~ s/^(.+?\.)\s+//s ) { $data->{brief} = $1; }
}
return $doc_data = $data;
}
method pod {
my $d = $self->parse_doc;
my $out = '=head2 ' . $self->name . "\n\n";
$out .= $self->_format_pod( $d->{brief} ) . "\n\n" if length $d->{brief};
$out .= $self->_format_pod( $d->{desc} ) . "\n\n" if length $d->{desc};
# Format parameters
if ( keys %{ $d->{params} } ) {
$out .= "=over\n\n";
my @param_names = sort keys %{ $d->{params} };
# If we have args metadata (e.g. Function), use it for ordering
if ( $self->can('args') && ref( $self->args ) eq 'ARRAY' ) {
@param_names = map { $_->name } grep { exists $d->{params}{ $_->name } } @{ $self->args };
lib/Affix/Wrap.pm view on Meta::CPAN
my %seen = map { $_ => 1 } @param_names;
push @param_names, grep { !$seen{$_} } sort keys %{ $d->{params} };
}
for my $name (@param_names) {
$out .= "=item C<$name>\n\n" . $self->_format_pod( $d->{params}{$name} ) . "\n\n";
}
$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 //= '';
lib/Affix/Wrap.pm view on Meta::CPAN
}
class #
Affix::Wrap::Macro : isa(Affix::Wrap::Entity) {
field $value : reader : param //= ();
method set_value ($v) { $value = $v }
method affix_type {
$value // return '';
my $v = $value // '';
$v =~ s/^\s+|\s+$//g;
return '' unless length $v;
if ( $v =~ /^-?(?:0x[\da-fA-F]+|\d+(?:\.\d+)?)$/ ) {
return sprintf 'use constant %s => %s', $self->name, $v;
}
if ( $v =~ /^".*"$/ || $v =~ /^'.*'$/ ) {
return sprintf 'use constant %s => %s', $self->name, $v;
}
$v =~ s/'/\\'/g;
sprintf 'use constant %s => \'%s\'', $self->name, $v;
}
method affix ( $lib //= (), $pkg //= () ) {
if ( $pkg && defined $value && length $value ) {
my $val = $value;
if ( $val =~ /^"(.*)"$/ || $val =~ /^'(.*)'$/ ) { $val = $1; }
no strict 'refs';
no warnings 'redefine';
*{ "${pkg}::" . $self->name } = sub () {$val};
}
sub () {$value};
}
} class Affix::Wrap::Variable : isa(Affix::Wrap::Entity) {
field $type : reader : param;
lib/Affix/Wrap.pm view on Meta::CPAN
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 {
my %seen_dirs;
for my $f (@$project_files) {
next unless defined $f && length $f;
my $abs = $self->_normalize($f);
next unless length $abs;
$allowed_files->{$abs} = 1;
my $dir = Path::Tiny::path($abs)->parent->stringify;
$dir =~ s{\\}{/}g;
unless ( $seen_dirs{$dir}++ ) { push @$project_dirs, $dir; }
}
}
method parse ( $entry_point, $include_dirs //= [] ) {
if ( !defined $entry_point || !length $entry_point ) {
($entry_point) = grep { defined $_ && length $_ } @$project_files;
}
return () unless defined $entry_point && length $entry_point;
my $ep_abs = $self->_normalize($entry_point);
return () unless length $ep_abs;
$allowed_files->{$ep_abs} = 1;
$last_seen_file = $ep_abs;
my $ep_dir = Path::Tiny::path($ep_abs)->parent->stringify;
$ep_dir =~ s{\\}{/}g;
my $found = 0;
for my $pd (@$project_dirs) {
if ( $ep_dir eq $pd ) { $found = 1; last; }
}
push @$project_dirs, $ep_dir unless $found;
lib/Affix/Wrap.pm view on Meta::CPAN
return;
}
elsif ( $kind eq 'BuiltinType' ) { return; }
}
if ( $node->{inner} ) {
for ( @{ $node->{inner} } ) { $self->_walk( $_, $acc, $current_file ); }
}
}
method _is_valid_file ($f) {
return 0 unless defined $f && length $f;
return 0 if $f =~ m{^/usr/(include|lib|share|local/include)};
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; }
return 0;
}
method _get_node_file($node) {
my $loc = $node->{loc};
return undef unless $loc;
lib/Affix/Wrap.pm view on Meta::CPAN
if ( $n->{range}{end} ) {
$end_line = $n->{range}{end}{presumedLoc}{line} || $n->{range}{end}{line} || $n->{range}{end}{expansionLoc}{line} || $line;
}
else { $end_line = $line; }
return ( $s, $e, $line, $end_line );
}
method _doc_w_trail( $f, $s, $e ) {
my $d = $self->_extract_doc( $f, $s );
my $t = $self->_extract_trailing( $f, $e );
return $d unless defined $t && length $t;
return $t unless defined $d && length $d;
return "$d\n$t";
}
method _macro( $n, $acc, $f ) {
my ( $s, $e, $l, $el ) = $self->_meta($n);
my $val = $self->_extract_macro_val( $n, $f );
push @$acc,
Affix::Wrap::Macro->new(
name => $n->{name},
file => $f,
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;
lib/Affix/Wrap.pm view on Meta::CPAN
$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 ) {
return '' unless defined $off;
my $content = $self->_get_content($f);
return '' unless length($content);
my $post = substr( $content, $off );
my ($line) = split /\R/, $post, 2;
return '' unless defined $line;
if ( $line =~ /\/\/(.*)$/ ) {
my $c = $1;
$c =~ s/^\s+|\s+$//g;
return $c;
}
return '';
}
method _extract_raw( $f, $s, $e ) {
return '' unless defined $s && defined $e;
my $content = $self->_get_content($f);
return '' unless length($content) >= $e;
return substr( $content, $s, $e - $s );
}
method _extract_macro_val( $n, $f ) {
my $off = $n->{range}{begin}{offset};
return '' unless defined $off;
my $content = $self->_get_content($f);
return '' unless length($content);
my $r = substr( $content, $off );
if ( $r =~ /^(.*?)$/m ) {
my $line = $1;
my $name = $n->{name};
if ( $line =~ /#\s*define\s+\Q$name\E\s+(.*)/ ) {
my $v = $1;
$v =~ s/\/\/.*$//;
$v =~ s/\/\*.*?\*\///g;
$v =~ s/^\s+|\s+$//g;
return $v;
lib/Affix/Wrap.pm view on Meta::CPAN
}
}
@$objs = grep { !$_->is_merged } @$objs;
}
method _wrap_named_types($objs) {
for ( my $i = 0; $i < @$objs; $i++ ) {
my $node = $objs->[$i];
next if $node->is_merged;
if ( ( ref($node) eq 'Affix::Wrap::Struct' || ref($node) eq 'Affix::Wrap::Enum' ) &&
length( $node->name ) &&
$node->name ne '(anonymous)' ) {
# If there's already a typedef for this name, skip it
next if grep { $_ isa Affix::Wrap::Typedef && $_->name eq $node->name } @$objs;
my $new = Affix::Wrap::Typedef->new(
name => $node->name,
underlying => $node,
file => $node->file,
line => $node->line,
end_line => $node->end_line,
lib/Affix/Wrap.pm view on Meta::CPAN
$out =~ s/\s+//g if $out;
return $out // "$arch-unknown-unknown";
}
}
class #
Affix::Wrap::Driver::Regex {
field $project_files : param : reader;
field $file_cache = {};
method _normalize ($path) {
return '' unless defined $path && length $path;
my $abs = Path::Tiny::path($path)->absolute->stringify;
$abs =~ s{\\}{/}g;
return $abs;
}
method _is_valid_file ($f) {
return 0 unless defined $f && length $f;
return $f !~ m{^/usr/(include|lib|share|local/include)} &&
$f !~ m{^/System/Library} &&
$f !~ m{(Program Files|Strawberry|MinGW|Windows|cygwin|msys)}i;
}
method parse( $entry_point, $ids //= [] ) {
my @objs;
for my $f (@$project_files) {
my $abs = $self->_normalize($f);
next unless length $abs;
next unless $self->_is_valid_file($abs);
if ( $f =~ /\.h(pp|xx)?$/i ) { $self->_scan( $f, \@objs ); $self->_scan_funcs( $f, \@objs ); }
else { $self->_scan_funcs( $f, \@objs ); }
}
@objs = sort { ( $a->file cmp $b->file ) || ( $a->start_offset <=> $b->start_offset ) } @objs;
@objs;
}
method _read($f) {
my $abs = $self->_normalize($f);
lib/Affix/Wrap.pm view on Meta::CPAN
# Strip likely API macros (uppercase words) from the type definition
$type_str =~ s/\b[A-Z_][A-Z0-9_]*\b//g;
$type_str =~ s/^\s+|\s+$//g;
# Handle array syntax: "int vars[10]" -> type="int[10]", name="vars"
if ( $name =~ s/(\[.*\])$// ) { $type_str .= $1; }
# Merge standard preceding doc with captured trailing doc
my $doc = $self->_doc( $c, $s );
if ( defined $trail && length $trail ) {
$trail =~ s/^\s+|\s+$//g;
$doc = defined $doc ? "$doc\n$trail" : $trail;
}
push @$acc,
Affix::Wrap::Variable->new(
name => $name,
type => Affix::Wrap::Type->parse($type_str),
file => $f,
line => $self->_ln( $c, $s ),
end_line => $self->_ln( $c, $e ),
lib/Affix/Wrap.pm view on Meta::CPAN
while ( $c =~ /typedef\s+(?!struct\s*(?:\w+\s*)?\{|enum\s*(?:\w+\s*)?\{)(.+?)\s*;/gs ) {
my $content = $1;
my $s = $-[0];
my $e = $+[0];
$content =~ s/\s+/ /g;
$content =~ s/^\s+|\s+$//g;
if ( $content =~ /^(.+?)\s*\(\*\s*(\w+)\)\s*\((.*?)\)$/ ) {
my ( $ret_str, $name, $args_str ) = ( $1, $2, $3 );
my $ret = Affix::Wrap::Type->parse($ret_str);
my @args;
if ( defined $args_str && length $args_str && $args_str ne 'void' ) {
my @args_raw = grep {length} map { s/^\s+|\s+$//g; $_ } split /,(?![^(]*\))/, $args_str;
if ( @args_raw == 1 && $args_raw[0] =~ /^void$/ ) { @args_raw = (); }
for my $raw (@args_raw) {
if ( $raw =~ /^(.+?)([\s\*]+)([a-zA-Z_]\w*(?:\[.*?\])?)$/ ) {
my ( $t, $sep, $n ) = ( $1, $2, $3 );
$t .= $sep;
if ( $n =~ s/(\[.*\])$// ) { $t .= $1 }
push @args, Affix::Wrap::Type->parse($t);
}
else {
push @args, Affix::Wrap::Type->parse($raw);
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;
}
lib/Affix/Wrap.pm view on Meta::CPAN
next if $2 =~ /^(if|while|for|return|switch|typedef)$/ || $1 =~ /static/;
my $s = $-[0];
my $e = $+[0];
my ( $ret_str, $func_name, $args_str ) = ( $1, $2, substr( $3, 1, -1 ) );
#
$ret_str =~ s/\b[A-Z_][A-Z0-9_]*\b//g;
$ret_str =~ s/^\s+|\s+$//g;
my $ret_obj = Affix::Wrap::Type->parse($ret_str);
# Split args respecting commas inside parentheses (function pointers, etc.)
my @args_raw = grep {length} map { s/^\s+|\s+$//g; $_ } split /,(?![^(]*\))/, $args_str;
if ( @args_raw == 1 && $args_raw[0] =~ /^void$/ ) { @args_raw = (); }
my @args;
for my $raw (@args_raw) {
if ( $raw =~ /^(.+?)\s*\(\*\s*(\w+)\)\s*\((.*)\)$/ ) {
my ( $r_type, $cb_name, $cb_args ) = ( $1, $2, $3 );
my $ret = Affix::Wrap::Type->parse($r_type);
my @p;
if ( $cb_args ne '' && $cb_args ne 'void' ) {
@p = map { Affix::Wrap::Type->parse($_) } split /,(?![^(]*\))/, $cb_args;
}
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 = '';
next;
}
lib/Test2/Tools/Affix.pm view on Meta::CPAN
sub {
system('valgrind --version');
}
);
plan skip_all 'Valgrind is not installed' if $exit_code;
diag 'Valgrind v', ( $stdout =~ m/valgrind-(.+)$/ ), ' found';
diag 'Generating suppressions...';
my @cmd = (
qw[valgrind --leak-check=full --show-reachable=yes --error-limit=no
--gen-suppressions=all --log-fd=1], $^X, '-e',
sprintf <<'', ( join ', ', map {"'$_'"} sort { length $a <=> length $b } map { path($_)->absolute->canonpath } @INC ) );
use strict;
use warnings;
use lib %s;
use Affix;
no Test2::Plugin::ExitSummary;
use Test2::V0;
pass "generate valgrind suppressions";
done_testing;
lib/Test2/Tools/Affix.pm view on Meta::CPAN
}
# 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]);
my ( $package, $file, $line ) = caller;
my $source = sprintf
<<'', ( join ', ', map {"'$_'"} sort { length $a <=> length $b } grep {defined} map { my $dir = path($_); $dir->exists ? $dir->absolute->realpath : () } @INC, 't/lib' ), Test2::API::test2_stack()->top->{count}, $deparse->coderef2text(...
use lib %s;
use Test2::V0 -no_srand => 1, '!subtest';
use Test2::Util::Importer 'Test2::Tools::Subtest' => ( subtest_streamed => { -as => 'subtest' } );
use Test2::Plugin::UTF8;
no Test2::Plugin::ExitSummary; # I wish
use Test2::Tools::Affix;
# Test2::API::test2_stack()->top->{count} = %d;
$|++;
my $exit = sub {use Affix; Affix::set_destruct_level(3); %s;}->();
# Test2::API::test2_stack()->top->{count}++;
t/007_pointers.t view on Meta::CPAN
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, Int ), 'calloc returns an array';
#~ diag Affix::dump( $array_ptr, 32 );
ok $array_ptr, 'calloc returns an Affix::Pointer object';
is sum_int_array( $array_ptr, 4 ), 0, 'Memory from calloc is zero-initialized';
ok free($array_ptr), 'Explicitly calling free() returns true';
# Note: Double-free would crash, so we assume it worked.
like( warning { free( find_symbol( load_library($lib_path), 'sum_int_array' ) ) },
t/007_pointers.t view on Meta::CPAN
my $arr = cast( $buf, Array [ Int, 10 ] );
is $$arr->[2], 999, 'ptr_add moved to index 2 correctly';
free($buf);
};
subtest 'strdup and strnlen' => sub {
my $str = "Hello World";
my $dup = strdup($str);
ok !is_null($dup), 'strdup returned non-null';
is cast( $dup, String ), $str, 'strdup content matches';
is strnlen( $dup, 5 ), 5, 'strnlen capped at max';
is strnlen( $dup, 100 ), 11, 'strnlen found true length';
# Ensure it's managed memory that we can free
ok free($dup), 'free(dup) worked';
};
};
subtest 'return malloc\'d pointer' => sub {
ok affix( $lib_path, 'test', [] => Pointer [Void] ), 'affix test()';
# We MUST bind C's free, because Affix::free uses Perl's allocator.
# Mixing them causes crashes on Windows.
t/014_array.t view on Meta::CPAN
#
isa_ok my $sum_arr = wrap( $lib_path, 'sum_array_static', [ Array [ Int, 5 ] ] => Int ), ['Affix'];
is $sum_arr->( [ 1, 2, 3, 4, 5 ] ), 15, 'Fixed size array passed by value';
#
subtest 'Fixed Array Binary Safety' => sub {
my $ptr = calloc( 5, Int8 ); # Allocate 5 bytes
my $mem = cast( $ptr, Array [ Int8, 5 ] ); # Write: "A \0 B \0 C"
$$mem = [ 65, 0, 66, 0, 67 ]; # We can write using an array ref (slow path, verify write works)
my $view = cast( $ptr, Array [ Char, 5 ] ); # Now read it back as a char array (fast path)
my $data = $$view;
is length($data), 5, 'Binary string has correct length (5)';
is $data, "A\0B\0C", 'Binary content preserved (nulls included)';
free($ptr);
};
done_testing;
t/040_error.t view on Meta::CPAN
is $ret, -1, 'remove() returned -1 for missing file';
# Check the system error
my $err = errno();
# On POSIX, removing a missing file is ENOENT (2).
# On Windows, it is typically ERROR_FILE_NOT_FOUND (2).
ok int($err) > 0, 'Got positive numeric error code: ' . int($err);
#
diag $err;
ok length("$err") > 0, "Got error message string: '$err'";
like "$err", qr/\w/, 'Error message contains text';
#
is $err + 0, int($err), 'Scalar acts as number in numeric context';
is $err . "", "$err", 'Scalar acts as string in string context';
#
done_testing;
( run in 2.886 seconds using v1.01-cache-2.11-cpan-8f98c5d2c55 )