view release on metacpan or  search on metacpan

t/103-collectorrunner-coverage.t  view on Meta::CPAN

# environ, which reads back as a defined empty string and drives the
# empty-environ return path.
#
# This used to delegate to `env -i sleep 30` and poll /proc/<pid>/cmdline for
# /sleep/, but the intermediate env process already matches that pattern in its
# own cmdline, so the poll returned on its first iteration - before env had
# exec'd sleep and installed the empty environment. Measured 10 runs out of 10,
# the environ at that moment was still the inherited one (1564 and 1820 bytes in
# two samples), so whether the routine below saw an empty environ at all came
# down to env finishing its exec inside the gap between the poll exiting and the
# call being made. Nothing pinned that: is($marker, undef) is satisfied just as
# well by a populated environ that lacks the key, so the empty-environ leg could
# stop being exercised without a single assertion failing. Clearing the
# environment in this very fork removes the intermediate process entirely, and
# the environ assertion below turns the precondition into a real one.
SKIP: {
    my ($sleep_bin) = grep { -x } qw(/bin/sleep /usr/bin/sleep);
    skip 'no sleep binary available to hold an empty environment open', 2 if !defined $sleep_bin;
    my $probe_title = 'dd-empty-environ-probe';
    my $child       = fork();
    die "fork failed: $!" if !defined $child;
    if ( !$child ) {
        %ENV = ();
        exec { $sleep_bin } $probe_title, '30' or CORE::exit(127);
    }
    # Poll on the exec'd argv[0], which only the post-exec process can show.
    #
    # The bound is 30 seconds, and it is measured rather than chosen (DD-482).
    # The previous bound was 500 polls -- 5 seconds -- and the coverage gate
    # failed on it while the plain suite passed. Instrumenting the loop showed
    # the bound expiring with the child still ALIVE in state R, having not yet
    # reached its exec: a Devel::Cover-instrumented child flushes its coverage
    # database before exec'ing, which took 678 polls (~6.8s) against 2 polls
    # plain. So the old bound sat just under what the gated run needs.
    #
    # Widening a poll loop is normally a smell, and in this repo it has been an
    # actual defect (a loop once widened past a sleep that was silently zero).
    # The difference is that the mechanism here was demonstrated before the
    # number was changed, and the timeout below now reports what it saw so a
    # future failure is diagnosable instead of a bare undef.
    my $probe_environ;
    my $probe_polls = 0;
    for ( 1 .. 3000 ) {
        $probe_polls = $_;
        my $cmdline = '';
        if ( open my $cf, '<', "/proc/$child/cmdline" ) { local $/; $cmdline = <$cf>; close $cf; }
        if ( defined $cmdline && index( $cmdline, $probe_title ) == 0 ) {
            if ( open my $ef, '<', "/proc/$child/environ" ) { local $/; $probe_environ = <$ef>; close $ef; }
            diag("probe child did not expose a readable environ after $probe_polls polls: $!")
              if !defined $probe_environ;
            last;
        }
        select undef, undef, undef, 0.01;
    }

    # A bare "got undef" says nothing about which of the two very different
    # failures happened: the child never reached its exec, or its environ could
    # not be read. Note that undef never means "the environ was empty" -- a
    # genuinely empty /proc/<pid>/environ reads back as '' with length 0.
    if ( !defined $probe_environ ) {
        my $alive = -e "/proc/$child" ? 'alive' : 'gone';
        my $state = eval {
            open my $st, '<', "/proc/$child/stat" or die;
            my $line = <$st>;
            close $st;
            ( split / /, $line )[2];
        } // '?';
        diag("probe gave up after $probe_polls polls; child is $alive in state $state and never exposed its exec'd argv[0]");
    }
    # Pin the precondition the coverage below depends on. Without this the
    # marker assertion is satisfied by any environ that lacks the key, so the
    # empty-environ leg can stop being exercised without a single test failing.
    is( $probe_environ, '', 'the probe child exposes a readable zero-length environ' );
    is( $runner->_read_process_env_marker( $child, 'ANY' ), undef, '_read_process_env_marker returns undef for an empty environ' );
    kill 9, $child;
    waitpid( $child, 0 );
}

