view release on metacpan or  search on metacpan

t/148-foundation-runner-group-kill.t  view on Meta::CPAN

            }
        }
        closedir $d;
    };

    # Spin a watcher for up to 6s while the runner is in max_runtime.
    my $watcher_pid = fork // die "fork watcher: $!";
    if ( $watcher_pid == 0 ) {
        # child watcher: poll /proc every 100ms for 6s, then exit.
        for my $i ( 1 .. 60 ) {
            $watcher->();
            select undef, undef, undef, 0.1;
        }
        exit 0;
    }

    my $f = App::karr::Foundation->new( _config_data => {} );
    my $start = time;
    my ( $code, $out ) = $f->_run_command(
        $repo, { max_runtime => 1 }, $cmd,
    );
    my $elapsed = time - $start;

    reap_wait($watcher_pid);

    # The runner should report SIGTERM death and have killed the agent
    # promptly -- not waited 30s for the foreground sleep to finish.
    is $code, 143, 'timed-out run reports 128+SIGTERM';
    ok $elapsed < 10, "killed promptly (took ${elapsed}s)"
        or diag "the runner waited the full sleep -- group kill is broken";

    # The bug-shaped check: nothing under /tmp/* should still be running
    # a `sleep 30`. The watcher polled /proc while the run was live and
    # afterwards; if any of those sleeps survived the runner, it is
    # either our reaped watcher (impossible -- it does not run sleep 30)
    # or an orphan that the group kill missed.
    my @still_running;
    opendir my $d, '/proc' or die "opendir /proc: $!";
    while ( my $entry = readdir($d) ) {
        next unless $entry =~ /^\d+$/;
        next if $entry == $$;                  # the test itself
        my $cmdline = safe_slurp("/proc/$entry/cmdline") // next;
        $cmdline =~ s/\0/ /g;
        # The watcher has exited; filter its defunct shell (a `sh -c`
        # looping select) by parent. /proc/<pid>/status has PPid.
        my $status = safe_slurp("/proc/$entry/status") // next;
        my ($ppid) = $status =~ /^PPid:\s*(\d+)/m;
        next if defined $ppid && $ppid == $test_pid;
        if ( $cmdline =~ /sleep 30/ ) {
            push @still_running, [ $entry, $cmdline, $ppid ];
        }
    }
    closedir $d;

    ok !@still_running, 'no orphan sleep 30 left on the box'
        or diag "survivors: @{[ map { join('/',@$_) } @still_running ]}";
};

# Group identity: the agent's pgid must equal its own pid, because the
# runner relies on `kill 'TERM', -$pgid` to signal the whole group. We
# spawn the runner, peek at /proc/<pid>/stat while it is alive, and
# confirm pgid == pid.
subtest 'runner puts the agent in a process group whose pgid is its own pid' => sub {
    my $repo = path( tempdir( CLEANUP => 1 ) );
    my $cmd  = 'sleep 5';

    # Fork a child that drives the runner; the parent watches /proc.
    my $driver_pid = fork // die "fork driver: $!";
    if ( $driver_pid == 0 ) {
        # child driver
        my $f = App::karr::Foundation->new( _config_data => {} );
        $f->_run_command( $repo, { max_runtime => 8 }, $cmd );
        exit 0;
    }

    # Poll for the agent up to 5s.
    my $agent_pid;
    my $end = time + 5;
    while ( time < $end && !$agent_pid ) {
        opendir my $d, '/proc' or die;
        while ( my $entry = readdir($d) ) {
            next unless $entry =~ /^\d+$/;
            next if $entry == $$ || $entry == $driver_pid;
            my $cmdline = safe_slurp("/proc/$entry/cmdline") // next;
            $cmdline =~ s/\0/ /g;
            my $status  = safe_slurp("/proc/$entry/status") // next;
            my ($ppid) = $status =~ /^PPid:\s*(\d+)/m;
            # The driver forked the agent; the agent's ppid is the driver.
            next unless defined $ppid && $ppid == $driver_pid;
            if ( $cmdline =~ /sleep 5/ ) {
                $agent_pid = $entry;
                last;
            }
        }
        closedir $d;
        select undef, undef, undef, 0.05 unless $agent_pid;
    }

    ok $agent_pid, 'found the agent process'
        or diag 'no child of the driver was running sleep 5';

    SKIP: {
        skip 'no agent to inspect', 2 unless $agent_pid;

        my $pgid = pgid_of($agent_pid);
        is $pgid, $agent_pid,
            "agent's pgid equals its own pid ($agent_pid); runner can signal the group"
            or diag "agent $agent_pid has pgid $pgid -- group kill would miss";

        # And it is not the test's group -- the runner has to create a
        # *new* group, not inherit ours, otherwise SIGTERM to the group
        # would also signal the test.
        isnt $pgid, $$, 'agent is in a new group, not the test\'s';
    }

    # Let the driver finish.
    reap_wait($driver_pid);
};

done_testing;