Async-Event-Interval
view release on metacpan or search on metacpan
a peer still holds LOCK_EX on the events knot
- stop() now polls kill(0) at STOP_KILL_POLL_INTERVAL (0.05s) for up
to STOP_KILL_TIMEOUT (1s) instead of always sleeping a fixed 1s;
returns as soon as the target process is gone (full test suite
wallclock roughly halved)
- Refactor error()/status() to remove their mutual-recursion
side-effect chain. Crash detection now lives in a private
_detect_crash helper that both methods call independently
- Retire the undocumented -99 PID sentinel that marked crashes
- stop() now sends SIGTERM first (STOP_TERM_TIMEOUT 0.5s) and escalates
to SIGKILL only if the child is still alive; _signal_and_wait() helper
encapsulates the signal-and-poll logic
- Replace mutable module-level $is_child_process flag with
$$ != $creator_pid check in DESTROY; a forked child inherently has
a different PID than the process that loaded the module, so no
mutable state that mock-fork tests can corrupt is needed
- Replace lexical $id counter with shared _id_counter in %events to
prevent duplicate IDs across forked processes
- Closes #15; Add _stop_requested cooperative flag in shared %events so the
child's interval loop can break cleanly and call finish() instead of being
killed by SIGTERM; stop() sets it, start() clears it, the loop checks it
lib/Async/Event/Interval.pm view on Meta::CPAN
# Set cooperative stop flag so a well-behaved child exits its event loop on
# the next iteration. The signals below act as a safety net for children
# stuck in a long-running callback.
_events_write(sub { $events{$self->id}{_stop_requested} = 1 });
# Try graceful SIGTERM first so a user-installed SIGTERM handler in the
# callback can do cleanup (close files, release locks, etc.).
# Escalate to SIGKILL if the child is still alive after STOP_TERM_TIMEOUT
# _signal_and_wait polls at STOP_KILL_POLL_INTERVAL and returns 1 as
# soon as the process is gone, so the common case is a single poll.
return if $self->_signal_and_wait('TERM', STOP_TERM_TIMEOUT);
return if $self->_signal_and_wait('KILL', STOP_KILL_TIMEOUT);
croak "Event stop was called, but the process hasn't been killed " .
"(SIGTERM + SIGKILL both ignored). This is a fatal event. " .
"Exiting...\n";
lib/Async/Event/Interval.pm view on Meta::CPAN
sub _started {
my ($self, $started) = @_;
$self->{started} = $started if defined $started;
return $self->{started};
}
# External access: These allow unit tests to directly access live data in the
# %events hash
sub _events_count {
# Number of events currently alive
return _events_read(sub { $events{_event_count} || 0 });
}
sub _events_knot {
# The IPC::Shareable knot itself
return tied(%events);
}
sub _events_next_id {
# Fetch the next ID that will be assigned to an event
return _events_read(sub { $events{_id_counter} || 0 });
}
t/09-locking.t view on Meta::CPAN
# No leaked alarm — alarm(0) returns the seconds remaining on any
# pending alarm, so a clean state returns 0.
is alarm(0), 0,
"_end() leaves no pending alarm in the global state";
}
# 2.2: stop() polls kill(0) at STOP_KILL_POLL_INTERVAL cadence for up to
# STOP_KILL_TIMEOUT seconds instead of always sleeping a fixed 1s. It
# returns as soon as the target process is gone, and croaks only if the
# process is still alive after the timeout.
# Constants exist and have sane values; poll interval < total timeout.
{
can_ok 'Async::Event::Interval', 'STOP_KILL_TIMEOUT';
can_ok 'Async::Event::Interval', 'STOP_KILL_POLL_INTERVAL';
cmp_ok Async::Event::Interval::STOP_KILL_TIMEOUT(), '>', 0,
"STOP_KILL_TIMEOUT is positive";
cmp_ok Async::Event::Interval::STOP_KILL_POLL_INTERVAL(), '>', 0,
"STOP_KILL_POLL_INTERVAL is positive";
t/09-locking.t view on Meta::CPAN
{
can_ok 'Async::Event::Interval', '_signal_and_wait';
}
# SIGTERM success: when a child dies from SIGTERM, stop() returns
# without ever escalating to SIGKILL. Uses the CORE::GLOBAL::kill mock
# to track signal order and simulate TERM-induced death.
{
my @signals_sent;
my $kill_zero_alive = 0; # count of kill(0) calls seen so far
local $kill_mock = sub {
my ($sig, @pids) = @_;
push @signals_sent, $sig;
if ($sig eq 'TERM') {
# After SIGTERM is delivered, subsequent kill(0) calls
# should report the process as dead.
$kill_zero_alive = 0;
return 1;
}
if ($sig eq '0') {
$kill_zero_alive++;
# Return alive for the first kill(0) (pre-TERM probe in
# _signal_and_wait's while loop), then dead afterwards
# (simulating TERM-induced death).
return $kill_zero_alive <= 1 ? 1 : 0;
}
return 1;
};
my $e = Async::Event::Interval->new(0, sub {});
$e->_pid(99999);
eval { $e->stop };
# stop() must have sent TERM (it always tries TERM first).
t/09-locking.t view on Meta::CPAN
}
# _signal_and_wait timeout: when kill(0) keeps returning truthy past
# the timeout, returns 0 (used by stop() to decide escalation).
{
my @kill_calls;
local $kill_mock = sub {
my ($sig, @pids) = @_;
push @kill_calls, $sig;
return 1; # always alive
};
my $e = Async::Event::Interval->new(0, sub {});
$e->_pid(99999);
use Time::HiRes ();
my $t0 = Time::HiRes::time();
my $rv = $e->_signal_and_wait('TERM',
Async::Event::Interval::STOP_TERM_TIMEOUT());
my $elapsed = Time::HiRes::time() - $t0;
t/13-shared_scalar_protected.t view on Meta::CPAN
is
$segs_after,
$segs_before,
"clean_up_all() does not remove the protected shared_scalar segment";
is
$$s,
"before clean_up_all",
"shared_scalar value still readable after clean_up_all() (segment intact)";
$$s = "still alive";
is
$$s,
"still alive",
"shared_scalar still writeable after clean_up_all()";
}
# 3) The owning event's DESTROY still removes the protected shared_scalar
# segment. $knot->remove ignores the 'protected' attribute (it only
# blocks bulk sweeps).
{
my $segs_at_start = IPC::Shareable::seg_count();
t/13-shared_scalar_protected.t view on Meta::CPAN
cmp_ok
IPC::Shareable::seg_count(),
'>',
$segs_at_start,
"creating event + shared_scalar increases seg_count";
# event goes out of scope → DESTROY → $knot->remove on the scalar
}
# AEI %events parent is still alive (protected); only the shared
# scalar (and the event's per-event child) should have been removed
# by DESTROY.
my $register = IPC::Shareable::global_register();
ok
! exists $register->{$seg_id},
"shared_scalar segment is gone from global_register after event DESTROY";
}
# 4) Multiple shared_scalars under the same event all share the same
t/68-shared_scalar_complex.t view on Meta::CPAN
$h->{c} = 3;
$$s = $h;
is ref($$s), 'HASH',
'mutate-then-store: scalar is still a HASH ref';
is scalar(keys %{ ref($$s) eq 'HASH' ? $$s : {} }), 0,
'mutate-then-store: hash ends up empty (pins POD-documented broken pattern)';
}
# 18. Event crash mid-write: the callback writes partial data, then dies.
# The shared_scalar segment is owned by the event object (still alive),
# so the partial write survives and the segment remains readable and
# writable from the parent.
{
my $s;
my $e = $mod->new(0, sub {
$$s = { phase => 'partial' };
die "callback died after partial write\n";
});
$s = $e->shared_scalar;
t/92-end_phased_cleanup.t view on Meta::CPAN
for (1..50) {
last if -e $flag_file;
select(undef, undef, undef, 0.1);
}
my $child_pid = $event->pid;
Async::Event::Interval::_end(1);
my $child_alive = kill(0, $child_pid);
open my $fh, '>', "$flag_file.result" or die "open: $!";
print $fh "$child_alive\n";
close $fh;
IPC::Shareable::_end();
POSIX::_exit(0);
}
waitpid $pid, 0;
SKIP: {
skip "result file not written", 1
unless -e "$flag_file.result";
open my $fh, '<', "$flag_file.result";
chomp(my $alive = <$fh>);
close $fh;
is $alive, 0,
"_end() killed event child (via %events or \@all_pids fallback)";
}
unlink $flag_file if -e $flag_file;
unlink "$flag_file.result" if -e "$flag_file.result";
}
# ---------------------------------------------------------------------------
# Test 3: Per-phase cleanup — later phases run even when earlier ones fail
# ---------------------------------------------------------------------------
( run in 0.814 second using v1.01-cache-2.11-cpan-df04353d9ac )