view release on metacpan or  search on metacpan

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

    #~ 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' ) ) },
        qr/unmanaged/, 'free() croaks when called on an unmanaged pointer' );

    # Test that auto-freeing via garbage collection doesn't crash
    subtest 'GC of managed pointers' => sub {
        ok my $scoped_ptr = malloc(16), 'malloc(16)';

        #~ ok cast( $scoped_ptr, '*int'), 'cast void pointer to int pointer';
        #substr $$scoped_ptr, 0, 1, 'a';
        #~ diag '[' . ($$scoped_ptr) . ']';
        my $values = $$scoped_ptr;
        substr( $values, 4 ) = 'hi';
        $$scoped_ptr = $values;

        #~ Affix::dump( $scoped_ptr, 32 );
        #~ diag '[' . ($$scoped_ptr) . ']';
        # When $scoped_ptr goes out of scope here, its DESTROY method is called.
    };
    pass('Managed pointer went out of scope without crashing');
};
subtest 'Pointer Arithmetic and String Utils' => sub {
    imported_ok qw[ptr_add ptr_diff strdup strnlen is_null];
    subtest 'ptr_add and ptr_diff' => sub {
        my $buf = calloc( 10, Int );    # 40 bytes
        ok !is_null($buf), 'buffer is not null';
        my $p2 = ptr_add( $buf, 8 );    # width of 2 ints
        is ptr_diff( $p2,  $buf ),  8, 'ptr_diff calculates 8 bytes';
        is ptr_diff( $buf, $p2 ),  -8, 'ptr_diff calculates -8 bytes';
        $$p2 = 999;                     # Write to offset

        # Verify via original array pointer
        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.
    ok affix( $lib_path, 'c_free', [ Pointer [Void] ] => Void ), 'affix c_free()';
    ok my $string = test(),                                      'test()';
    is Affix::cast( $string, String ), 'Testing', 'read C string';

    # Correct cleanup: Use the allocator that created it.
    c_free($string);
    pass('freed via c_free');
};
subtest 'deep pointers' => sub {

    # Deep Indirection (***int)
    isa_ok my $set_deep = wrap( $lib_path, 'set_int_deep', [ Pointer [ Pointer [ Pointer [Int] ] ], Int ] => Void ), ['Affix'];

    # Manually construct the pointer chain with correct types
    # Keep original 'malloc' pointers alive (managed) while using 'cast' aliases
    # Layer 1: The int value (int*)
    my $p_mem = malloc(8);
    my $p_val = Affix::cast( $p_mem, Pointer [Int] );

    # Assigning directly ($p_val = 0) would overwrite the magic scalar with a normal SV*
    $$p_val = 0;

    # Layer 2: Pointer to Layer 1 (int**)
    my $pp_mem = malloc(8);
    my $pp_val = Affix::cast( $pp_mem, Pointer [ Pointer [Int] ] );
    $$pp_val = $p_val;    # Writes address of $p_mem into $pp_mem

    # Layer 3: Pointer to Layer 2 (int***)
    my $ppp_mem = malloc(8);
    my $ppp_val = Affix::cast( $ppp_mem, Pointer [ Pointer [ Pointer [Int] ] ] );

    # Dereference to invoke SET magic, writing the pointer address to memory.
    $$ppp_val = $pp_val;

    # Call Function
    $set_deep->( $ppp_val, 12345 );

    # Verification
    is $$p_val, 12345, '***int deep write successful via Pins';

    # Cleanup (Freeing the originals clears the memory)
    Affix::free($p_mem);
    Affix::free($pp_mem);
    Affix::free($ppp_mem);

    # Manual Memory Management (malloc/free/cast)
    isa_ok my $get_heap = wrap( $lib_path, 'get_heap_int', [Int] => Pointer [Int] ), ['Affix'];

    # Alias libc free to avoid conflict with Affix::free
    diag affix( $lib_path, 'libc_free', [ Pointer [Void] ] => Void );
    my $heap_ptr = $get_heap->(99);
    ok $heap_ptr, 'Received pointer from C';
    is $$heap_ptr, 99, 'Dereferenced managed pointer value';
    $$heap_ptr = 88;
    is $$heap_ptr, 88, 'Modified heap memory via magic deref';
    my $void_alias = Affix::cast( $heap_ptr, Pointer [Void] );
    my $addr       = $$void_alias;
    ok $addr > 0, 'Cast to void*, deref returns address';
    my $int_alias = Affix::cast( $void_alias, Pointer [Int] );