view release on metacpan or  search on metacpan

t/007_pointers.t  view on Meta::CPAN

DLLEXPORT void c_free(void* p) { free(p); }

DLLEXPORT void set_int_deep(int*** ptr, int val) {
    if (ptr && *ptr && **ptr) {
        ***ptr = val;
    }
}

DLLEXPORT void* get_heap_int(int val) {
    int* p = (int*)malloc(sizeof(int));
    *p = val;
    return p;
}

DLLEXPORT void libc_free(void * ptr){ free(ptr); }
END_C
#
my $lib_path = compile_ok($C_CODE);
ok( $lib_path && -e $lib_path, 'Compiled a test shared library successfully' );
#
affix $lib_path, 'read_int_from_void_ptr', [ Pointer [Void] ], Int;
my $mem = malloc(8);

# Cast returns a new pin. We must assign it or use the returned object.
# Also, we keep $mem alive to ensure the memory isn't freed if $int_ptr assumes
# $mem owns it (though cast usually creates unmanaged aliases, so we need $mem to stay alive).
my $int_ptr = Affix::cast( $mem, Pointer [Int] );

# Test magical 'set' via dereferencing
# $$int_ptr is a scalar magic that writes to the address
$$int_ptr = 42;

# Use the original $mem pointer for reading (verifying they point to the same place)
is( read_int_from_void_ptr($mem), 42, 'Magical set via deref wrote to C memory' );

# Test cast again
my $long_ptr = Affix::cast( $mem, Pointer [LongLong] );
$$long_ptr = 1234567890123;
is $$long_ptr, 1234567890123, 'Magical get after casting to a new type works';

# Test realloc
my $r_ptr = calloc( 2, Int );

# realloc updates the pointer inside $r_ptr in-place.
Affix::realloc( $r_ptr, 32 );    # Reallocate to hold 8 ints

# But $r_ptr still thinks it's [2:int]. We must cast to update the type view.
my $arr_ptr = Affix::cast( $r_ptr, Array [ Int, 8 ] );

# Read the entire array from C into a Perl variable
my $array_values = $$arr_ptr;

# Modify perl's copy
$array_values->[0] = 10;
$array_values->[7] = 80;

# Write the entire modified array ref back to the C pointer
$$arr_ptr = $array_values;

# 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;
    is $deref->( \$int_var ), 60, 'Passing a scalar ref as an "in" pointer works';
    $modify->( \$int_var, 999 );
    is $int_var, 1000, 'C function correctly modified the value in our scalar ref ("out" param)';
};
subtest 'void*' => sub {
    isa_ok my $read_void = wrap( $lib_path, 'read_int_from_void_ptr', '(*void)->int32' ), ['Affix'];
    my $int_val = 12345;
    is $read_void->( \$int_val ), 12345, 'Correctly passed a scalar ref as a void* and read its value';
};
subtest 'char**' => sub {
    isa_ok my $check_ptr_ptr = wrap( $lib_path, 'check_string_ptr_ptr', '(**char)->int32' ), ['Affix'];
    my $string = 'perl';
    ok $check_ptr_ptr->( \$string ), 'Correctly passed a reference to a string as char**';
    is $string, 'C changed me', 'C function was able to modify the inner pointer';
};
subtest 'Struct Pointers (*@My::Struct)' => sub {
    ok typedef( 'My::Struct' => Struct [ id => SInt32, value => Float64, label => Pointer [Char] ] ), q[typedef('My::Struct' = ...)];
    isa_ok my $init_struct = wrap( $lib_path, 'init_struct', '(*@My::Struct, int32, float64, *char)->void' ), ['Affix'];
    my %struct_hash;
    $init_struct->( \%struct_hash, 101, 9.9, "Initialized" );
    is \%struct_hash, { id => 101, value => float(9.9), label => "Initialized" }, 'Correctly initialized a Perl hash via a struct pointer';
    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 Pin (Scalar Ref). Dereference it to check contents.
    is $$struct_ptr, { id => 99, value => float(-1.0), label => 'Global' }, 'Dereferencing a 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, Int ), 'calloc returns an array';