view release on metacpan or  search on metacpan

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 $runtime = Developer::Dashboard::PageRuntime->new( paths => $paths );
    my $web_page = Developer::Dashboard::PageDocument->new(
        title  => 'Web Coverage',
        layout => {
            body => qq{<script>const value = "x";</script><div onclick="go()">[% stash.name %]</div>},
        },
    );
    my $rendered = $web_page->render_html;
    my $auth = Developer::Dashboard::Auth->new( files => $files, paths => $paths );
    my $sessions = Developer::Dashboard::SessionStore->new( paths => $paths );
    my $actions = Developer::Dashboard::ActionRunner->new( files => $files, paths => $paths );
    my $prompt = Developer::Dashboard::Prompt->new( indicators => $indicator_store, paths => $paths );
    my $app = Developer::Dashboard::Web::App->new(
        actions  => $actions,
        auth     => $auth,
        pages    => $store,
        prompt   => $prompt,
        runtime  => $runtime,
        sessions => $sessions,
    );

    like( Developer::Dashboard::Web::App::_highlight_js_text( undef, q{const value = "x"; // note} ), qr/tok-js/, 'web app JS highlighter marks JavaScript keywords' );
    like( Developer::Dashboard::Web::App::_highlight_js_text( undef, q{const value = 'x';} ), qr/tok-string/, 'web app JS highlighter marks single-quoted JavaScript strings' );
    like( Developer::Dashboard::Web::App::_highlight_css_text( undef, q{body { color: red; }} ), qr/tok-css|tok-attr|tok-value/, 'web app CSS highlighter supports direct package-style calls' );
    like( Developer::Dashboard::Web::App::_highlight_css_text( undef, q{/* note */ body { color: red; }} ), qr/tok-comment/, 'web app CSS highlighter marks CSS comments' );
    like( Developer::Dashboard::Web::App::_highlight_perl_text( undef, q{my $value = 1;} ), qr/tok-perl-keyword/, 'web app Perl highlighter supports direct package-style calls' );