view release on metacpan or  search on metacpan

t/14-coverage-closure-extra.t  view on Meta::CPAN

    my @loops = $runner->running_loops;
    is( scalar @loops, 1, 'running_loops lists active managed loop pids' );
    is( $loops[0]{name}, $loop_name, 'running_loops returns the managed loop name' );

    $collector_store->mark_run_started( $loop_name, {} );
    ok( $collector_store->read_status($loop_name)->{running}, 'collector status reports running before the loop is stopped' );

    my $stopped_pid = $runner->stop_loop($loop_name);
    is( $stopped_pid, $managed_child, 'stop_loop returns managed loop pid' );
    waitpid( $managed_child, 0 );
    ok( !-e $pidfile, 'stop_loop removes loop pid files after forced kill' );
    ok( !-e $statefile, 'stop_loop removes loop state files after forced kill' );

    my $status_after_stop = $collector_store->read_status($loop_name) || {};
    ok( !$status_after_stop->{running}, 'stop_loop resets the consumer-facing running flag so a stopped collector is no longer reported as running' );
    is( $status_after_stop->{active_runs}, 0, 'stop_loop clears active_runs when the loop is stopped so in-flight counters do not linger' );
}

{
    is( $collector_store->mark_stopped('never.seeded.collector'), undef, 'mark_stopped is a no-op when the collector has no status file yet' );

    $collector_store->mark_run_started( 'reset.direct.collector', {} );
    ok( $collector_store->read_status('reset.direct.collector')->{running}, 'seeded collector status reports running' );
    is( $collector_store->read_status('reset.direct.collector')->{active_runs}, 1, 'seeded collector status reports one active run' );

    $collector_store->mark_stopped('reset.direct.collector');
    my $reset = $collector_store->read_status('reset.direct.collector');
    ok( !$reset->{running}, 'mark_stopped clears the running flag directly' );
    is( $reset->{active_runs}, 0, 'mark_stopped clears active_runs directly' );
    ok( defined $reset->{stopped_at} && $reset->{stopped_at} ne '', 'mark_stopped records when the collector was stopped' );
}

{
    # Fix A: a just-spawned worker must be persisted to active_worker_pids
    # immediately, not only at the top of the next iteration, so a crash cannot
    # orphan a worker that is invisible to the persisted state.
    my $persist_name = 'coverage.persist.on.spawn';
    my $child = fork();
    die "fork failed: $!" if !defined $child;
    if ( !$child ) {
        no warnings 'redefine';
        local *Developer::Dashboard::CollectorRunner::_job_is_due = sub { return 1 };
        my $ok = $runner->_run_loop_child(
            daemonize     => 0,
            interval      => 1,
            job           => { command => 'sleep 30', cwd => $home },
            name          => $persist_name,
            schedule_mode => 'interval',
            single_tick   => 1,
            title         => $runner->_process_title($persist_name),
        );
        exit( $ok ? 0 : 1 );
    }
    waitpid( $child, 0 );
    my @persisted = $runner->_state_active_worker_pids($persist_name);
    ok( scalar(@persisted) >= 1, 'loop persists active_worker_pids immediately on spawn so a just-started worker survives a crash-and-stop' );
    for my $wpid (@persisted) { kill 9, -$wpid; kill 9, $wpid; }
}

{
    # Fix D (Facet 1c): a command child that ignores SIGTERM stays alive in the
    # worker's process group after the worker (group leader) exits; pass 2 must
    # send the group SIGKILL unconditionally to reap it.
    my $gc_file = File::Spec->catfile( $home, "trapgc.$$" );
    unlink $gc_file;
    my $worker = fork();
    die "fork failed: $!" if !defined $worker;
    if ( !$worker ) {
        setsid();
        my $gc = fork();
        if ( !defined $gc ) { exit 1 }
        if ( !$gc ) {
            $SIG{TERM} = 'IGNORE';
            select undef, undef, undef, 60;
            exit 0;
        }
        open my $gf, '>', $gc_file or exit 1;
        print {$gf} $gc;
        close $gf;
        $SIG{TERM} = 'DEFAULT';
        select undef, undef, undef, 60;
        exit 0;
    }
    my $gc_pid = '';
    for ( 1 .. 60 ) { last if -s $gc_file; select undef, undef, undef, 0.05; }
    if ( open my $gf, '<', $gc_file ) { local $/; $gc_pid = <$gf>; close $gf; }
    $gc_pid =~ s/\s+//g;
    ok( $gc_pid && kill( 0, $gc_pid ), 'SIGTERM-ignoring command child is running before termination' );
    $runner->_terminate_loop_workers( { $worker => 1 } );
    select undef, undef, undef, 0.3;
    ok( !kill( 0, $gc_pid ), '_terminate_loop_workers group-SIGKILLs a SIGTERM-ignoring child left in a dead worker process group' );
    kill 9, -$worker; kill 9, $worker; waitpid( $worker, 0 ) if kill 0, $worker;
    unlink $gc_file;
}

{
    # Fix E (Facet 5): on a proc-blind host (no /proc, no ps: Windows) a live
    # loop recorded in loop.json must still be recognized from its pid/name/title
    # even when its status is outside the old whitelist, so stop can kill it.
    my $ename  = 'coverage.confirm.broadened';
    my $echild = fork();
    die "fork failed: $!" if !defined $echild;
    if ( !$echild ) { $SIG{TERM} = 'DEFAULT'; select undef, undef, undef, 60; exit 0; }
    my $epidfile = $runner->_pidfile($ename);
    open my $ef, '>', $epidfile or die $!;
    print {$ef} $echild;
    close $ef;
    $runner->_write_loop_state(
        $ename,
        {
            pid          => $echild,
            name         => $ename,
            process_name => $runner->_process_title($ename),
            status       => 'attention',
        }
    );
    my $ret;
    {
        no warnings 'redefine';
        local *Developer::Dashboard::CollectorRunner::_read_process_title      = sub { return undef };
        local *Developer::Dashboard::CollectorRunner::_read_process_env_marker = sub { return undef };

t/14-coverage-closure-extra.t  view on Meta::CPAN

        },
        'start_loop child path dispatches the expected collector job hash',
    );
}

