view release on metacpan or  search on metacpan

t/IPCShareableTest.pm  view on Meta::CPAN

# when the limit cannot be determined. Unlike low_sem_resources() -- which
# looks only at the LIMIT -- this accounts for sets already consumed, eg. by a
# concurrent smoker or stale sets leaked by previously crashed runs, which is
# what actually starves semget() into ENOSPC on wedged hosts.

sub free_sem_sets {
    my $limit = sem_set_limit();

    return undef if ! defined $limit;

    my $free = $limit - IPC::Shareable::sem_count();

    return $free < 0 ? 0 : $free;
}

# Count of IPC::Shareable segments currently live and owned by THIS process
# (a tied structure's root plus its nested-reference children), via the
# module's own global register. Process-scoped, so it is immune to unrelated
# IPC activity from other processes -- and unlike tree_seg_count() it works for
# every serializer, including the binary 'storable' format whose child links
# shm_segments() cannot parse back out of segment content.

sub live_seg_count {
    return scalar keys %{ IPC::Shareable->global_register };
}

my $_low_sem_cache;

# True when the host has a small SysV semaphore-set budget (see LOW_SEM_SETS),
# such that a test that creates many tied variables without releasing them
# between steps would exhaust it. Each tie consumes one semaphore set, and on
# OpenBSD the default kern.seminfo.semmni is only 10. An undeterminable limit is
# treated as NOT constrained, so behaviour changes only on platforms we can
# positively identify as small. Cached: the underlying probe runs once.

sub low_sem_resources {
    return $_low_sem_cache if defined $_low_sem_cache;

    my $limit = sem_set_limit();
    $_low_sem_cache = (defined $limit && $limit < LOW_SEM_SETS) ? 1 : 0;

    return $_low_sem_cache;
}

# Release every IPC::Shareable segment this process currently holds, but ONLY on
# hosts with a small semaphore-set budget (see low_sem_resources()). A test that
# creates many tied variables calls this between independent steps to stay under
# the limit. On roomy platforms it is a no-op, so the test's behaviour there is
# unchanged.

sub relieve_ipc_pressure {
    IPC::Shareable::clean_up_all if low_sem_resources();
}

# Skip the entire test file when the host does not have at least $needed free
# SysV semaphore sets. Every tie consumes one set, so a file whose peak
# concurrent tie count cannot be satisfied dies mid-run with "Could not create
# semaphore set: No space left on device" (ENOSPC) -- the mass CPAN tester
# FAIL mode on OpenBSD smokers (semmni=10) pre-wedged by stale sets from
# previously crashed runs. Skipping is the honest grade there: the environment
# cannot run the file, and a FAIL cascade (croaking mid-test and leaking yet
# more IPC resources on the way down) helps nobody. No-op when the limit
# cannot be determined. Call it before the first tie, after testing_set().

sub require_free_sem_sets {
    my ($needed) = @_;

    $needed = FREE_SEM_SETS_NEEDED if ! defined $needed;

    my $free = free_sem_sets();

    return 1 if ! defined $free;

    if ($free < $needed) {
        plan skip_all => "insufficient free SysV semaphore sets "
                       . "(free: $free, need: $needed)";
    }

    return 1;
}

# Return the system-wide limit on SysV semaphore sets (SEMMNI) for the current
# platform, or undef if it cannot be determined. Each IPC::Shareable tie consumes
# one set, so this bounds how many live ties a process may hold at once.

sub sem_set_limit {
    # Reuse the module's own cross-platform probe rather than re-deriving the
    # per-OS sysctl names here: sysv_info() reads kern.sysv (macOS), kern.ipc
    # (FreeBSD), kern.seminfo (OpenBSD), and /proc (Linux). Call it as a class
    # method (it shift()s its invocant) and trap its die-on-missing-sysctl.
    my $info = eval { IPC::Shareable->sysv_info };
    return undef if ! $info;

    my $semmni = $info->{semmni};

    return defined $semmni && $semmni =~ /^\d+$/ ? $semmni : undef;
}

# Number of live IPC::Shareable segments in this glue's segment tree (the root
# plus any nested-reference child segments), as seen in the OS at the key
# level. Used by assert_clean() to confirm real cleanup. Note: only the JSON
# serializer records child links in a form shm_segments() can follow, so for
# measuring a live storable structure's size use live_seg_count() instead.

sub tree_seg_count {
    my ($glue) = @_;

    if (! defined $glue) {
        croak "tree_seg_count() requires a \$glue param";
    }

    my $segs = IPC::Shareable::shm_segments($glue);

    return scalar keys %$segs;
}

# Turn a human-readable base name into a glue string that is unique to this
# process. Deterministic within a process: unique_glue('foo') always returns
# the same string, in both the parent and any forked child, so both sides of a
# fork tie to the same key.