view release on metacpan or  search on metacpan

t/04-edge-cases.t  view on Meta::CPAN

is $str->get($s), $full, "Str full max_len";
is length($str->get($s)), 32, "Str full length";

# exceeds max_len — truncated
my $long = "y" x 100;
$str->set($s, $long);
is length($str->get($s)), 32, "Str truncated to max_len";
is $str->get($s), "y" x 32, "Str truncated content";

$str->free($s);

# --- Error paths ---

my $pool = Data::Pool::Shared::I64->new(undef, 5);

# out of range
eval { $pool->get(99) };
like $@, qr/out of range/, "get out of range";

eval { $pool->set(99, 1) };
like $@, qr/out of range/, "set out of range";

eval { $pool->free(99) };
like $@, qr/out of range/, "free out of range";

eval { $pool->is_allocated(99) };
like $@, qr/out of range/, "is_allocated out of range";

eval { $pool->owner(99) };
like $@, qr/out of range/, "owner out of range";

# not allocated
eval { $pool->get(0) };
like $@, qr/not allocated/, "get not allocated";

eval { $pool->set(0, 1) };
like $@, qr/not allocated/, "set not allocated";

# I64-specific errors on unallocated
eval { $pool->cas(0, 0, 1) };
like $@, qr/not allocated/, "cas not allocated";

eval { $pool->add(0, 1) };
like $@, qr/not allocated/, "add not allocated";

eval { $pool->incr(0) };
like $@, qr/not allocated/, "incr not allocated";

eval { $pool->decr(0) };
like $@, qr/not allocated/, "decr not allocated";

# slot_sv not allocated
eval { $pool->slot_sv(0) };
like $@, qr/not allocated/, "slot_sv not allocated";

# double free returns false
$s = $pool->alloc;
ok $pool->free($s), "first free ok";
ok !$pool->free($s), "double free returns false";

# slot_sv pins pool alive across pool-object scope exit
{
    my $sv;
    {
        my $p = Data::Pool::Shared->new(undef, 1, 16);
        my $ps = $p->alloc;
        $p->set($ps, "pintest\0\0\0\0\0\0\0\0\0");
        $sv = $p->slot_sv($ps);
    } # $p out of scope — magic must hold pool alive via refcount
    is substr($sv, 0, 7), "pintest", "slot_sv pins pool across scope exit";
}

# free_n croaks on undef slot (Pass 10 hardening)
eval { $pool->free_n([undef]) };
like $@, qr/undef slot/, "free_n croaks on undef element";
my @slots = map $pool->alloc, 1..3;
eval { $pool->free_n([$slots[0], undef, $slots[2]]) };
like $@, qr/undef slot/, "free_n croaks mid-array on undef";
is $pool->free_n([$slots[0], $slots[1], $slots[2]]), 3, "free_n clean array works";

# free_n with non-arrayref
eval { $pool->free_n("not an array") };
like $@, qr/expected arrayref/, "free_n non-arrayref croaks";

# --- alloc_n / free_n ---

$pool->reset;

my $batch = $pool->alloc_n(3);
ok ref $batch eq 'ARRAY', "alloc_n returns arrayref";
is scalar @$batch, 3, "alloc_n returned 3 slots";
is $pool->used, 3, "3 allocated after alloc_n";

# set values on batch
$pool->set($batch->[$_], $_ * 10) for 0..2;
is $pool->get($batch->[1]), 10, "batch slot value correct";

# free_n
my $freed = $pool->free_n($batch);
is $freed, 3, "free_n freed 3";
is $pool->used, 0, "0 used after free_n";

# alloc_n all-or-nothing: request more than available
$pool->alloc for 1..4;  # 4 of 5 used
my $too_many = $pool->alloc_n(3, 0);
ok !defined $too_many, "alloc_n returns undef when not enough (non-blocking)";
is $pool->used, 4, "no partial allocation left behind";

$pool->reset;

# alloc_n(0) returns empty arrayref
my $empty = $pool->alloc_n(0);
ok ref $empty eq 'ARRAY', "alloc_n(0) returns arrayref";
is scalar @$empty, 0, "alloc_n(0) is empty";

# free_n empty
is $pool->free_n([]), 0, "free_n([]) returns 0";

# --- allocated_slots ---

$pool->reset;
$pool->alloc_set(100);
$pool->alloc_set(200);
$pool->alloc_set(300);

my $slots = $pool->allocated_slots;
ok ref $slots eq 'ARRAY', "allocated_slots returns arrayref";
is scalar @$slots, 3, "allocated_slots has 3 entries";
my @vals = sort map { $pool->get($_) } @$slots;