{
    my $loop_name = 'coverage.loop.inline';
    no warnings 'redefine';
    local *Developer::Dashboard::CollectorRunner::_job_is_due = sub { return 1 };
    local *Developer::Dashboard::CollectorRunner::run_once     = sub { return { ok => 1 } };
    ok(
        $runner->_run_loop_child(
            daemonize     => 0,
            interval      => 0,
            job           => { command => 'printf inline', cwd => $home },
            name          => $loop_name,
            schedule_mode => 'interval',
            single_tick   => 1,
            title         => $runner->_process_title($loop_name),
        ),
        '_run_loop_child can execute a single non-daemonized coverage tick',
    );
    my $state = $runner->loop_state($loop_name);
    is( $state->{status}, 'running', '_run_loop_child non-daemonized tick still writes running state' );
}

{
    my $loop_name = 'coverage.loop.scrub';
    my $seen_file = File::Spec->catfile( $paths->state_root, 'coverage-loop-scrub.json' );
    my $child_pid = fork();
    die "fork failed: $!" if !defined $child_pid;
    if ( !$child_pid ) {
        no warnings 'redefine';
        local $ENV{PERL5OPT} = '-MDevel::Cover';
        local $ENV{HARNESS_PERL_SWITCHES} = '-MDevel::Cover';
        local *Developer::Dashboard::CollectorRunner::_job_is_due = sub { return 1 };
        local *Developer::Dashboard::CollectorRunner::run_once = sub {
            my ($self, $job) = @_;
            open my $fh, '>', $seen_file or die "Unable to write $seen_file: $!";
            print {$fh} json_encode(
                {
                    perl5opt               => ( defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : '' ),
                    harness_perl_switches  => ( defined $ENV{HARNESS_PERL_SWITCHES} ? $ENV{HARNESS_PERL_SWITCHES} : '' ),
                }
            );
            close $fh;
            return { ok => 1 };
        };
        my $ok = $runner->_run_loop_child(
            daemonize     => 0,
            interval      => 0,
            job           => { command => 'printf scrub', cwd => $home },
            name          => $loop_name,
            schedule_mode => 'interval',
            single_tick   => 1,
            title         => $runner->_process_title($loop_name),
        );
        exit( $ok ? 0 : 1 );
    }
    waitpid( $child_pid, 0 );
    is( $? >> 8, 0, '_run_loop_child keeps a coverage-instrumented child alive long enough to execute one scrubbed tick' );
    open my $seen_fh, '<', $seen_file or die "Unable to read $seen_file: $!";
    my $seen = json_decode( do { local $/; <$seen_fh> } );
    close $seen_fh;
    is( $seen->{perl5opt}, '', '_run_loop_child clears PERL5OPT inside managed collector children when coverage instrumentation is active' );
    is( $seen->{harness_perl_switches}, '', '_run_loop_child clears HARNESS_PERL_SWITCHES inside managed collector children when coverage instrumentation is active' );
}

{
    my $loop_name = 'coverage.loop.error';
    my $child_pid = fork();
    die "fork failed: $!" if !defined $child_pid;
    if ( !$child_pid ) {
        no warnings 'redefine';
        local *Developer::Dashboard::CollectorRunner::_job_is_due = sub { return 1 };
        local *Developer::Dashboard::CollectorRunner::run_once     = sub { die "forced child failure\n" };
        my $ok = $runner->_run_loop_child(
            daemonize     => 1,
            interval      => 0,
            job           => { command => 'printf child', cwd => $home },
            name          => $loop_name,
            schedule_mode => 'interval',
            single_tick   => 1,
            title         => $runner->_process_title($loop_name),
        );
        exit( $ok ? 0 : 1 );
    }
    waitpid( $child_pid, 0 );
    is( $? >> 8, 0, '_run_loop_child returns cleanly after one daemonized error tick' );
    my $state = $runner->loop_state($loop_name);
    is( $state->{status}, 'error', '_run_loop_child writes error state when a collector tick dies' );
    like( $state->{error}, qr/forced child failure/, '_run_loop_child persists the collector error message' );
}

{
    my @spawned;
    {
        no warnings 'redefine';
        local *Developer::Dashboard::CollectorRunner::is_windows = sub { return 1 };
        local *Developer::Dashboard::CollectorRunner::_windows_background_worker_command = sub {
            my ( undef, $name, $loop_pid ) = @_;
            return ( 'perl.exe', '_dashboard-core', 'collector-worker-foreground', '--name', $name, '--loop-pid', $loop_pid );
        };
        local *Developer::Dashboard::CollectorRunner::_spawn_windows_background_command = sub {
            my ( undef, @command ) = @_;
            @spawned = @command;
            return 7171;
        };
        is(
            $runner->_start_loop_worker( { command => 'true' }, 'windows.worker', 'dashboard collector: windows.worker' ),
            7171,
            '_start_loop_worker returns the detached Windows collector worker pid',
        );
    }
    is_deeply(
        \@spawned,
        [ 'perl.exe', '_dashboard-core', 'collector-worker-foreground', '--name', 'windows.worker', '--loop-pid', $$ ],
        '_start_loop_worker launches the detached Windows collector worker helper command',
    );
}