view release on metacpan or  search on metacpan

t/093_malloc_lifeline.t  view on Meta::CPAN

use v5.40;
use blib;
use Test2::Tools::Affix qw[:all];
use Test2::V0 -no_srand => 1;
use Affix qw[:all];
#
my $orig_destroy = \&Affix::Memory::DESTROY;
my $destroyed    = 0;
no warnings qw[redefine prototype];
*Affix::Memory::DESTROY = sub { $destroyed++; $orig_destroy->(@_); };
#
$|++;
#
my $C_CODE = <<'END_C';
#include "std.h"
//ext: .c

#include <stdlib.h>

DLLEXPORT int read_int_from_void_ptr(void* p) {
    if (!p) return -999;
    return *(int*)p;
}

DLLEXPORT int sum_int_array(int* arr, int count) {
    int total = 0;
    for (int i = 0; i < count; i++)
        total += arr[i];
    return total;
}
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;
affix $lib_path, 'sum_int_array',          [ Pointer [Int], Int ], Int;
#
subtest 'malloc: memory survives while the pin is alive' => sub {
    my $a          = malloc(64);
    my $a_addr     = address($a);
    my $collisions = 0;
    for ( 1 .. 10_000 ) {
        my $p = malloc(64);
        $collisions++ if address($p) == $a_addr;
    }
    is $collisions, 0, 'live block is never handed out again';
};
#
subtest 'malloc: memory is reclaimed once the pin is released' => sub {
    my $before = $destroyed;
    my $addr;
    {
        my $p = malloc(64);
        $addr = address($p);
    }
    is $destroyed, $before + 1, 'releasing the pin destroyed the Affix::Memory object and freed the memory';

    # Address reuse is an allocator implementation detail (glibc does not
    # guarantee prompt reuse and varies with prior heap state), so it is
    # diagnostic only; the refcount check above is the actual reclaim proof.
    my $reclaimed = 0;
    for ( 1 .. 10000 ) {
        my $p = malloc(64);
        $reclaimed++ if address($p) == $addr;
    }
    is $destroyed, $before + 1 + 10000, 'every allocation in the reuse loop was destroyed exactly once';
    note "freed block address was reused $reclaimed/10000 times";
};
#
subtest 'malloc: free() works across statements' => sub {
    ok no_warnings {
        my $ptr = malloc(64);
        ok $ptr,       'malloc returned a pin';
        ok free($ptr), 'free() on malloc pin returns true';
    }, 'no "unmanaged pointer" warning';
};
#
subtest 'calloc: zero-initialized and free()-able' => sub {
    ok no_warnings {
        my $arr = calloc( 4, sizeof Int );
        ok $arr, 'calloc returned a pin';
        is sum_int_array( $arr, 4 ), 0, 'calloc memory is zero-initialized';
        ok free($arr), 'free() on calloc pin returns true';
    }, 'no "unmanaged pointer" warning';
};
#
subtest 'realloc: grows and preserves data' => sub {
    my $r = calloc( 2, sizeof Int );
    ok $r, 'calloc returned a pin';
    my $small = cast( $r, Array [ Int, 2 ] );
    $small->[0] = 10;
    $small->[1] = 20;
    ok realloc( $r, 32 ), 'realloc grew to 32 bytes';
    my $big = cast( $r, Array [ Int, 8 ] );
    is $big->[0], 10, 'data preserved at index 0 after realloc';
    is $big->[1], 20, 'data preserved at index 1 after realloc';

    # realloc() preserves but does not zero the extension; write every slot