# _read_process_title: proc cmdline path, then the ps fallback under a mocked
# capture so every exit-code and defined-title branch is exercised.
{
    my $title = $runner->_read_process_title($$);
    ok( defined $title && $title ne '', '_read_process_title reads the current process cmdline' );
}
{
    no warnings 'redefine';
    local *Developer::Dashboard::CollectorRunner::_read_proc_file = sub { return undef };
    {
        local *Developer::Dashboard::CollectorRunner::capture = sub { return ( 'ps-title   ', '', 0 ) };
        is( $runner->_read_process_title($$), 'ps-title', '_read_process_title trims a successful ps fallback title' );
    }
    {
        local *Developer::Dashboard::CollectorRunner::capture = sub { return ( '', '', 1 ) };
        is( $runner->_read_process_title($$), undef, '_read_process_title returns undef when the ps fallback exits non-zero' );
    }
    {
        local *Developer::Dashboard::CollectorRunner::capture = sub { return ( undef, '', undef ) };
        is( $runner->_read_process_title($$), undef, '_read_process_title returns undef when the ps fallback yields no title' );
    }
}

# _read_process_state: procfs parse variants plus the ps fallback.
{
    no warnings 'redefine';
    {
        local *Developer::Dashboard::CollectorRunner::_read_proc_file = sub { return '4242 (cmd) R 1 4242 4242' };
        is( $runner->_read_process_state($$), 'R', '_read_process_state parses a running state from procfs stat' );
    }
    {
        local *Developer::Dashboard::CollectorRunner::_read_proc_file = sub { return 'garbage-without-format' };
        local *Developer::Dashboard::CollectorRunner::capture         = sub { return ( ' Ss ', '', 0 ) };
        is( $runner->_read_process_state($$), 'S', '_read_process_state falls back to ps when procfs stat is unparseable' );
    }
    {
        local *Developer::Dashboard::CollectorRunner::_read_proc_file = sub { return '' };
        local *Developer::Dashboard::CollectorRunner::capture         = sub { return ( 'R', '', 0 ) };
        is( $runner->_read_process_state($$), 'R', '_read_process_state falls back to ps when procfs stat is empty' );
    }
    {
        local *Developer::Dashboard::CollectorRunner::_read_proc_file = sub { return undef };
        local *Developer::Dashboard::CollectorRunner::capture         = sub { return ( '', '', 1 ) };
        is( $runner->_read_process_state($$), undef, '_read_process_state returns undef when the ps fallback exits non-zero' );
    }
    {
        local *Developer::Dashboard::CollectorRunner::_read_proc_file = sub { return undef };
        local *Developer::Dashboard::CollectorRunner::capture         = sub { return ( undef, '', undef ) };
        is( $runner->_read_process_state($$), undef, '_read_process_state returns undef when the ps fallback yields no state' );
    }

t/103-collectorrunner-coverage.t  view on Meta::CPAN

        POSIX::_exit(0);
    }
    my $pidfile = $runner->_pidfile($name);
    open my $fh, '>', $pidfile or die $!;
    print {$fh} $child;
    close $fh;
    $runner->_write_loop_state( $name, { pid => $child, name => $name, process_name => $runner->_process_title($name), status => 'running' } );
    {
        no warnings 'redefine';
        local *Developer::Dashboard::CollectorRunner::_read_process_env_marker = sub { return $name };
        is( $runner->stop_loop($name), $child, 'stop_loop returns the pid of a managed loop it terminates' );
    }
    select undef, undef, undef, 0.2;
    ok( !kill( 0, $child ), 'stop_loop terminates the managed loop process' );
    waitpid( $child, 0 ) if kill 0, $child;
}

# Live managed loop under the Windows branch: no process-group kill.
{
    my $name  = 'stop.managed.windows';
    my $child = fork();
    die "fork failed: $!" if !defined $child;
    if ( !$child ) {
        $0 = $runner->_process_title($name);
        $ENV{DEVELOPER_DASHBOARD_LOOP_NAME} = $name;
        $SIG{TERM} = 'DEFAULT';
        select undef, undef, undef, 30;
        POSIX::_exit(0);
    }
    my $pidfile = $runner->_pidfile($name);
    open my $fh, '>', $pidfile or die $!;
    print {$fh} $child;
    close $fh;
    $runner->_write_loop_state( $name, { pid => $child, name => $name, process_name => $runner->_process_title($name), status => 'running' } );
    {
        no warnings 'redefine';
        local *Developer::Dashboard::CollectorRunner::is_windows               = sub { return 1 };
        local *Developer::Dashboard::CollectorRunner::_read_process_env_marker = sub { return $name };
        is( $runner->stop_loop($name), $child, 'stop_loop returns the managed loop pid on the Windows branch' );
    }
    select undef, undef, undef, 0.2;
    kill 9, $child;
    waitpid( $child, 0 ) if kill 0, $child;
}

