view release on metacpan or  search on metacpan

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

    # mutate the returned value
    $got .= " world";
    is($got, "hello world", 'local mutation works');

    # shared value should be unchanged
    my $stored = shm_ss_get $map, "key1";
    is($stored, "hello", 'shared value unchanged after mutating returned SV');

    # second call should return existing value (also a copy)
    my $got2 = shm_ss_get_or_set $map, "key1", "other";
    is($got2, "hello", 'get_or_set returns existing value on second call');

    unlink $path;
}

# put_ttl with ttl_sec=0 creates permanent entry on TTL-enabled map
{
    my $path = tmpfile();
    my $map = Data::HashMap::Shared::II->new($path, 1000, 0, 2);

    shm_ii_put_ttl $map, 1, 100, 0;  # permanent
    shm_ii_put $map, 2, 200;         # default TTL (2s)

    my $rem1 = shm_ii_ttl_remaining $map, 1;
    is($rem1, 0, 'ttl_remaining is 0 for permanent entry');

    my $rem2 = shm_ii_ttl_remaining $map, 2;
    ok(defined $rem2 && $rem2 > 0, 'ttl_remaining > 0 for TTL entry');

    sleep 3;

    # permanent entry survives
    my $v1 = shm_ii_get $map, 1;
    is($v1, 100, 'permanent entry (ttl=0) survives past default TTL');

    # TTL entry expired
    my $v2 = shm_ii_get $map, 2;
    ok(!defined $v2, 'default TTL entry expired');

    unlink $path;
}

# stale write lock recovery: simulate dead process holding wrlock
{
    my $path = tmpfile();
    my $map = Data::HashMap::Shared::II->new($path, 1000);
    shm_ii_put $map, 1, 42;

    # Simulate a stale lock by forking a child that sets the lock and dies
    my $pid = fork();
    if ($pid == 0) {
        my $child_map = Data::HashMap::Shared::II->new($path, 1000);
        # Do a normal put to prove the child can access the map
        shm_ii_put $child_map, 2, 99;
        POSIX::_exit(0);
    }
    waitpid($pid, 0);

    # Now manually corrupt the lock to simulate the child dying while holding it.
    # The header is at the start of the mmap file. rwlock is at offset 128
    # and encodes 0x80000000 | pid when write-locked. seq is at offset 64.
    open my $fh, '+<:raw', $path or die "Cannot open $path: $!";
    # Set rwlock = 0x80000000 | $pid (write-locked by dead child)
    seek($fh, 128, 0);
    print $fh pack('V', 0x80000000 | $pid);
    # Set seq to odd (writer active)
    seek($fh, 64, 0);
    print $fh pack('V', 1);
    close $fh;

    # Re-open the map — the stale lock is now in the mmap
    undef $map;
    $map = Data::HashMap::Shared::II->new($path, 1000);

    # This should recover after SHM_LOCK_TIMEOUT_SEC (2s) since $pid is dead
    my $val = shm_ii_get $map, 1;
    # The data written before corruption should still be readable
    is($val, 42, 'recovered from stale lock without deadlock');
    ok(shm_ii_stat_recoveries($map) > 0, 'stat_recoveries incremented after recovery');

    unlink $path;
}

# error diagnostics: wrong variant gives informative message
{
    my $path = tmpfile();
    my $map = Data::HashMap::Shared::II->new($path, 100);
    shm_ii_put $map, 1, 1;
    undef $map;

    eval { Data::HashMap::Shared::SS->new($path, 100) };
    like($@, qr/variant mismatch/, 'variant mismatch gives diagnostic error');
    like($@, qr/file=\d+, expected=\d+/, 'error includes variant IDs');

    unlink $path;
}

# error diagnostics: bad path gives errno message
{
    eval { Data::HashMap::Shared::II->new('/nonexistent/path/test.shm', 100) };
    like($@, qr/No such file|Permission denied/, 'bad path gives errno in error');
}

# unlink: instance method
{
    my $path = tmpfile();
    my $map = Data::HashMap::Shared::II->new($path, 100);
    shm_ii_put $map, 1, 42;
    ok(-f $path, 'backing file exists');
    ok($map->unlink, 'instance unlink returns true');
    ok(!-f $path, 'backing file removed after unlink');
    # map still works (mmap stays alive after unlink)
    my $v = shm_ii_get $map, 1;
    is($v, 42, 'map still readable after unlink');
}

# unlink: class method
{
    my $path = tmpfile();
    my $map = Data::HashMap::Shared::II->new($path, 100);
    undef $map;
    ok(-f $path, 'backing file exists before class unlink');
    ok(Data::HashMap::Shared::II->unlink($path), 'class unlink returns true');