view release on metacpan or  search on metacpan

xt/corrupt_shm.t  view on Meta::CPAN

use strict;
use warnings;
use Test::More;
use Config;
use POSIX ':sys_wait_h';
use File::Temp qw(tempdir);
use Data::SortedSet::Shared;

plan skip_all => 'fork required' unless $Config{d_fork};

# Defense-in-depth for a hostile segment: node indices and index-slot state
# bytes live in peer-writable shared memory.  These tests corrupt the mapping
# through the backing file (MAP_SHARED: immediately visible) and then call the
# write paths in a child process:
#   * F3: a poisoned B+tree child pointer must stop the write paths (insert,
#     delete, merge, underflow) instead of a wild read/write under the lock.
#   * F4: an all-occupied member index must bound the open-addressing probe
#     (and the backward-shift delete scan) by the table size instead of
#     spinning forever under the lock.
#   * F6: add_many must keep the rows array alive across element magic.
# The children run under a parent-side watchdog: the unguarded code spins in
# pure C, where Perl signal handlers never fire, so alarm() cannot be used.

# Shared-memory layout constants (must match sortedset.h; the geometry is
# cross-checked against stats() at runtime).
use constant {
    HEADER_SIZE   => 256,
    READER_SLOTS  => 1024,
    SLOT_SIZE     => 16,
    OCC_BYTES     => 128,
    IDX_SLOT_SIZE => 24,   # int64 member + double score + uint8 state, padded
    IDX_STATE_OFF => 16,
    NODE_SIZE     => 424,
    NODE_CHILDREN => 288,  # offsetof(SsNode, children)
    HDR_ROOT_OFF  => 56,
};

sub index_off { HEADER_SIZE + READER_SLOTS * SLOT_SIZE + OCC_BYTES }   # 16768
sub nodes_off { my ($slots) = @_; (index_off() + $slots * IDX_SLOT_SIZE + 7) & ~7 }

# run a vulnerable snippet in a child; return (reaped?, status)
sub run_child {
    my ($code) = @_;
    my $pid = fork();
    die "fork: $!" unless defined $pid;
    unless ($pid) { $code->(); POSIX::_exit(0) }
    my $done; my $deadline = time + 10;
    while (time < $deadline) {
        my $r = waitpid($pid, WNOHANG);
        if ($r == $pid) { $done = 1; last }
        select undef, undef, undef, 0.05;
    }
    if (!$done) { kill 9, $pid; waitpid($pid, 0); }
    return ($done, $?);
}

# --- F4: corrupt all-occupied member index -----------------------------------
{
    my $dir  = tempdir(CLEANUP => 1);
    my $path = "$dir/idx.ss";
    my $z = Data::SortedSet::Shared->new($path, 8);   # index_slots == 16
    $z->add($_, $_ + 0.5) for 1 .. 4;
    my $slots = $z->stats->{index_slots};
    die "test setup: expected 16 index slots, got $slots" unless $slots == 16;

    # Flip every index slot's state byte to "occupied".  Members left as-is
    # (real members 1..4, zeros elsewhere); none equals the probe member 999.
    open my $fh, '+<', $path or die $!;
    for my $i (0 .. $slots - 1) {
        sysseek $fh, index_off() + $i * IDX_SLOT_SIZE + IDX_STATE_OFF, 0 or die $!;
        syswrite $fh, "\x01" or die $!;
    }
    close $fh;

    my ($done, $st) = run_child(sub {
        # Each of these hits an unbounded loop without the fix, in order:
        # ss_idx_find (add's absent-member probe), ss_idx_del's backward-shift
        # scan (remove), ss_idx_find again (exists).
        my $a = $z->add(999, 9.5);        # must fail cleanly (undef), not spin/clobber
        my $r = $z->remove(2);            # present member: bounded shift scan