# Already-reaped loop child: the reap short-circuits the kill path.
{
    my $name  = 'stop.reaped';
    my $child = fork();
    die "fork failed: $!" if !defined $child;
    if ( !$child ) { POSIX::_exit(0); }
    my $pidfile = $runner->_pidfile($name);
    open my $fh, '>', $pidfile or die $!;
    print {$fh} $child;
    close $fh;
    $runner->_write_loop_state( $name, { pid => $child, name => $name, process_name => $runner->_process_title($name), status => 'running' } );
    select undef, undef, undef, 0.1;
    is( $runner->stop_loop($name), $child, 'stop_loop returns the pid of an already-exited loop it reaps' );
}

# Foreign-namespace loop: pid is alive but reported in another namespace.
{
    my $name  = 'stop.foreign';
    my $child = fork();
    die "fork failed: $!" if !defined $child;
    if ( !$child ) { $SIG{TERM} = 'DEFAULT'; select undef, undef, undef, 30; POSIX::_exit(0); }
    my $pidfile = $runner->_pidfile($name);
    open my $fh, '>', $pidfile or die $!;
    print {$fh} $child;
    close $fh;
    {
        no warnings 'redefine';
        local *Developer::Dashboard::CollectorRunner::_same_pid_namespace = sub { return 0 };
        is( $runner->stop_loop($name), $child, 'stop_loop returns a foreign-namespace pid without signalling it' );
    }
    ok( kill( 0, $child ), 'stop_loop leaves a foreign-namespace loop running' );
    kill 9, $child;
    waitpid( $child, 0 ) if kill 0, $child;
}

# Unrecognized live loop with recorded worker pids: else-branch worker sweep.
{
    my $name  = 'stop.unrecognized';
    my $child = fork();
    die "fork failed: $!" if !defined $child;
    if ( !$child ) { $SIG{TERM} = 'DEFAULT'; select undef, undef, undef, 30; POSIX::_exit(0); }
    my $pidfile = $runner->_pidfile($name);
    open my $fh, '>', $pidfile or die $!;
    print {$fh} $child;
    close $fh;
    $runner->_write_loop_state( $name, { pid => $child, name => $name, process_name => 'unrelated-title', status => 'running', active_worker_pids => [ 2000000001 ] } );
    {
        no warnings 'redefine';
        local *Developer::Dashboard::CollectorRunner::_read_process_env_marker  = sub { return undef };
        local *Developer::Dashboard::CollectorRunner::_read_process_title       = sub { return 'unrelated-title' };
        local *Developer::Dashboard::CollectorRunner::_state_confirms_managed_loop = sub { return 0 };
        local *Developer::Dashboard::CollectorRunner::_terminate_loop_workers   = sub { return 1 };
        is( $runner->stop_loop($name), $child, 'stop_loop sweeps recorded workers for an unrecognized live loop' );
    }
    kill 9, $child;
    waitpid( $child, 0 ) if kill 0, $child;
}

# ===========================================================================
# running_loops: empty pidfile, reaped child, managed loop, foreign loop, and
# an unrecognized (swept) loop.
# ===========================================================================
{
    # Use a fresh runtime so the collectors root holds only these pidfiles and
    # every readdir branch/condition outcome is exercised deterministically.
    my $rl_home  = tempdir( CLEANUP => 1 );
    my $rl_paths = Developer::Dashboard::PathRegistry->new( home => $rl_home, workspace_roots => [ File::Spec->catdir( $rl_home, 'workspace' ) ] );
    my $rl_runner = Developer::Dashboard::CollectorRunner->new(
        collectors => Developer::Dashboard::Collector->new( paths => $rl_paths ),
        files      => Developer::Dashboard::FileRegistry->new( paths => $rl_paths ),
        indicators => Developer::Dashboard::IndicatorStore->new( paths => $rl_paths ),
        paths      => $rl_paths,
    );
    my $root = $rl_paths->collectors_root;

    # Empty pidfile -> skipped on the falsy-pid guard (slurps to undef).